New tool: virt-dib

virt-dib is a new tool to run the elements of diskimage-builder using
libguestfs.
This commit is contained in:
Pino Toscano
2015-07-09 14:55:43 +02:00
parent 46be6934fc
commit 85fe0abdd0
14 changed files with 2282 additions and 1 deletions

5
.gitignore vendored
View File

@@ -118,6 +118,10 @@ Makefile.in
/df/stamp-virt-df.pod
/df/virt-df
/df/virt-df.1
/dib/.depend
/dib/stamp-virt-dib.pod
/dib/virt-dib
/dib/virt-dib.1
/diff/stamp-virt-diff.pod
/diff/virt-diff
/diff/virt-diff.1
@@ -245,6 +249,7 @@ Makefile.in
/html/virt-copy-out.1.html
/html/virt-customize.1.html
/html/virt-df.1.html
/html/virt-dib.1.html
/html/virt-diff.1.html
/html/virt-edit.1.html
/html/virt-filesystems.1.html

View File

@@ -134,6 +134,7 @@ SUBDIRS += \
mllib \
customize \
builder builder/website \
dib \
get-kernel \
resize \
sparsify \
@@ -355,7 +356,7 @@ all-local:
grep -v -E '^python/utils.c$$' | \
LC_ALL=C sort > po/POTFILES
cd $(srcdir); \
find builder customize get-kernel mllib resize sparsify sysprep v2v -name '*.ml' | \
find builder customize dib get-kernel mllib resize sparsify sysprep v2v -name '*.ml' | \
LC_ALL=C sort > po/POTFILES-ml
# Try to stop people using 'make install' without 'DESTDIR'.

View File

@@ -254,6 +254,18 @@ util-linux-ng
xfsprogs
zerofree
dnl tools needed by virt-dib
ifelse(REDHAT,1,
qemu-img
which
)
ifelse(DEBIAN,1,
qemu-utils
)
curl
dnl (virt-dib) tools optionally used for elements
debootstrap
ifelse(VALGRIND_DAEMON,1,valgrind)
dnl Define this by doing: ./configure --with-extra-packages="..."

View File

@@ -1729,6 +1729,7 @@ AC_CONFIG_FILES([Makefile
customize/Makefile
daemon/Makefile
df/Makefile
dib/Makefile
diff/Makefile
edit/Makefile
erlang/Makefile

144
dib/Makefile.am Normal file
View File

@@ -0,0 +1,144 @@
# libguestfs virt-dib tool
# Copyright (C) 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.
include $(top_srcdir)/subdir-rules.mk
EXTRA_DIST = \
$(SOURCES_ML) $(SOURCES_C) \
virt-dib.pod
CLEANFILES = *~ *.annot *.cmi *.cmo *.cmx *.cmxa *.o virt-dib
SOURCES_ML = \
utils.ml \
cmdline.ml \
elements.ml \
dib.ml
SOURCES_C = \
$(top_srcdir)/mllib/mkdtemp-c.c
bin_PROGRAMS =
if HAVE_OCAML
bin_PROGRAMS += virt-dib
virt_dib_SOURCES = $(SOURCES_C)
virt_dib_CPPFLAGS = \
-I. \
-I$(top_builddir) \
-I$(top_srcdir)/gnulib/lib -I$(top_builddir)/gnulib/lib \
-I$(shell $(OCAMLC) -where) \
-I$(top_srcdir)/gnulib/lib \
-I$(top_srcdir)/src
virt_dib_CFLAGS = \
-pthread \
$(WARN_CFLAGS) $(WERROR_CFLAGS)
BOBJECTS = \
$(top_builddir)/mllib/libdir.cmo \
$(top_builddir)/mllib/config.cmo \
$(top_builddir)/mllib/common_gettext.cmo \
$(top_builddir)/mllib/common_utils.cmo \
$(top_builddir)/mllib/mkdtemp.cmo \
$(SOURCES_ML:.ml=.cmo)
XOBJECTS = $(BOBJECTS:.cmo=.cmx)
# -I $(top_builddir)/src/.libs is a hack which forces corresponding -L
# option to be passed to gcc, so we don't try linking against an
# installed copy of libguestfs.
OCAMLPACKAGES = \
-package str,unix \
-I $(top_builddir)/src/.libs \
-I $(top_builddir)/gnulib/lib/.libs \
-I $(top_builddir)/ocaml \
-I $(top_builddir)/mllib
if HAVE_OCAML_PKG_GETTEXT
OCAMLPACKAGES += -package gettext-stub
endif
OCAMLCLIBS = \
-pthread -lpthread \
-lutils \
$(LIBINTL) \
-lgnu
OCAMLFLAGS = $(OCAML_FLAGS) $(OCAML_WARN_ERROR)
if !HAVE_OCAMLOPT
OBJECTS = $(BOBJECTS)
BEST = c
OCAMLLINKFLAGS = mlguestfs.cma -custom
else
OBJECTS = $(XOBJECTS)
BEST = opt
OCAMLLINKFLAGS = mlguestfs.cmxa
endif
virt_dib_DEPENDENCIES = $(OBJECTS) $(top_srcdir)/ocaml-link.sh
virt_dib_LINK = \
$(top_srcdir)/ocaml-link.sh -cclib '$(OCAMLCLIBS)' -- \
$(OCAMLFIND) $(BEST) $(OCAMLFLAGS) $(OCAMLPACKAGES) $(OCAMLLINKFLAGS) \
$(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
# Manual pages and HTML files for the website.
man_MANS = virt-dib.1
noinst_DATA = $(top_builddir)/html/virt-dib.1.html
virt-dib.1 $(top_builddir)/html/virt-dib.1.html: stamp-virt-dib.pod
stamp-virt-dib.pod: virt-dib.pod
$(PODWRAPPER) \
--man virt-dib.1 \
--html $(top_builddir)/html/virt-dib.1.html \
--license GPLv2+ \
$<
touch $@
CLEANFILES += stamp-virt-dib.pod
# Dependencies.
depend: .depend
.depend: $(wildcard $(abs_srcdir)/*.mli) $(wildcard $(abs_srcdir)/*.ml)
rm -f $@ $@-t
$(OCAMLFIND) ocamldep -I ../ocaml -I $(abs_srcdir) -I $(abs_top_builddir)/mllib $^ | \
$(SED) 's/ *$$//' | \
$(SED) -e :a -e '/ *\\$$/N; s/ *\\\n */ /; ta' | \
$(SED) -e 's,$(abs_srcdir)/,$(builddir)/,g' | \
sort > $@-t
mv $@-t $@
-include .depend
endif
DISTCLEANFILES = .depend
.PHONY: depend docs

242
dib/cmdline.ml Normal file
View File

@@ -0,0 +1,242 @@
(* virt-dib
* Copyright (C) 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.
*)
(* Command line argument parsing. *)
open Common_gettext.Gettext
open Common_utils
open Utils
open Printf
let parse_args () =
let usage_msg =
sprintf (f_"\
%s: run diskimage-builder elements to generate images
virt-dib -B DIB-LIB -p ELEMENTS-PATH elements...
A short summary of the options is given below. For detailed help please
read the man page virt-dib(1).
")
prog in
let elements = ref [] in
let append_element element =
elements := element :: !elements in
let excluded_elements = ref [] in
let append_excluded_element element =
excluded_elements := element :: !excluded_elements in
let element_paths = ref [] in
let append_element_path arg =
element_paths := arg :: !element_paths in
let excluded_scripts = ref [] in
let append_excluded_script arg =
excluded_scripts := arg :: !excluded_scripts in
let debug = ref 0 in
let set_debug arg =
if arg < 0 then
error (f_"--debug parameter must be >= 0");
debug := arg in
let basepath = ref "" in
let image_name = ref "image" in
let fs_type = ref "ext4" in
let size = ref (unit_GB 5) in
let set_size arg = size := parse_size arg in
let memsize = ref None in
let set_memsize arg = memsize := Some arg in
let network = ref true in
let smp = ref None in
let set_smp arg = smp := Some arg in
let formats = ref ["qcow2"] in
let set_format arg =
let fmts = remove_dups (string_nsplit "," arg) in
List.iter (
function
| "qcow2" | "tar" | "raw" | "vhd" -> ()
| fmt ->
error (f_"invalid format '%s' in --formats") fmt
) fmts;
formats := fmts in
let envvars = ref [] in
let append_envvar arg =
envvars := arg :: !envvars in
let use_base = ref true in
let arch = ref "" in
let drive = ref None in
let set_drive arg = drive := Some arg in
let root_label = ref None in
let set_root_label arg = root_label := Some arg in
let install_type = ref "source" in
let image_cache = ref None in
let set_image_cache arg = image_cache := Some arg in
let compressed = ref true in
let delete_on_failure = ref true in
let is_ramdisk = ref false in
let ramdisk_element = ref "ramdisk" in
let qemu_img_options = ref None in
let set_qemu_img_options arg = qemu_img_options := Some arg in
let mkfs_options = ref None in
let set_mkfs_options arg = mkfs_options := Some arg in
let machine_readable = ref false in
let extra_packages = ref [] in
let append_extra_packages arg =
extra_packages := List.rev (string_nsplit "," arg) @ !extra_packages in
let argspec = [
"--short-options", Arg.Unit display_short_options, " " ^ s_"List short options";
"--long-options", Arg.Unit display_long_options, " " ^ s_"List long options";
"-p", Arg.String append_element_path, "path" ^ " " ^ s_"Add new a elements location";
"--element-path", Arg.String append_element_path, "path" ^ " " ^ s_"Add new a elements location";
"--exclude-element", Arg.String append_excluded_element,
"element" ^ " " ^ s_"Exclude the specified element";
"--exclude-script", Arg.String append_excluded_script,
"script" ^ " " ^ s_"Exclude the specified script";
"--envvar", Arg.String append_envvar, "envvar[=value]" ^ " " ^ s_"Carry/set this environment variable";
"--skip-base", Arg.Clear use_base, " " ^ s_"Skip the inclusion of the 'base' element";
"--root-label", Arg.String set_root_label, "label" ^ " " ^ s_"Label for the root fs";
"--install-type", Arg.Set_string install_type, "type" ^ " " ^ s_"Installation type";
"--image-cache", Arg.String set_image_cache, "directory" ^ " " ^ s_"Location for cached images";
"-u", Arg.Clear compressed, " " ^ "Do not compress the qcow2 image";
"--qemu-img-options", Arg.String set_qemu_img_options,
"option" ^ " " ^ s_"Add qemu-img options";
"--mkfs-options", Arg.String set_mkfs_options,
"option" ^ " " ^ s_"Add mkfs options";
"--extra-packages", Arg.String append_extra_packages,
"pkg,..." ^ " " ^ s_"Add extra packages to install";
"--ramdisk", Arg.Set is_ramdisk, " " ^ "Switch to a ramdisk build";
"--ramdisk-element", Arg.Set_string ramdisk_element, "name" ^ " " ^ s_"Main element for building ramdisks";
"--name", Arg.Set_string image_name, "name" ^ " " ^ s_"Name of the image";
"--fs-type", Arg.Set_string fs_type, "fs" ^ " " ^ s_"Filesystem for the image";
"--size", Arg.String set_size, "size" ^ " " ^ s_"Set output disk size";
"--formats", Arg.String set_format, "qcow2,tgz,..." ^ " " ^ s_"Output formats";
"--arch", Arg.Set_string arch, "arch" ^ " " ^ s_"Output architecture";
"--drive", Arg.String set_drive, "path" ^ " " ^ s_"Optional drive for caches";
"-m", Arg.Int set_memsize, "mb" ^ " " ^ s_"Set memory size";
"--memsize", Arg.Int set_memsize, "mb" ^ " " ^ s_"Set memory size";
"--network", Arg.Set network, " " ^ s_"Enable appliance network (default)";
"--no-network", Arg.Clear network, " " ^ s_"Disable appliance network";
"--smp", Arg.Int set_smp, "vcpus" ^ " " ^ s_"Set number of vCPUs";
"--no-delete-on-failure", Arg.Clear delete_on_failure,
" " ^ s_"Don't delete output file on failure";
"--machine-readable", Arg.Set machine_readable, " " ^ s_"Make output machine readable";
"-V", Arg.Unit print_version_and_exit, " " ^ s_"Display version and exit";
"--version", Arg.Unit print_version_and_exit, " " ^ s_"Display version and exit";
"-v", Arg.Unit set_verbose, " " ^ s_"Enable libguestfs debugging messages";
"--verbose", Arg.Unit set_verbose, " " ^ s_"Enable libguestfs debugging messages";
"-x", Arg.Unit set_trace, " " ^ s_"Enable tracing of libguestfs calls";
"--debug", Arg.Int set_debug, "level" ^ " " ^ s_"Set debug level";
"-B", Arg.Set_string basepath, "path" ^ " " ^ s_"Base path of diskimage-builder library";
] in
let argspec =
let cmp (arg1, _, _) (arg2, _, _) =
let arg1 = skip_dashes arg1 and arg2 = skip_dashes arg2 in
compare (String.lowercase arg1) (String.lowercase arg2)
in
List.sort cmp argspec in
let argspec = Arg.align argspec in
long_options := argspec;
Arg.parse argspec append_element usage_msg;
let debug = !debug in
let basepath = !basepath in
let elements = List.rev !elements in
let excluded_elements = List.rev !excluded_elements in
let element_paths = List.rev !element_paths in
let excluded_scripts = List.rev !excluded_scripts in
let image_name = !image_name in
let fs_type = !fs_type in
let size = !size in
let memsize = !memsize in
let network = !network in
let smp = !smp in
let formats = !formats in
let envvars = !envvars in
let use_base = !use_base in
let arch = !arch in
let drive = !drive in
let root_label = !root_label in
let install_type = !install_type in
let image_cache = !image_cache in
let compressed = !compressed in
let delete_on_failure = !delete_on_failure in
let is_ramdisk = !is_ramdisk in
let ramdisk_element = !ramdisk_element in
let qemu_img_options = !qemu_img_options in
let mkfs_options = !mkfs_options in
let machine_readable = !machine_readable in
let extra_packages = List.rev !extra_packages in
(* No elements and machine-readable mode? Print some facts. *)
if elements = [] && machine_readable then (
printf "virt-dib\n";
printf "output:qcow2\n";
printf "output:tar\n";
printf "output:raw\n";
printf "output:vhd\n";
exit 0
);
if basepath = "" then
error (f_"-B must be specified");
if formats = [] then
error (f_"the list of output formats cannot be empty");
if elements = [] then
error (f_"at least one distribution root element must be specified");
debug, basepath, elements, excluded_elements, element_paths,
excluded_scripts, use_base, drive,
image_name, fs_type, size, root_label, install_type, image_cache, compressed,
qemu_img_options, mkfs_options, is_ramdisk, ramdisk_element, extra_packages,
memsize, network, smp, delete_on_failure, formats, arch, envvars

920
dib/dib.ml Normal file
View File

@@ -0,0 +1,920 @@
(* virt-dib
* Copyright (C) 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 Common_gettext.Gettext
open Common_utils
open Cmdline
open Utils
open Elements
open Printf
module G = Guestfs
let exclude_elements elements = function
| [] ->
(* No elements to filter out, so just don't bother iterating through
* the elements. *)
elements
| excl -> StringSet.filter (not_in_list excl) elements
let read_envvars envvars =
filter_map (
fun var ->
let i = string_find var "=" in
if i = -1 then (
try Some (var, Sys.getenv var)
with Not_found -> None
) else (
let len = String.length var in
Some (String.sub var 0 i, String.sub var (i + 1) (len - i - 1))
)
) envvars
let read_dib_envvars () =
let vars = Array.to_list (Unix.environment ()) in
let vars = List.filter (fun x -> string_prefix x "DIB_") vars in
let vars = List.map (fun x -> x ^ "\n") vars in
String.concat "" vars
let make_dib_args args =
let args = Array.to_list args in
let rec quote_args = function
| [] -> ""
| x :: xs -> " " ^ (quote x) ^ quote_args xs
in
match args with
| [] -> ""
| app :: xs -> app ^ quote_args xs
let write_script fn text =
let oc = open_out fn in
output_string oc text;
flush oc;
close_out oc;
Unix.chmod fn 0o755
let prepare_external ~dib_args ~dib_vars ~out_name ~root_label ~rootfs_uuid
~image_cache ~arch ~network ~debug
destdir libdir hooksdir tmpdir fakebindir all_elements element_paths =
let network_string = if network then "" else "1" in
let run_extra = sprintf "\
#!/bin/bash
set -e
%s
target_dir=$1
shift
script=$1
shift
export PATH=%s:$PATH
# d-i-b variables
export TMP_MOUNT_PATH=%s
export DIB_OFFLINE=%s
export IMAGE_NAME=\"%s\"
export DIB_ROOT_LABEL=\"%s\"
export DIB_IMAGE_ROOT_FS_UUID=%s
export DIB_IMAGE_CACHE=\"%s\"
export _LIB=%s
export ARCH=%s
export TMP_HOOKS_PATH=%s
export DIB_ARGS=\"%s\"
export IMAGE_ELEMENT=\"%s\"
export ELEMENTS_PATH=\"%s\"
export DIB_ENV=%s
export TMPDIR=\"${TMP_MOUNT_PATH}/tmp\"
export TMP_DIR=\"${TMPDIR}\"
export DIB_DEBUG_TRACE=%d
ENVIRONMENT_D_DIR=$target_dir/../environment.d
if [ -d $ENVIRONMENT_D_DIR ] ; then
env_files=$(find $ENVIRONMENT_D_DIR -maxdepth 1 -xtype f | \
grep -E \"/[0-9A-Za-z_\\.-]+$\" | \
LANG=C sort -n)
for env_file in $env_files ; do
source $env_file
done
fi
$target_dir/$script
"
(if debug >= 1 then "set -x\n" else "")
fakebindir
(quote tmpdir)
network_string
out_name
root_label
rootfs_uuid
image_cache
(quote libdir)
arch
(quote hooksdir)
dib_args
(String.concat " " (StringSet.elements all_elements))
(String.concat ":" element_paths)
(quote dib_vars)
debug in
write_script (destdir // "run-part-extra.sh") run_extra;
(* Needed as TMPDIR for the extra-data hooks *)
do_mkdir (tmpdir // "tmp")
let prepare_aux ~envvars ~dib_args ~dib_vars ~log_file ~out_name ~rootfs_uuid
~arch ~network ~root_label ~install_type ~debug ~extra_packages
destdir all_elements =
let envvars_string = List.map (
fun (var, value) ->
sprintf "export %s=%s" var (quote value)
) envvars in
let network_string = if network then "" else "1" in
let script_run_part = sprintf "\
#!/bin/bash
set -e
%s
sysroot=$1
shift
mysysroot=$1
shift
blockdev=$1
shift
target_dir=$1
shift
new_wd=$1
shift
script=$1
shift
# user variables
%s
# system variables
export HOME=$mysysroot/tmp/aux/perm/home
export PATH=$mysysroot/tmp/aux/hooks/bin:$PATH
export TMP=$mysysroot/tmp
export TMPDIR=$TMP
export TMP_DIR=$TMP
# d-i-b variables
export TMP_MOUNT_PATH=$sysroot
export TARGET_ROOT=$sysroot
export DIB_OFFLINE=%s
export IMAGE_NAME=\"%s\"
export DIB_IMAGE_ROOT_FS_UUID=%s
export DIB_IMAGE_CACHE=$HOME/.cache/image-create
export DIB_ROOT_LABEL=\"%s\"
export _LIB=$mysysroot/tmp/aux/lib
export _PREFIX=$mysysroot/tmp/aux/elements
export ARCH=%s
export TMP_HOOKS_PATH=$mysysroot/tmp/aux/hooks
export DIB_ARGS=\"%s\"
export DIB_MANIFEST_SAVE_DIR=\"$mysysroot/tmp/aux/out/${IMAGE_NAME}.d\"
export IMAGE_BLOCK_DEVICE=$blockdev
export IMAGE_ELEMENT=\"%s\"
export DIB_ENV=%s
export DIB_DEBUG_TRACE=%d
export DIB_NO_TMPFS=1
export TMP_BUILD_DIR=$mysysroot/tmp/aux
export TMP_IMAGE_DIR=$mysysroot/tmp/aux
if [ -n \"$mysysroot\" ]; then
export PATH=$mysysroot/tmp/aux/fake-bin:$PATH
else
export PATH=\"$PATH:/usr/local/sbin:/usr/local/bin:/usr/sbin:/usr/bin:/sbin:/bin\"
fi
ENVIRONMENT_D_DIR=$target_dir/../environment.d
if [ -d $ENVIRONMENT_D_DIR ] ; then
env_files=$(find $ENVIRONMENT_D_DIR -maxdepth 1 -xtype f | \
grep -E \"/[0-9A-Za-z_\\.-]+$\" | \
LANG=C sort -n)
for env_file in $env_files ; do
source $env_file
done
fi
if [ -n \"$new_wd\" ]; then
cd \"$mysysroot/$new_wd\"
fi
$target_dir/$script
"
(if debug >= 1 then "set -x\n" else "")
(String.concat "\n" envvars_string)
network_string
out_name
rootfs_uuid
root_label
arch
dib_args
(String.concat " " (StringSet.elements all_elements))
(quote dib_vars)
debug in
write_script (destdir // "run-part.sh") script_run_part;
let script_run_and_log = "\
#!/bin/bash
logfile=$1
shift
exec 3>&1
exit `( ( ( $(dirname $0)/run-part.sh \"$@\" ) 2>&1 3>&-; echo $? >&4) | tee -a $logfile >&3 >&2) 4>&1`
" in
write_script (destdir // "run-and-log.sh") script_run_and_log;
(* Create the fake sudo support. *)
do_mkdir (destdir // "fake-bin");
let fake_sudo = "\
#!/bin/bash
set -e
SCRIPTNAME=fake-sudo
ARGS_SHORT=\"EHiu:\"
ARGS_LONG=\"\"
TEMP=`POSIXLY_CORRECT=1 getopt ${ARGS_SHORT:+-o $ARGS_SHORT} ${ARGS_LONG:+--long $ARGS_LONG} \
-n \"$SCRIPTNAME\" -- \"$@\"`
if [ $? != 0 ]; then echo \"$SCRIPTNAME: terminating...\" >&2 ; exit 1 ; fi
eval set -- \"$TEMP\"
preserve_env=
set_home=
login_shell=
user=
while true; do
case \"$1\" in
-E) preserve_env=1; shift;;
-H) set_home=1; shift;;
-i) login_shell=1; shift;;
-u) user=$2; shift 2;;
--) shift; break;;
*) echo \"$SCRIPTNAME: internal arguments error\"; exit 1;;
esac
done
if [ -n \"$user\" ]; then
if [ $user != root -a $user != `whoami` ]; then
echo \"$SCRIPTNAME: cannot use the sudo user $user, only root and $(whoami) handled\" >&2
exit 1
fi
fi
if [ -z \"$preserve_env\" ]; then
for envvar in `env | grep '^\\w' | cut -d= -f1`; do
case \"$envvar\" in
PATH | USER | USERNAME | HOSTNAME | TERM | LANG | HOME | SHELL | LOGNAME ) ;;
*) unset $envvar ;;
esac
done
fi
cmd=$1
shift
$cmd \"$@\"
" in
write_script (destdir // "fake-bin" // "sudo") fake_sudo;
(* Pick dib-run-parts from the host, if available, otherwise put
* a fake executable which will error out if used.
*)
(try
let loc = which "dib-run-parts" in
do_cp loc (destdir // "fake-bin")
with Tool_not_found _ ->
let fake_dib_run_parts = "\
#!/bin/sh
echo \"Please install dib-run-parts on the host\"
exit 1
" in
write_script (destdir // "fake-bin" // "dib-run-parts") fake_dib_run_parts;
);
(* Write the custom hooks. *)
let script_install_type_env = sprintf "\
export DIB_DEFAULT_INSTALLTYPE=${DIB_DEFAULT_INSTALLTYPE:-\"%s\"}
"
install_type in
write_script (destdir // "hooks" // "environment.d" // "11-dib-install-type.bash") script_install_type_env;
(* Write install-packages.sh if needed. *)
if extra_packages <> [] then (
let script_install_packages = sprintf "\
#!/bin/bash
install-packages %s
"
(String.concat " " extra_packages) in
write_script (destdir // "install-packages.sh") script_install_packages;
);
do_mkdir (destdir // "perm")
let timing_output ~target_name entries timings =
let buf = Buffer.create 4096 in
Buffer.add_string buf "----------------------- PROFILING -----------------------\n";
Buffer.add_char buf '\n';
bprintf buf "Target: %s\n" target_name;
Buffer.add_char buf '\n';
bprintf buf "%-40s %9s\n" "Script" "Seconds";
bprintf buf "%-40s %9s\n" "---------------------------------------" "----------";
Buffer.add_char buf '\n';
List.iter (
fun x ->
bprintf buf "%-40s %10.3f\n" x (Hashtbl.find timings x);
) entries;
Buffer.add_char buf '\n';
Buffer.add_string buf "--------------------- END PROFILING ---------------------\n";
Buffer.contents buf
type sysroot_type =
| In
| Out
| Subroot
let timed_run fn =
let time_before = Unix.gettimeofday () in
fn ();
let time_after = Unix.gettimeofday () in
time_after -. time_before
let run_parts ~debug ~sysroot ~blockdev ~log_file ?(new_wd = "")
(g : Guestfs.guestfs) hook_name scripts =
let hook_dir = "/tmp/aux/hooks/" ^ hook_name in
let scripts = List.sort digit_prefix_compare scripts in
let outbuf = Buffer.create 16384 in
let timings = Hashtbl.create 13 in
let new_wd =
match sysroot, new_wd with
| (Out|Subroot), "" -> "''"
| _, dir -> dir in
List.iter (
fun x ->
message (f_"Running: %s/%s") hook_name x;
g#write_append log_file (sprintf "Running %s/%s...\n" hook_name x);
let out = ref "" in
let run () =
let outstr =
match sysroot with
| In ->
g#sh (sprintf "/tmp/aux/run-and-log.sh '%s' '' '' '%s' '%s' '%s' '%s'" log_file blockdev hook_dir new_wd x)
| Out ->
g#debug "sh" [| "/sysroot/tmp/aux/run-and-log.sh"; "/sysroot" ^ log_file; "/sysroot"; "/sysroot"; blockdev; "/sysroot" ^ hook_dir; new_wd; x |]
| Subroot ->
g#debug "sh" [| "/sysroot/tmp/aux/run-and-log.sh"; "/sysroot" ^ log_file; "/sysroot/subroot"; "/sysroot"; blockdev; "/sysroot" ^ hook_dir; new_wd; x |] in
out := outstr;
Buffer.add_string outbuf outstr in
let delta_t = timed_run run in
Buffer.add_char outbuf '\n';
out := ensure_trailing_newline !out;
printf "%s%!" !out;
if debug >= 1 then (
printf "%s completed after %.3f s\n" x delta_t
);
Hashtbl.add timings x delta_t;
) scripts;
g#write_append log_file (timing_output ~target_name:hook_name scripts timings);
flush_all ();
Buffer.contents outbuf
let run_parts_host ~debug hooks_dir hook_name scripts run_script =
let hook_dir = hooks_dir // hook_name in
let scripts = List.sort digit_prefix_compare scripts in
let timings = Hashtbl.create 13 in
List.iter (
fun x ->
message (f_"Running: %s/%s") hook_name x;
let cmd = sprintf "%s %s %s" (quote run_script) (quote hook_dir) (quote x) in
let run () =
run_command cmd in
let delta_t = timed_run run in
if debug >= 1 then (
printf "\n";
printf "%s completed after %.3f s\n" x delta_t
);
Hashtbl.add timings x delta_t;
) scripts;
if debug >= 1 then (
print_string (timing_output ~target_name:hook_name scripts timings)
);
flush_all ()
let run_install_packages ~debug ~blockdev ~log_file
(g : Guestfs.guestfs) packages =
let pkgs_string = String.concat " " packages in
message (f_"Installing: %s") pkgs_string;
g#write_append log_file (sprintf "Installing %s...\n" pkgs_string);
let out = g#sh (sprintf "/tmp/aux/run-and-log.sh '%s' '' '' '%s' '/tmp/aux' '' 'install-packages.sh'" log_file blockdev) in
let out = ensure_trailing_newline out in
if debug >= 1 then (
printf "%s%!" out;
printf "package installation completed\n";
);
flush_all ();
out
let main () =
let debug, basepath, elements, excluded_elements, element_paths,
excluded_scripts, use_base, drive,
image_name, fs_type, size, root_label, install_type, image_cache, compressed,
qemu_img_options, mkfs_options, is_ramdisk, ramdisk_element, extra_packages,
memsize, network, smp, delete_on_failure, formats, arch, envvars =
parse_args () in
(* Check that the specified base directory of diskimage-builder
* has the "die" script in it, so we know the directory is the
* right one (hopefully so, at least).
*)
if not (Sys.file_exists (basepath // "die")) then
error (f_"the specified base path is not the diskimage-builder library");
(* Check for required tools. *)
require_tool "uuidgen";
if List.mem "qcow2" formats then
require_tool "qemu-img";
if List.mem "vhd" formats then
require_tool "vhd-util";
let image_name_d = image_name ^ ".d" in
let tmpdir = Mkdtemp.temp_dir "dib." "" in
rmdir_on_exit tmpdir;
let auxtmpdir = tmpdir // "aux" in
do_mkdir auxtmpdir;
let hookstmpdir = auxtmpdir // "hooks" in
do_mkdir (hookstmpdir // "environment.d"); (* Just like d-i-b does. *)
let extradatatmpdir = tmpdir // "extra-data" in
do_mkdir extradatatmpdir;
do_mkdir (auxtmpdir // "out" // image_name_d);
let elements = if use_base then ["base"] @ elements else elements in
let elements = if is_ramdisk then [ramdisk_element] @ elements else elements in
message (f_"Elements: %s") (String.concat " " elements);
if debug >= 1 then (
printf "tmpdir: %s\n" tmpdir;
printf "element paths: %s\n" (String.concat ":" element_paths);
);
let loaded_elements = load_elements ~debug element_paths in
if debug >= 1 then (
printf "loaded elements:\n";
Hashtbl.iter (
fun k v ->
printf " %s => %s\n" k v.directory;
Hashtbl.iter (
fun k v ->
printf "\t%-20s %s\n" k (String.concat " " (List.sort compare v))
) v.hooks;
) loaded_elements;
printf "\n";
);
let all_elements = load_dependencies elements loaded_elements in
let all_elements = exclude_elements all_elements
(excluded_elements @ builtin_elements_blacklist) in
message (f_"Expanded elements: %s") (String.concat " " (StringSet.elements all_elements));
let envvars = read_envvars envvars in
message (f_"Carried environment variables: %s") (String.concat " " (List.map fst envvars));
if debug >= 1 then (
printf "carried over envvars:\n";
if envvars <> [] then
List.iter (
fun (var, value) ->
printf " %s=%s\n" var value
) envvars
else
printf " (none)\n";
printf "\n";
);
let dib_args = make_dib_args Sys.argv in
let dib_vars = read_dib_envvars () in
if debug >= 1 then (
printf "DIB args:\n%s\n" dib_args;
printf "DIB envvars:\n%s\n" dib_vars
);
message (f_"Preparing auxiliary data");
copy_elements all_elements loaded_elements
(excluded_scripts @ builtin_scripts_blacklist) hookstmpdir;
(* Re-read the hook scripts from the hooks dir, as d-i-b (and we too)
* has basically copied over anything found in elements.
*)
let final_hooks = load_hooks ~debug hookstmpdir in
let log_file = "/tmp/aux/perm/" ^ (log_filename ()) in
let arch =
match arch with
| "" -> current_arch ()
| arch -> arch in
let root_label =
match root_label with
| None ->
(* XFS has a limit of 12 characters for filesystem labels.
* Not changing the default for other filesystems to maintain
* backwards compatibility.
*)
(match fs_type with
| "xfs" -> "img-rootfs"
| _ -> "cloudimg-rootfs")
| Some label -> label in
let image_cache =
match image_cache with
| None -> Sys.getenv "HOME" // ".cache" // "image-create"
| Some dir -> dir in
do_mkdir image_cache;
let rootfs_uuid = uuidgen () in
let formats_img, formats_archive = List.partition (
function
| "qcow2" | "raw" | "vhd" -> true
| _ -> false
) formats in
let formats_img_nonraw = List.filter ((<>) "raw") formats_img in
prepare_aux ~envvars ~dib_args ~dib_vars ~log_file ~out_name:image_name
~rootfs_uuid ~arch ~network ~root_label ~install_type ~debug
~extra_packages
auxtmpdir all_elements;
let delete_output_file = ref delete_on_failure in
let delete_file () =
if !delete_output_file then (
List.iter (
fun fmt ->
try Unix.unlink (output_filename image_name fmt) with _ -> ()
) formats
)
in
at_exit delete_file;
prepare_external ~dib_args ~dib_vars ~out_name:image_name ~root_label
~rootfs_uuid ~image_cache ~arch ~network ~debug
tmpdir basepath hookstmpdir extradatatmpdir (auxtmpdir // "fake-bin")
all_elements element_paths;
let run_hook_host hook =
try
let scripts = Hashtbl.find final_hooks hook in
if debug >= 1 then (
printf "Running hooks for %s...\n%!" hook;
);
run_parts_host ~debug hookstmpdir hook scripts
(tmpdir // "run-part-extra.sh")
with Not_found -> ()
and run_hook ~blockdev ~sysroot ?(new_wd = "") (g : Guestfs.guestfs) hook =
try
let scripts = Hashtbl.find final_hooks hook in
if debug >= 1 then (
printf "Running hooks for %s...\n%!" hook;
);
run_parts ~debug ~sysroot ~blockdev ~log_file ~new_wd g hook scripts
with Not_found -> "" in
run_hook_host "extra-data.d";
let copy_in (g : Guestfs.guestfs) srcdir destdir =
let desttar = Filename.temp_file ~temp_dir:tmpdir "virt-dib." ".tar.gz" in
let cmd = sprintf "tar czf %s -C %s --owner=root --group=root ."
(quote desttar) (quote srcdir) in
run_command cmd;
g#mkdir_p destdir;
g#tar_in ~compress:"gzip" desttar destdir;
Sys.remove desttar in
let copy_preserve_in (g : Guestfs.guestfs) srcdir destdir =
let desttar = Filename.temp_file ~temp_dir:tmpdir "virt-dib." ".tar.gz" in
let remotetar = "/tmp/aux/" ^ (Filename.basename desttar) in
let cmd = sprintf "tar czf %s -C %s --owner=root --group=root ."
(quote desttar) (quote srcdir) in
run_command cmd;
g#upload desttar remotetar;
let verbose_flag = if debug > 0 then "v" else "" in
ignore (g#debug "sh" [| "tar"; "-C"; "/sysroot" ^ destdir; "--no-overwrite-dir"; "-x" ^ verbose_flag ^ "zf"; "/sysroot" ^ remotetar |]);
Sys.remove desttar;
g#rm remotetar in
if debug >= 1 then
ignore (Sys.command (sprintf "tree -ps %s" (quote tmpdir)));
message (f_"Opening the disks");
let is_ramdisk_build = is_ramdisk || StringSet.mem "ironic-agent" all_elements in
let g, tmpdisk, tmpdiskfmt, drive_partition =
let g = new G.guestfs () in
if verbose () then g#set_verbose true;
if trace () then g#set_trace true;
(match memsize with None -> () | Some memsize -> g#set_memsize memsize);
(match smp with None -> () | Some smp -> g#set_smp smp);
g#set_network network;
(* Make sure to turn SELinux off to avoid awkward interactions
* between the appliance kernel and applications/libraries interacting
* with SELinux xattrs.
*)
g#set_selinux false;
(* Main disk with the built image. *)
let fmt = "raw" in
let fn =
(* If "raw" is among the selected outputs, use it as main backing
* disk, otherwise create a temporary disk.
*)
if not is_ramdisk_build && List.mem "raw" formats_img then image_name
else Filename.temp_file ~temp_dir:tmpdir "image." "" in
let fn = output_filename fn fmt in
(* Produce the output image. *)
g#disk_create fn fmt size;
g#add_drive ~readonly:false ~format:fmt fn;
(* Helper drive for elements and binaries. *)
g#add_drive_scratch (unit_GB 5);
(match drive with
| None ->
g#add_drive_scratch (unit_GB 5)
| Some drive ->
g#add_drive drive;
);
g#launch ();
(* Prepare the /aux partition. *)
g#mkfs "ext2" "/dev/sdb";
g#mount "/dev/sdb" "/";
copy_in g auxtmpdir "/";
copy_in g basepath "/lib";
g#umount "/";
(* Prepare the /aux/perm partition. *)
let drive_partition =
match drive with
| None ->
g#mkfs "ext2" "/dev/sdc";
"/dev/sdc"
| Some _ ->
let partitions = Array.to_list (g#list_partitions ()) in
(match partitions with
| [] -> "/dev/sdc"
| p ->
let p = List.filter (fun x -> string_prefix x "/dev/sdc") p in
if p = [] then
error (f_"no partitions found in the helper drive");
List.hd p
) in
g#mount drive_partition "/";
g#mkdir_p "/home/.cache/image-create";
g#umount "/";
g, fn, fmt, drive_partition in
let mount_aux () =
g#mkmountpoint "/tmp/aux";
g#mount "/dev/sdb" "/tmp/aux";
g#mount drive_partition "/tmp/aux/perm" in
(* Small kludge: try to umount all first: if that fails, use lsof and fuser
* to find out what might have caused the failure, run udevadm to try
* to settle things down (udev, you never know), and try umount all again.
*)
let checked_umount_all () =
try g#umount_all ()
with G.Error _ ->
if debug >= 1 then (
(try printf "lsof:\n%s\nEND\n" (g#debug "sh" [| "lsof"; "/sysroot"; |]) with _ -> ());
(try printf "fuser:\n%s\nEND\n" (g#debug "sh" [| "fuser"; "-v"; "-m"; "/sysroot"; |]) with _ -> ());
(try printf "losetup:\n%s\nEND\n" (g#debug "sh" [| "losetup"; "--list"; "--all" |]) with _ -> ());
);
ignore (g#debug "sh" [| "udevadm"; "--debug"; "settle" |]);
g#umount_all () in
g#mkmountpoint "/tmp";
mount_aux ();
let blockdev =
(* Setup a loopback device, just like d-i-b would tie an image in the host
* environment.
*)
let run_losetup device =
let lines = g#debug "sh" [| "losetup"; "--show"; "-f"; device |] in
let lines = string_nsplit "\n" lines in
let lines = List.filter ((<>) "") lines in
(match lines with
| [] -> device
| x :: _ -> x
) in
let blockdev = run_losetup "/dev/sda" in
let run_hook_out_eval hook envvar =
let lines = run_hook ~sysroot:Out ~blockdev g hook in
let lines = string_nsplit "\n" lines in
let lines = List.filter ((<>) "") lines in
if lines = [] then None
else (try Some (var_from_lines envvar lines) with _ -> None) in
(match run_hook_out_eval "block-device.d" "IMAGE_BLOCK_DEVICE" with
| None -> blockdev
| Some x -> x
) in
let rec run_hook_out ?(new_wd = "") hook =
do_run_hooks_noout ~sysroot:Out ~new_wd hook
and run_hook_in hook =
do_run_hooks_noout ~sysroot:In hook
and run_hook_subroot hook =
do_run_hooks_noout ~sysroot:Subroot hook
and do_run_hooks_noout ~sysroot ?(new_wd = "") hook =
ignore (run_hook ~sysroot ~blockdev ~new_wd g hook) in
g#sync ();
checked_umount_all ();
flush_all ();
message (f_"Setting up the destination root");
(* Create and mount the target filesystem. *)
let mkfs_options =
match mkfs_options with
| None -> []
| Some o -> [ o ] in
let mkfs_options =
(match fs_type with
| "ext4" ->
(* Very conservative to handle images being resized a lot
* Without -J option specified, default journal size will be set to 32M
* and online resize will be failed with error of needs too many credits.
*)
[ "-i"; "4096"; "-J"; "size=64" ]
| _ -> []
) @ mkfs_options @ [ "-t"; fs_type; blockdev ] in
ignore (g#debug "sh" (Array.of_list ([ "mkfs" ] @ mkfs_options)));
g#set_label blockdev root_label;
(match fs_type with
| x when string_prefix x "ext" -> g#set_uuid blockdev rootfs_uuid
| _ -> ());
g#mount blockdev "/";
g#mkmountpoint "/tmp";
mount_aux ();
g#mkdir "/subroot";
run_hook_subroot "root.d";
g#sync ();
g#umount "/tmp/aux/perm";
g#umount "/tmp/aux";
g#rm_rf "/tmp";
let subroot_items =
let l = Array.to_list (g#ls "/subroot") in
let l_lost_plus_found, l = List.partition ((=) "lost+found") l in
if l_lost_plus_found <> [] then (
g#rm_rf "/subroot/lost+found";
);
l in
List.iter (fun x -> g#mv ("/subroot/" ^ x) ("/" ^ x)) subroot_items;
g#rmdir "/subroot";
(* Check /tmp exists already. *)
ignore (g#is_dir "/tmp");
mount_aux ();
g#ln_s "aux/hooks" "/tmp/in_target.d";
copy_preserve_in g extradatatmpdir "/";
run_hook_in "pre-install.d";
if extra_packages <> [] then
ignore (run_install_packages ~debug ~blockdev ~log_file g extra_packages);
run_hook_in "install.d";
run_hook_in "post-install.d";
(* Unmount and remount the image, as d-i-b does at this point too. *)
g#sync ();
checked_umount_all ();
flush_all ();
g#mount blockdev "/";
(* Check /tmp/aux still exists. *)
ignore (g#is_dir "/tmp/aux");
g#mount "/dev/sdb" "/tmp/aux";
g#mount drive_partition "/tmp/aux/perm";
run_hook_in "finalise.d";
let out_dir = "/tmp/aux/out/" ^ image_name_d in
run_hook_out ~new_wd:out_dir "cleanup.d";
g#sync ();
if g#ls out_dir <> [||] then (
message (f_"Extracting data out of the image");
do_mkdir image_name_d;
g#copy_out out_dir ".";
);
(* Unmount everything, and remount only the root to cleanup
* its /tmp; this way we should be pretty sure that there is
* nothing left mounted over /tmp, so it is safe to empty it.
*)
checked_umount_all ();
flush_all ();
g#mount blockdev "/";
Array.iter (fun x -> g#rm_rf ("/tmp/" ^ x)) (g#ls "/tmp");
flush_all ();
List.iter (
fun fmt ->
let fn = output_filename image_name fmt in
match fmt with
| "tar" ->
message (f_"Compressing the image as tar");
g#tar_out ~excludes:[| "./sys/*"; "./proc/*" |] "/" fn
| _ as fmt -> error "unhandled format: %s" fmt
) formats_archive;
message (f_"Umounting the disks");
(* Now that we've finished the build, don't delete the output file on
* exit.
*)
delete_output_file := false;
g#sync ();
checked_umount_all ();
g#shutdown ();
g#close ();
flush_all ();
(* Don't produce images as output when doing a ramdisk build. *)
if not is_ramdisk_build then (
List.iter (
fun fmt ->
let fn = output_filename image_name fmt in
message (f_"Converting to %s") fmt;
match fmt with
| "qcow2" ->
let cmd =
sprintf "qemu-img convert%s -f %s %s -O %s%s %s"
(if compressed then " -c" else "")
tmpdiskfmt
(quote tmpdisk)
fmt
(match qemu_img_options with
| None -> ""
| Some opt -> " -o " ^ quote opt)
(quote (qemu_input_filename fn)) in
if debug >= 1 then
printf "%s\n%!" cmd;
run_command cmd
| "vhd" ->
let fn_intermediate = Filename.temp_file ~temp_dir:tmpdir "vhd-intermediate." "" in
let cmd =
sprintf "vhd-util convert -s 0 -t 1 -i %s -o %s"
(quote tmpdisk)
(quote fn_intermediate) in
if debug >= 1 then
printf "%s\n%!" cmd;
run_command cmd;
let cmd =
sprintf "vhd-util convert -s 1 -t 2 -i %s -o %s"
(quote fn_intermediate)
(quote fn) in
if debug >= 1 then
printf "%s\n%!" cmd;
run_command cmd;
if not (Sys.file_exists fn) then
error (f_"VHD output not produced, most probably vhd-util is old or not patched for 'convert'")
| _ as fmt -> error "unhandled format: %s" fmt
) formats_img_nonraw;
);
message (f_"Done")
let () = run_main_and_handle_errors main

187
dib/elements.ml Normal file
View File

@@ -0,0 +1,187 @@
(* virt-dib
* Copyright (C) 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 and handling of elements. *)
open Common_gettext.Gettext
open Common_utils
open Utils
open Printf
module StringSet = Set.Make (String)
type element = {
directory : string;
hooks : hooks_map;
}
and hooks_map = (string, string list) Hashtbl.t (* hook name, scripts *)
exception Duplicate_script of string * string (* hook, script *)
(* These are the elements which we don't ever try to use. *)
let builtin_elements_blacklist = [
]
(* These are the scripts which we don't ever try to run.
* Usual reason could be that they are not compatible the way virt-dib works:
* e.g. they expect the tree of elements outside the chroot, which is not
* available in the appliance. *)
let builtin_scripts_blacklist = [
"01-sahara-version"; (* Gets the Git commit ID of the d-i-b and
* sahara-image-elements repositories. *)
]
let valid_script_name n =
let is_char_valid = function
| 'A'..'Z' | 'a'..'z' | '0'..'9' | '_' | '-' -> true
| _ -> false in
try ignore (string_index_fn (fun c -> not (is_char_valid c)) n); false
with Not_found -> true
let stringset_of_list l =
List.fold_left (fun acc x -> StringSet.add x acc) StringSet.empty l
let load_hooks ~debug path =
let hooks = Hashtbl.create 13 in
let entries = Array.to_list (Sys.readdir path) in
let entries = List.filter (fun x -> Filename.check_suffix x ".d") entries in
let entries = List.map (fun x -> (x, path // x)) entries in
let entries = List.filter (fun (_, x) -> is_directory x) entries in
List.iter (
fun (hook, p) ->
let listing = Array.to_list (Sys.readdir p) in
let scripts = List.filter valid_script_name listing in
let scripts = List.filter (
fun x ->
try
let s = Unix.stat (p // x) in
s.Unix.st_kind = Unix.S_REG && s.Unix.st_perm land 0o111 > 0
with Unix.Unix_error _ -> false
) scripts in
if scripts <> [] then
Hashtbl.add hooks hook scripts
) entries;
hooks
let load_elements ~debug paths =
let loaded_elements = Hashtbl.create 13 in
let paths = List.filter is_directory paths in
List.iter (
fun path ->
let listing = Array.to_list (Sys.readdir path) in
let listing = List.map (fun x -> (x, path // x)) listing in
let listing = List.filter (fun (_, x) -> is_directory x) listing in
List.iter (
fun (p, dir) ->
if not (Hashtbl.mem loaded_elements p) then (
let elem = { directory = dir; hooks = load_hooks ~debug dir } in
Hashtbl.add loaded_elements p elem
) else if debug >= 1 then (
printf "element %s (in %s) already present" p path;
)
) listing
) paths;
loaded_elements
let load_dependencies elements loaded_elements =
let get filename element =
try
let path = (Hashtbl.find loaded_elements element).directory in
let path = path // filename in
if Sys.file_exists path then (
let lines = read_whole_file path in
let lines = string_nsplit "\n" lines in
let lines = List.filter ((<>) "") lines in
stringset_of_list lines
) else
StringSet.empty
with Not_found ->
error (f_"element %s not found") element in
let get_deps = get "element-deps" in
let get_provides = get "element-provides" in
let queue = Queue.create () in
let final = ref StringSet.empty in
let provided = ref StringSet.empty in
List.iter (fun x -> Queue.push x queue) elements;
final := stringset_of_list elements;
while not (Queue.is_empty queue) do
let elem = Queue.pop queue in
if StringSet.mem elem !provided <> true then (
let deps = get_deps elem in
provided := StringSet.union !provided (get_provides elem);
StringSet.iter (fun x -> Queue.push x queue)
(StringSet.diff deps (StringSet.union !final !provided));
final := StringSet.union !final deps
)
done;
let conflicts = StringSet.inter (stringset_of_list elements) !provided in
if not (StringSet.is_empty conflicts) then
error (f_"following elements were explicitly required but are provided by other included elements: %s")
(String.concat "," (StringSet.elements conflicts));
if not (StringSet.mem "operating-system" !provided) then
error (f_"please include an operating system element");
StringSet.diff !final !provided
let copy_element element destdir blacklist =
let entries = Array.to_list (Sys.readdir element.directory) in
let entries = List.filter ((<>) "tests") entries in
let entries = List.filter ((<>) "test-elements") entries in
let dirs, nondirs = List.partition is_directory entries in
let dirs = List.map (fun x -> (x, element.directory // x, destdir // x)) dirs in
let nondirs = List.map (fun x -> element.directory // x) nondirs in
let is_regular_file file =
try (Unix.stat file).Unix.st_kind = Unix.S_REG
with Unix.Unix_error _ -> false in
List.iter (
fun (e, path, destpath) ->
do_mkdir destpath;
let subentries = Array.to_list (Sys.readdir path) in
let subentries = List.filter (not_in_list blacklist) subentries in
List.iter (
fun sube ->
if is_regular_file (destpath // sube) then (
raise (Duplicate_script (e, sube))
) else
do_cp (path // sube) destpath
) subentries;
) dirs;
List.iter (
fun path ->
do_cp path destdir
) nondirs
let copy_elements elements loaded_elements blacklist destdir =
do_mkdir destdir;
StringSet.iter (
fun element ->
try
copy_element (Hashtbl.find loaded_elements element) destdir blacklist
with
| Duplicate_script (hook, script) ->
let element_has_script e =
try
let s = Hashtbl.find (Hashtbl.find loaded_elements e).hooks hook in
List.exists ((=) script) s
with Not_found -> false in
let dups = StringSet.filter element_has_script elements in
error (f_"There is a duplicated script in your elements:\n%s/%s in: %s")
hook script (String.concat " " (StringSet.elements dups))
) elements

131
dib/utils.ml Normal file
View File

@@ -0,0 +1,131 @@
(* virt-dib
* Copyright (C) 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 Common_gettext.Gettext
open Common_utils
open Printf
exception Tool_not_found of string (* tool *)
let quote = Filename.quote
let unit_GB howmany =
(Int64.of_int howmany) *^ 1024_L *^ 1024_L *^ 1024_L
let current_arch () =
(* Turn a CPU into the dpkg architecture naming. *)
match Config.host_cpu with
| "amd64" | "x86_64" -> "amd64"
| "i386" | "i486" | "i586" | "i686" -> "i386"
| arch when string_prefix arch "armv" -> "armhf"
| arch -> arch
let output_filename image_name = function
| fmt -> image_name ^ "." ^ fmt
let log_filename () =
let tm = Unix.gmtime (Unix.time ()) in
sprintf "%s-%d%02d%02d-%02d%02d%02d.log"
prog (tm.Unix.tm_year + 1900) (tm.Unix.tm_mon + 1) tm.Unix.tm_mday
tm.Unix.tm_hour tm.Unix.tm_min tm.Unix.tm_sec
let var_from_lines var lines =
let var_with_equal = var ^ "=" in
let var_lines = List.filter (fun x -> string_prefix x var_with_equal) lines in
match var_lines with
| [] ->
error (f_"variable '%s' not found in lines:\n%s")
var (String.concat "\n" lines)
| [x] -> snd (string_split "=" x)
| _ ->
error (f_"variable '%s' has more than one occurrency in lines:\n%s")
var (String.concat "\n" lines)
let string_index_fn fn str =
let len = String.length str in
let rec loop i =
if i = len then raise Not_found
else if fn str.[i] then i
else loop (i + 1) in
loop 0
let digit_prefix_compare a b =
let myint str =
try int_of_string str
with _ -> 0 in
let mylength str =
match String.length str with
| 0 -> max_int
| x -> x in
let split_prefix str =
let len = String.length str in
let digits =
let isdigit = function
| '0'..'9' -> true
| _ -> false in
try string_index_fn (fun x -> not (isdigit x)) str
with Not_found -> len in
match digits with
| 0 -> "", str
| x when x = len -> str, ""
| _ -> String.sub str 0 digits, String.sub str digits (len - digits) in
let pref_a, rest_a = split_prefix a in
let pref_b, rest_b = split_prefix b in
match mylength pref_a, mylength pref_b, compare (myint pref_a) (myint pref_b) with
| x, y, 0 when x = y -> compare rest_a rest_b
| x, y, 0 -> x - y
| _, _, x -> x
let do_mkdir dir =
mkdir_p dir 0o755
let rec remove_dups = function
| [] -> []
| x :: xs -> x :: (remove_dups (List.filter ((<>) x) xs))
let which tool =
let paths = string_nsplit ":" (Sys.getenv "PATH") in
let paths = filter_map (
fun p ->
let path = p // tool in
try Unix.access path [Unix.X_OK]; Some path
with Unix.Unix_error _ -> None
) paths in
match paths with
| [] -> raise (Tool_not_found tool)
| x :: _ -> x
let run_command cmd =
ignore (external_command cmd)
let require_tool tool =
try ignore (which tool)
with Tool_not_found tool ->
error (f_"%s needed but not found") tool
let do_cp src destdir =
run_command (sprintf "cp -t %s -a %s" (quote destdir) (quote src))
let ensure_trailing_newline str =
if String.length str > 0 && str.[String.length str - 1] <> '\n' then str ^ "\n"
else str
let not_in_list l e =
not (List.mem e l)

628
dib/virt-dib.pod Normal file
View File

@@ -0,0 +1,628 @@
=head1 NAME
virt-dib - Run diskimage-builder elements
=head1 SYNOPSIS
virt-dib -B DIB-LIB [options] elements...
=head1 DESCRIPTION
Virt-dib is a tool for using the elements of C<diskimage-builder>
to build a new disk image, generate new ramdisks, etc.
Virt-dib is intended as safe replacement for C<diskimage-builder>
and its C<ramdisk-image-create> mode, see
L</COMPARISON WITH DISKIMAGE-BUILDER> for a quick comparison with
usage of C<diskimage-builder>.
C<diskimage-builder> is part of the TripleO OpenStack project:
L<https://wiki.openstack.org/wiki/TripleO>.
=head1 EXAMPLES
=head2 Build simple images of distributions
virt-dib \
-B /path/to/diskimage-builder/lib \
-p /path/to/diskimage-builder/elements \
--envvar DIB_RELEASE=jessie \
--name debian-jessie \
debian vm
This builds a Debian Jessie (8.x) disk image, suitable for running
as virtual machine, saved as F<debian-jessie.qcow2>.
=head2 Build ramdisks
virt-dib \
-B /path/to/diskimage-builder/lib \
-p /path/to/diskimage-builder/elements \
--ramdisk \
--name ramdisk \
ubuntu deploy-ironic
This builds a ramdisk for the Ironic OpenStack component based
on the Ubuntu distribution.
=head1 OPTIONS
=over 4
=item B<--help>
Display help.
=item B<-B> PATH
Set the path to the library directory of C<diskimage-builder>. This is
usually the F<lib> subdirectory in the sources and when installed,
and F</usr/share/diskimage-builder/lib> when installed in F</usr>.
This parameter is B<mandatory>, as virt-dib needs to provide it for
the elements (as some of them might use scripts in it).
Virt-dib itself does not make use of the library directory.
=item B<--arch> ARCHITECURE
Use the specified architecture for the output image. The default
value is the same as the host running virt-dib.
Right now this option does nothing more than setting the C<ARCH>
environment variable for the elements, and it's up to them to
produce an image for the requested architecture.
=item B<--debug> LEVEL
Set the debug level to C<LEVEL>, which is a non-negative integer
number. The default is C<0>.
This debug level is different than what I<-x> and I<-v> set,
and it increases the debugging information printed out.
Specifically, this sets the C<DIB_DEBUG_TRACE>, and any value
E<gt> C<0> enables tracing in the scripts executed.
=item B<--drive> DISK
Add the specified disk to be used as helper drive where to cache
files of the elements, like disk images, distribution packages, etc.
See L</HELPER DRIVE>.
=item B<-p> PATH
=item B<--element-path> PATH
Add a new path with elements. Paths are used in the same order as the
I<-p> parameters appear, so a path specified first is looked first,
and so on.
Obviously, it is recommended to add the path to the own elements of
C<diskimage-builder>, as most of the other elements will rely on them.
=item B<--extra-packages> PACKAGE,...
Install additional packages in the image being built.
This relies on the C<install-packages> binary provided by the
package management elements.
This option can be specified multiple times, each time with multiple
packages separated by comma.
=item B<--envvar> VARIABLE
=item B<--envvar> VARIABLE=VALUE
Carry or set an environment variable for the elements.
See L</ENVIRONMENT VARIABLES> below for more information on the
interaction and usage of environment variables.
This option can be used in two ways:
=over 4
=item B<--envvar> VARIABLE
Carry the environment variable C<VARIABLE>. If it is not set, nothing
is exported to the elements.
=item B<--envvar> VARIABLE=VALUE
Set the environment variable C<VARIABLE> with value C<VALUE> for the
elements, regardless whether an environment variable with the same
name exists.
This can be useful to pass environment variable without exporting
them in the environment where virt-dib runs.
=back
=item B<--exclude-element> ELEMENT
Ignore the specified element.
=item B<--exclude-script> SCRIPT
Ignore any element script named C<SCRIPT>, whichever element it is in.
This can be useful in case some script does not run well with
virt-dib, for example when they really need C<diskimage-builder>'s
environment.
=item B<--formats> FORMAT,...
Set the list of output formats, separating them with comma.
Supported formats are:
=over 4
=item C<qcow2> (enabled by default)
QEMU's qcow2.
=item C<raw>
Raw disk format.
=item C<tar>
An uncompressed tarball.
=item C<vhd>
C<Virtual Hard Disk> disk image. This output format requires
the C<vhd-util> tool.
Please note that the version of C<vhd-util> tool needs to be patched
to support the C<convert> subcommand, and to be bootable.
The patch is available here:
L<https://github.com/emonty/vhd-util/blob/master/debian/patches/citrix>.
=back
=item B<--fs-type> FILESYSTEM
Set the filesystem type to use for the root filesystem. The default
is C<ext4>.
See also L<guestfs(3)/guestfs_filesystem_available>.
=item B<--image-cache> DIRECTORY
Set the path in the host where cache the resources used by the
elements of the C<extra-data.d> phase. The default is
F<~/.cache/image-create>.
Please note that most of the resources fetched after C<extra-data>
will be cached in the helper drive specified with I<--drive>;
see also L</HELPER DRIVE>.
=item B<--install-type> TYPE
Specify the default installation type. Defaults to C<source>.
Set to C<package> to use package based installations by default.
=item B<--machine-readable>
This option is used to make the output more machine friendly
when being parsed by other programs. See
L</MACHINE READABLE OUTPUT> below.
=item B<-m> MB
=item B<--memsize> MB
Change the amount of memory allocated to the appliance. Increase
this if you find that the virt-dib execution runs out of memory.
The default can be found with this command:
guestfish get-memsize
=item B<--mkfs-options> C<OPTION STRING>
Add the specified options to L<mkfs(1)>, to be able to fine-tune
the root filesystem creation. Note that this is not possible
to override the filesystem type.
You should use I<--mkfs-options> at most once. To pass multiple
options, separate them with space, eg:
virt-dib ... --mkfs-options '-O someopt -I foo'
=item B<--network>
=item B<--no-network>
Enable or disable network access from the guest during the
installation.
Enabled is the default. Use I<--no-network> to disable access.
The network only allows outgoing connections and has other minor
limitations. See L<virt-rescue(1)/NETWORK>.
This does not affect whether the guest can access the network once it
has been booted, because that is controlled by your hypervisor or
cloud environment and has nothing to do with virt-dib.
If you use I<--no-network>, then the environment variable
C<DIB_OFFLINE> is set to C<1>, signaling the elements that they
should use only cached resources when available. Note also that,
unlike with C<diskimage-builder> where elements may still be able
to access to the network even with C<DIB_OFFLINE=>, under virt-dib
network will be fully unaccessible.
=item B<--name> NAME
Set the name of the output image file. The default is C<image>.
According to the chosen name, there will be the following in the
current directory:
=over 4
=item F<$NAME.ext>
For each output format, a disk image named after the outout image
with the extension depending on the format; for example:
F<$NAME.qcow2>, F<$NAME.raw>, etc.
Not applicable in ramdisk mode, see L</RAMDISK BUILDING>.
=item F<$NAME.d>
A directory containing any files created by the elements, for example
F<dib-manifests> directory (created by the C<manifests> element),
ramdisks and kernels in ramdisk mode, and so on.
=back
=item B<--no-delete-on-failure>
Don't delete the output files on failure to build. You can use this
to debug failures to run scripts.
The default is to delete the output file if virt-dib fails (or,
for example, some script that it runs fails).
=item B<--qemu-img-options> option[,option,...]
Pass I<--qemu-img-options> option(s) to the L<qemu-img(1)> command
to fine-tune the output format. Options available depend on
the output format (see I<--formats>) and the installed version
of the qemu-img program.
You should use I<--qemu-img-options> at most once. To pass multiple
options, separate them with commas, eg:
virt-dib ... --qemu-img-options cluster_size=512,preallocation=metadata ...
=item B<--ramdisk>
Set the ramdisk building mode.
See L</RAMDISK BUILDING>.
=item B<--ramdisk-element> NAME
Set the name for the additional element added in ramdisk building
mode. The default is C<ramdisk>.
See L</RAMDISK BUILDING>.
=item B<--root-label> LABEL
Set the label for the root filesystem in the created image.
Please note that some filesystems have different restrictions on
the length of their labels; for example, on C<ext2/3/4> filesystems
labels cannot be longer than 16 characters, while on C<xfs> they have
at most 12 characters.
The default depends on the actual filesystem for the root partition
(see I<--fs-type>): on C<xfs> is C<img-rootfs>, while
C<cloudimg-rootfs> on any other filesystem.
=item B<--size> SIZE
Select the size of the output disk, where the size can be specified
using common names such as C<32G> (32 gigabytes) etc.
The default size is C<5G>.
To specify size in bytes, the number must be followed by the lowercase
letter I<b>, eg: S<C<--size 10737418240b>>.
See also L<virt-resize(1)> for resizing partitions of an existing
disk image.
=item B<--skip-base>
Skip the inclusion of the C<base> element.
=item B<--smp> N
Enable N E<ge> 2 virtual CPUs for scripts to use.
=item B<-u>
Do not compress resulting qcow2 images. The default is to compress
them.
=item B<-v>
=item B<--verbose>
Enable debugging messages.
=item B<-V>
=item B<--version>
Display version number and exit.
=item B<-x>
Enable tracing of libguestfs API calls.
=back
=head1 ENVIRONMENT VARIABLES
Unlike with C<diskimage-builder>, the environment of the host is
B<not> inherited in the appliance when running most of the elements
(i.e. all the ones different than C<extra-data.d>).
To set environment for the elements being run, it is necessary to tell
virt-dib to use them, with the option I<--envvar>. Such option
allows to selectively export environment variables when running the
elements, and it is the preferred way to pass environment variables
to the elements.
To recap: if you want the environment variable C<MYVAR>
(and its content) to be available to the elements, you can do either
export MYVAR # whichever is its value
virt-dib ... --envvar MYVAR ...
or
virt-dib ... --envvar MYVAR=value_of_it ...
=head1 HELPER DRIVE
Virt-dib runs most of the element in its own appliance, and thus not
on the host. Because of this, there is no possibility for elements
to cache resources directly on the host.
To solve this issue, virt-dib allows the usage of an helper drive
where to store cached resources, like disk images,
distribution packages, etc. While this means that there is a smaller
space available for caching, at least it allows to limit the space
on the host for caches, without assuming that elements will do that
by themselves.
Currently this disk is either required to have a single partition
on it, or the first partition on it will be used. A disk with
the latter configuration can be easily created with L<guestfish(1)>
like the following:
guestfish -N filename.img=fs:ext4:10G
The above will create a disk image called F<filename.img>, 10G big,
with a single partition of type ext4;
see L<guestfish(1)/PREPARED DISK IMAGES>.
It is recommended for it to be E<ge> 10G or even more, as elements
will cache disk images, distribution packages, etc. As with any disk
image, the helper disk can be easily resized using L<virt-resize(1)>
if more space in it is needed.
The drive can be accessed like any other disk image, for example using
other tools of libguestfs such as L<guestfish(1)>:
guestfish -a filename.img -m /dev/sda1
If no helper drive is specified with I<--drive>, all the resources
cached during a virt-dib run will be discarded.
=head2 RESOURCES INSIDE THE DRIVE
Inside the helper drive, it is possible to find the following
resources:
=over 4
=item F</home>
This directory is set as C<HOME> environment variable during the
build. It contains mostly the image cache (saved as
F</home/.cache/image-create>), and whichever other resource is
cached in the home directory of the user running the various tools.
=item F</virt-dib-*.log>
These are the logs of the elements being run within the libguestfs
appliance, which means all the hooks except C<extra-data.d>.
=back
=head1 RAMDISK BUILDING
Virt-dib can emulate also C<ramdisk-image-create>, which is a
secondary operation mode of C<diskimage-builder>. Instead of being
a different tool name, virt-dib provides easy access to this mode
using the I<--ramdisk> switch.
In this mode:
=over 4
=item
there is an additional ramdisk element added (see
I<--ramdisk-element>)
=item
no image is produced (so I<--formats> is ignored)
=item
F<$NAME.d> (see I<--name>) will contain initrd, kernel, etc
=back
=head1 TEMPORARY DIRECTORY
Virt-dib uses the standard temporary directory used by libguestfs,
see L<guestfs(3)/ENVIRONMENT VARIABLES>.
By default this location is F</tmp> (default value for C<TMPDIR>),
which on some systems may be on a tmpfs filesystem, and thus
defaulting to a maximum size of I<half> of physical RAM.
If virt-dib exceeds this, it may hang or exit early with an error.
The solution is to point C<TMPDIR> to a permanent location used
as temporary location, for example:
mkdir local-tmp
env TMPDIR=$PWD/local-tmp virt-dib ...
rm -rf local-tmp
=head1 COMPARISON WITH DISKIMAGE-BUILDER
Virt-dib is intended as safe replacement for C<diskimage-builder>
and its C<ramdisk-image-create> mode; the user-notable differences
consist in:
=over 4
=item
the command line arguments; some of the arguments are the same as
available in C<diskimage-builder>, while some have different names:
disk-image-create virt-dib
----------------- --------
-a ARCH --arch ARCH
--image-size SIZE --size SIZE
--max-online-resize SIZE doable using --mkfs-options
-n --skip-base
-o IMAGENAME --name IMAGENAME
-p PACKAGE(S) --extra-packages PACKAGE(S)
-t FORMAT(S) --formats FORMAT(S)
-x --debug N
=item
the location of non-image output files (like ramdisks and kernels)
=item
the way some of the cached resources are saved: using an helper drive,
not directly on the disk where virt-dib is run
=item
the need to specify a target size for the output disk, as opposed
to C<diskimage-builder> calculating an optimal one
=item
the handling of environment variables, see L</ENVIRONMENT VARIABLES>.
Furthermore, other than the libguestfs own environment variables
(see L<guestfs(3)/ENVIRONMENT VARIABLES>), virt-dib does not read
any other environment variable: this means that all the options
and behaviour changes are specified solely using command line
arguments
=item
C<extra-data.d> scripts run in the host environment, before all the
other ones (even C<root.d>); this means that, depending on the
configuration for the elements, some of them may fail due to missing
content (usually directories) in C<TMP_HOOKS_PATH>.
Workarounds for this may be either:
=over 4
=item
fix the C<extra-data.d> scripts to create the missing directories
=item
create (and use) a simple element with a C<extra-data.d> script
named e.g. F<00-create-missing-dirs> to create the missing
directories
=back
=back
Elements themselves should notice no difference in they way
they are run; behaviour differences may due to wrong assumptions in
elements, or not correct virt-dib emulation.
Known issues at the moment:
=over 4
=item
(none)
=back
=head1 MACHINE READABLE OUTPUT
The I<--machine-readable> option can be used to make the output more
machine friendly, which is useful when calling virt-dib from other
programs, GUIs etc.
Use the option on its own to query the capabilities of the
virt-dib binary. Typical output looks like this:
$ virt-dib --machine-readable
virt-dib
output:qcow2
output:tar
output:raw
output:vhd
A list of features is printed, one per line, and the program exits
with status 0.
=head1 TESTING
Virt-dib has been tested with C<diskimage-builder> (and its elements)
E<ge> 0.1.43; from time to time also with C<tripleo-image-elements>
and C<sahara-image-elements>.
Previous versions may work, but it is not guaranteed.
=head1 EXIT STATUS
This program returns 0 if successful, or non-zero if there was an
error.
=head1 SEE ALSO
L<guestfs(3)>,
L<guestfish(1)>,
L<virt-resize(1)>,
L<http://libguestfs.org/>.
=head1 AUTHOR
Pino Toscano (C<ptoscano at redhat dot com>)
=head1 COPYRIGHT
Copyright (C) 2015 Red Hat Inc.

View File

@@ -11,6 +11,7 @@
../customize/virt-customize.pod
../daemon/guestfsd.pod
../df/virt-df.pod
../dib/virt-dib.pod
../diff/virt-diff.pod
../edit/virt-edit.pod
../erlang/examples/guestfs-erlang.pod

View File

@@ -25,6 +25,10 @@ customize/random_seed.ml
customize/ssh_key.ml
customize/timezone.ml
customize/urandom.ml
dib/cmdline.ml
dib/dib.ml
dib/elements.ml
dib/utils.ml
get-kernel/get_kernel.ml
mllib/JSON.ml
mllib/JSON_tests.ml

1
run.in
View File

@@ -86,6 +86,7 @@ prepend PATH "$b/builder"
prepend PATH "$b/cat"
prepend PATH "$b/customize"
prepend PATH "$b/df"
prepend PATH "$b/dib"
prepend PATH "$b/diff"
prepend PATH "$b/edit"
prepend PATH "$b/erlang"

View File

@@ -4390,6 +4390,10 @@ actions.
L<virt-df(1)> command and documentation.
=item F<dib>
L<virt-dib(1)> command and documentation.
=item F<diff>
L<virt-diff(1)> command and documentation.