diff --git a/0004-RHEL-Reject-use-of-libguestfs-winsupport-features-ex.patch b/0001-RHEL-Reject-use-of-libguestfs-winsupport-features-ex.patch similarity index 87% rename from 0004-RHEL-Reject-use-of-libguestfs-winsupport-features-ex.patch rename to 0001-RHEL-Reject-use-of-libguestfs-winsupport-features-ex.patch index b9e3716..1b4772a 100644 --- a/0004-RHEL-Reject-use-of-libguestfs-winsupport-features-ex.patch +++ b/0001-RHEL-Reject-use-of-libguestfs-winsupport-features-ex.patch @@ -1,4 +1,4 @@ -From bbdc10642eff480246271f98180733f732c306b3 Mon Sep 17 00:00:00 2001 +From 3c9689e96d8b0fb6476eff22953b9c512421b9fc Mon Sep 17 00:00:00 2001 From: "Richard W.M. Jones" Date: Tue, 7 Jul 2015 09:28:03 -0400 Subject: [PATCH] RHEL: Reject use of libguestfs-winsupport features except for @@ -11,7 +11,7 @@ edits. 1 file changed, 1 insertion(+) diff --git a/test-data/phony-guests/make-windows-img.sh b/test-data/phony-guests/make-windows-img.sh -index 30908a918..73cf5144e 100755 +index 16debd129..1c13ddac3 100755 --- a/test-data/phony-guests/make-windows-img.sh +++ b/test-data/phony-guests/make-windows-img.sh @@ -37,6 +37,7 @@ fi diff --git a/0001-sysprep-remove-lvm2-s-default-system.devices-file.patch b/0001-sysprep-remove-lvm2-s-default-system.devices-file.patch deleted file mode 100644 index 8b2500d..0000000 --- a/0001-sysprep-remove-lvm2-s-default-system.devices-file.patch +++ /dev/null @@ -1,100 +0,0 @@ -From 37c002682a9e5b87d5793f1567c4ddfb8ca72d11 Mon Sep 17 00:00:00 2001 -From: Laszlo Ersek -Date: Sun, 10 Apr 2022 13:38:34 +0200 -Subject: [PATCH] sysprep: remove lvm2's default "system.devices" file - -(Background: lvm2 commit 83fe6e720f42, "device usage based on devices -file", 2021-02-23; first released in v2_03_12.) - -"lvm pvscan" may be -- and in RHEL9, will soon be -- restricted to those -block devices whose WWIDs are listed in "/etc/lvm/devices/system.devices". -This is a problem when cloning a VM, as cloning may change the WWIDs of -the domain's disk devices, and then physical volumes underlying the guest -filesystems may not be found. Example: -. - -Add the "lvm-system-devices" operation for removing this file, so that -"lvm pvscan" investigate all block devices for PVs. - -(Note that this operation is independent from "lvm-uuids". The libguestfs -appliance creates a pristine LVM_SYSTEM_DIR in "appliance/init" (see -libguestfs commit dd162d2cd56a), thus, when "lvm-uuids" calls "g#pvs" and -"g#vgs", those APIs can never be affected by an -"$LVM_SYSTEM_DIR/devices/system.devices" file.) - -Bugzilla: https://bugzilla.redhat.com/show_bug.cgi?id=2072493 -Signed-off-by: Laszlo Ersek -Message-Id: <20220410113834.6258-1-lersek@redhat.com> -Reviewed-by: Richard W.M. Jones -(cherry picked from commit 4fe8a03cd2d3e4570f4298245bb184ccdc4da0cd) ---- - sysprep/Makefile.am | 1 + - .../sysprep_operation_lvm_system_devices.ml | 44 +++++++++++++++++++ - 2 files changed, 45 insertions(+) - create mode 100644 sysprep/sysprep_operation_lvm_system_devices.ml - -diff --git a/sysprep/Makefile.am b/sysprep/Makefile.am -index 0e3afc8a0..7d5e8aadf 100644 ---- a/sysprep/Makefile.am -+++ b/sysprep/Makefile.am -@@ -46,6 +46,7 @@ operations = \ - ipa_client \ - kerberos_data \ - kerberos_hostkeytab \ -+ lvm_system_devices \ - lvm_uuids \ - logfiles \ - machine_id \ -diff --git a/sysprep/sysprep_operation_lvm_system_devices.ml b/sysprep/sysprep_operation_lvm_system_devices.ml -new file mode 100644 -index 000000000..b41fa5dbc ---- /dev/null -+++ b/sysprep/sysprep_operation_lvm_system_devices.ml -@@ -0,0 +1,44 @@ -+(* virt-sysprep -+ * Copyright (C) 2012-2022 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 Sysprep_operation -+open Common_gettext.Gettext -+ -+module G = Guestfs -+ -+let system_devices_file = "/etc/lvm/devices/system.devices" -+ -+let rec lvm_system_devices_perform g root side_effects = -+ let typ = g#inspect_get_type root in -+ if typ = "linux" then g#rm_f system_devices_file -+ -+let op = { -+ defaults with -+ name = "lvm-system-devices"; -+ enabled_by_default = true; -+ heading = s_"Remove LVM2 system.devices file"; -+ pod_description = -+ Some (s_"On Linux guests, LVM2's scanning for physical volumes (PVs) may \ -+ be restricted to those block devices whose WWIDs are listed in \ -+ C<" ^ system_devices_file ^ ">. When cloning VMs, WWIDs may \ -+ change, breaking C. Remove \ -+ C<" ^ system_devices_file ^ ">."); -+ perform_on_filesystems = Some lvm_system_devices_perform; -+} -+ -+let () = register_operation op --- -2.31.1 - diff --git a/0015-RHEL-builder-Disable-opensuse-repository.patch b/0002-RHEL-builder-Disable-opensuse-repository.patch similarity index 94% rename from 0015-RHEL-builder-Disable-opensuse-repository.patch rename to 0002-RHEL-builder-Disable-opensuse-repository.patch index 6d18bd9..87d0e09 100644 --- a/0015-RHEL-builder-Disable-opensuse-repository.patch +++ b/0002-RHEL-builder-Disable-opensuse-repository.patch @@ -1,4 +1,4 @@ -From 888ecde429ef6fab9567359abae1e2d04d552666 Mon Sep 17 00:00:00 2001 +From 10a4be467d84f5733cc696b7a0ed971fc1f35f3f Mon Sep 17 00:00:00 2001 From: "Richard W.M. Jones" Date: Mon, 21 Nov 2022 13:03:22 +0000 Subject: [PATCH] RHEL: builder: Disable opensuse repository diff --git a/0002-adopt-inversion-of-SELinux-relabeling-in-virt-custom.patch b/0002-adopt-inversion-of-SELinux-relabeling-in-virt-custom.patch deleted file mode 100644 index 5485754..0000000 --- a/0002-adopt-inversion-of-SELinux-relabeling-in-virt-custom.patch +++ /dev/null @@ -1,347 +0,0 @@ -From 5792f2e95bcddf476f2fe37e0bc4d97bd881d8fa Mon Sep 17 00:00:00 2001 -From: Laszlo Ersek -Date: Tue, 10 May 2022 12:50:46 +0200 -Subject: [PATCH] adopt inversion of SELinux relabeling in virt-customize - -Remove "--selinux-relabel" options. - -Do not add any "--no-selinux-relabel" options; rely on the internal check -for SELinux support instead ("is_selinux_guest" in -"common/mlcustomize/SELinux_relabel.ml"). - -"--no-selinux-relabel" becomes a real option for virt-sysprep now. -(Again?) - -Bugzilla: https://bugzilla.redhat.com/show_bug.cgi?id=1554735 -Bugzilla: https://bugzilla.redhat.com/show_bug.cgi?id=2075718 -Signed-off-by: Laszlo Ersek -Message-Id: <20220510105046.15167-1-lersek@redhat.com> -Acked-by: Richard W.M. Jones -[lersek@redhat.com: incorporate common submodule update] -(cherry picked from commit 19de3d1c8d4efb53565dbffe532d41ee9d25a832) ---- - builder/templates/make-template.ml | 8 +------- - builder/virt-builder.pod | 20 ++++---------------- - common | 2 +- - customize/customize_run.ml | 2 +- - customize/test-settings.sh | 3 --- - sysprep/main.ml | 2 -- - sysprep/test-virt-sysprep-docs.sh | 2 +- - 7 files changed, 8 insertions(+), 31 deletions(-) - -diff --git a/builder/templates/make-template.ml b/builder/templates/make-template.ml -index 6786fec19..b40789284 100755 ---- a/builder/templates/make-template.ml -+++ b/builder/templates/make-template.ml -@@ -256,8 +256,7 @@ let rec main () = - printf "Sysprepping ...\n%!"; - let cmd = - sprintf "virt-sysprep --quiet -a %s%s" -- (quote tmpout) -- (if is_selinux_os os then " --selinux-relabel" else "") in -+ (quote tmpout) in - if Sys.command cmd <> 0 then exit 1 - ); - -@@ -480,11 +479,6 @@ and can_sysprep_os = function - | Debian _ | Ubuntu _ -> true - | FreeBSD _ | Windows _ -> false - --and is_selinux_os = function -- | RHEL _ | Alma _ | CentOS _ | CentOSStream _ | Fedora _ -> true -- | Debian _ | Ubuntu _ -- | FreeBSD _ | Windows _ -> false -- - and needs_uefi os arch = - match os, arch with - | Fedora _, Armv7 -diff --git a/builder/virt-builder.pod b/builder/virt-builder.pod -index f7dd6cdad..aeb505296 100644 ---- a/builder/virt-builder.pod -+++ b/builder/virt-builder.pod -@@ -131,12 +131,6 @@ To update the installed packages to the latest version: - - virt-builder debian-7 --update - --For guests which use SELinux, like Fedora and Red Hat Enterprise --Linux, you may need to do SELinux relabelling after installing or --updating packages (see L below): -- -- virt-builder fedora-27 --update --selinux-relabel -- - =head2 Customizing the installation - - There are many options that let you customize the installation. These -@@ -972,7 +966,7 @@ command line. - - =item * - --SELinux relabelling is done (I<--selinux-relabel>). -+SELinux relabelling is done unless disabled with I<--no-selinux-relabel>. - - =back - -@@ -1072,8 +1066,7 @@ A typical virt-builder command would be: - --install puppet \ - --append-line '/etc/puppet/puppet.conf:[agent]' \ - --append-line '/etc/puppet/puppet.conf:server = puppetmaster.example.com/' \ -- --run-command 'systemctl enable puppet' \ -- --selinux-relabel -+ --run-command 'systemctl enable puppet' - - The precise instructions vary according to the Linux distro. For - further information see: -@@ -1753,14 +1746,14 @@ two possible strategies it can use to ensure correct labelling: - - =over 4 - --=item Using I<--selinux-relabel> -+=item Automatic relabeling - - This runs L just before finalizing the guest, which sets - SELinux labels correctly in the disk image. - - This is the recommended method. - --=item I<--touch> F -+=item Using I<--no-selinux-relabel> I<--touch> F - - Guest templates may already contain a file called F or - you may touch it. -@@ -1771,11 +1764,6 @@ them, which is normal and harmless. - - =back - --Please note that if your guest uses SELinux, and you are doing operations --on it which might create new files or change existing ones, you are --recommended to use I<--selinux-relabel>. This will help in making sure --that files have the right SELinux labels. -- - =head1 MACHINE READABLE OUTPUT - - The I<--machine-readable> option can be used to make the output more -Submodule common 0a231b3e6..48527b876: -diff --git a/common/mlcustomize/customize-options.pod b/common/mlcustomize/customize-options.pod -index 71b545d..a83c80a 100644 ---- a/common/mlcustomize/customize-options.pod -+++ b/common/mlcustomize/customize-options.pod -@@ -206,6 +206,19 @@ the image was built, use this option. - - See also: L. - -+=item B<--no-selinux-relabel> -+ -+Do not attempt to correct the SELinux labels of files in the guest. -+ -+In such guests that support SELinux, customization automatically -+relabels files so that they have the correct SELinux label. (The -+relabeling is performed immediately, but if the operation fails, -+customization will instead touch F on the image to -+schedule a relabel operation for the next time the image boots.) This -+option disables the automatic relabeling. -+ -+The option is a no-op for guests that do not support SELinux. -+ - =item B<--password> USER:SELECTOR - - Set the password for C. (Note this option does I -@@ -297,16 +310,6 @@ It cannot delete directories, only regular files. - - =back - --=item B<--selinux-relabel> -- --Relabel files in the guest so that they have the correct SELinux label. -- --This will attempt to relabel files immediately, but if the operation fails --this will instead touch F on the image to schedule a --relabel operation for the next time the image boots. -- --You should only use this option for guests which support SELinux. -- - =item B<--sm-attach> SELECTOR - - Attach to a pool using C. -diff --git a/common/mlcustomize/customize-synopsis.pod b/common/mlcustomize/customize-synopsis.pod -index 5f18540..2520853 100644 ---- a/common/mlcustomize/customize-synopsis.pod -+++ b/common/mlcustomize/customize-synopsis.pod -@@ -12,5 +12,5 @@ - [--truncate-recursive PATH] [--timezone TIMEZONE] [--touch FILE] - [--uninstall PKG,PKG..] [--update] [--upload FILE:DEST] - [--write FILE:CONTENT] [--no-logfile] -- [--password-crypto md5|sha256|sha512] [--selinux-relabel] -+ [--password-crypto md5|sha256|sha512] [--no-selinux-relabel] - [--sm-credentials SELECTOR] -diff --git a/common/mlcustomize/customize_cmdline.ml b/common/mlcustomize/customize_cmdline.ml -index 9326baa..5d404e8 100644 ---- a/common/mlcustomize/customize_cmdline.ml -+++ b/common/mlcustomize/customize_cmdline.ml -@@ -109,8 +109,8 @@ and flags = { - (* --no-logfile *) - password_crypto : Password.password_crypto option; - (* --password-crypto md5|sha256|sha512 *) -- selinux_relabel : bool; -- (* --selinux-relabel *) -+ no_selinux_relabel : bool; -+ (* --no-selinux-relabel *) - sm_credentials : Subscription_manager.sm_credentials option; - (* --sm-credentials SELECTOR *) - } -@@ -121,7 +121,7 @@ let rec argspec () = - let ops = ref [] in - let scrub_logfile = ref false in - let password_crypto = ref None in -- let selinux_relabel = ref false in -+ let no_selinux_relabel = ref false in - let sm_credentials = ref None in - - let rec get_ops () = { -@@ -131,7 +131,7 @@ let rec argspec () = - and get_flags () = { - scrub_logfile = !scrub_logfile; - password_crypto = !password_crypto; -- selinux_relabel = !selinux_relabel; -+ no_selinux_relabel = !no_selinux_relabel; - sm_credentials = !sm_credentials; - } - in -@@ -459,11 +459,11 @@ let rec argspec () = - ), - Some "md5|sha256|sha512", "When the virt tools change or set a password in the guest, this\noption sets the password encryption of that password to\nC, C or C.\n\nC and C require glibc E 2.7 (check crypt(3) inside\nthe guest).\n\nC will work with relatively old Linux guests (eg. RHEL 3), but\nis not secure against modern attacks.\n\nThe default is C unless libguestfs detects an old guest that\ndidn't have support for SHA-512, in which case it will use C.\nYou can override libguestfs by specifying this option.\n\nNote this does not change the default password encryption used\nby the guest when you create new user accounts inside the guest.\nIf you want to do that, then you should use the I<--edit> option\nto modify C (Fedora, RHEL) or\nC (Debian, Ubuntu)."; - ( -- [ L"selinux-relabel" ], -- Getopt.Set selinux_relabel, -- s_"Relabel files with correct SELinux labels" -+ [ L"no-selinux-relabel" ], -+ Getopt.Set no_selinux_relabel, -+ s_"Do not relabel files with correct SELinux labels" - ), -- None, "Relabel files in the guest so that they have the correct SELinux label.\n\nThis will attempt to relabel files immediately, but if the operation fails\nthis will instead touch F on the image to schedule a\nrelabel operation for the next time the image boots.\n\nYou should only use this option for guests which support SELinux."; -+ None, "Do not attempt to correct the SELinux labels of files in the guest.\n\nIn such guests that support SELinux, customization automatically\nrelabels files so that they have the correct SELinux label. (The\nrelabeling is performed immediately, but if the operation fails,\ncustomization will instead touch F on the image to\nschedule a relabel operation for the next time the image boots.) This\noption disables the automatic relabeling.\n\nThe option is a no-op for guests that do not support SELinux."; - ( - [ L"sm-credentials" ], - Getopt.String ( -diff --git a/common/mlcustomize/customize_cmdline.mli b/common/mlcustomize/customize_cmdline.mli -index 14eda49..7ee882a 100644 ---- a/common/mlcustomize/customize_cmdline.mli -+++ b/common/mlcustomize/customize_cmdline.mli -@@ -101,8 +101,8 @@ and flags = { - (* --no-logfile *) - password_crypto : Password.password_crypto option; - (* --password-crypto md5|sha256|sha512 *) -- selinux_relabel : bool; -- (* --selinux-relabel *) -+ no_selinux_relabel : bool; -+ (* --no-selinux-relabel *) - sm_credentials : Subscription_manager.sm_credentials option; - (* --sm-credentials SELECTOR *) - } -diff --git a/common/mlcustomize/test-firstboot.sh b/common/mlcustomize/test-firstboot.sh -index b906997..24c67f3 100755 ---- a/common/mlcustomize/test-firstboot.sh -+++ b/common/mlcustomize/test-firstboot.sh -@@ -61,9 +61,6 @@ case "$guestname" in - extra[${#extra[*]}]='/etc/inittab: - s,^#([1-9].*respawn.*/sbin/getty.*),$1,' - ;; -- fedora*|rhel*|centos*) -- extra[${#extra[*]}]='--selinux-relabel' -- ;; - *) - ;; - esac -diff --git a/common/mlcustomize/test-selinuxrelabel.sh b/common/mlcustomize/test-selinuxrelabel.sh -index 86278c6..caf7521 100755 ---- a/common/mlcustomize/test-selinuxrelabel.sh -+++ b/common/mlcustomize/test-selinuxrelabel.sh -@@ -41,13 +41,12 @@ virt-builder "$guestname" --quiet -o "$disk" - # Test #1: relabel with the default configuration works. - rm -f "$disk_overlay" - guestfish -- disk-create "$disk_overlay" qcow2 -1 backingfile:"$disk" --virt-customize -a "$disk" --selinux-relabel -+virt-customize -a "$disk" - - # Test #2: relabel with no SELINUXTYPE in the configuration. - rm -f "$disk_overlay" - guestfish -- disk-create "$disk_overlay" qcow2 -1 backingfile:"$disk" - virt-customize -a "$disk" \ -- --edit /etc/selinux/config:"s,^SELINUXTYPE=,#&,g" \ -- --selinux-relabel -+ --edit /etc/selinux/config:"s,^SELINUXTYPE=,#&,g" - - rm "$disk" "$disk_overlay" -diff --git a/common/options/uri.c b/common/options/uri.c -index 6b696fc..84d393c 100644 ---- a/common/options/uri.c -+++ b/common/options/uri.c -@@ -135,7 +135,7 @@ parse (const char *arg, char **path_ret, char **protocol_ret, - socket = query_get (uri, "socket"); - - if (uri->server && STRNEQ (uri->server, "") && socket) { -- fprintf (stderr, _("%s: %s: cannot both a server name and a socket query parameter\n"), -+ fprintf (stderr, _("%s: %s: cannot have both a server name and a socket query parameter\n"), - getprogname (), arg); - return -1; - } -@@ -347,6 +347,7 @@ make_server (xmlURIPtr uri, const char *socket, char ***ret) - *ret = malloc (sizeof (char *) * 2); - if (*ret == NULL) { - perror ("malloc"); -+ free (server); - return -1; - } - (*ret)[0] = server; -diff --git a/customize/customize_run.ml b/customize/customize_run.ml -index f2ee20413..99b5fe14d 100644 ---- a/customize/customize_run.ml -+++ b/customize/customize_run.ml -@@ -415,7 +415,7 @@ let run (g : G.guestfs) root (ops : ops) = - warning (f_"passwords could not be set for this type of guest") - ); - -- if ops.flags.selinux_relabel then ( -+ if not ops.flags.no_selinux_relabel then ( - message (f_"SELinux relabelling"); - SELinux_relabel.relabel g - ); -diff --git a/customize/test-settings.sh b/customize/test-settings.sh -index ed4c90f2e..e8b492dd1 100755 ---- a/customize/test-settings.sh -+++ b/customize/test-settings.sh -@@ -61,9 +61,6 @@ case "$guestname" in - extra[${#extra[*]}]='/etc/inittab: - s,^#([1-9].*respawn.*/sbin/getty.*),$1,' - ;; -- fedora*|rhel*|centos*) -- extra[${#extra[*]}]='--selinux-relabel' -- ;; - *) - ;; - esac -diff --git a/sysprep/main.ml b/sysprep/main.ml -index 087d1a17f..b760618ad 100644 ---- a/sysprep/main.ml -+++ b/sysprep/main.ml -@@ -132,8 +132,6 @@ let main () = - [ L"mount-options" ], Getopt.Set_string (s_"opts", mount_opts), s_"Set mount options (eg /:noatime;/var:rw,noatime)"; - [ L"network" ], Getopt.Set network, s_"Enable appliance network"; - [ L"no-network" ], Getopt.Clear network, s_"Disable appliance network (default)"; -- [ L"no-selinux-relabel" ], Getopt.Unit (fun () -> ()), -- s_"Compatibility option, does nothing"; - [ L"operation"; L"operations" ], Getopt.String (s_"operations", set_operations), s_"Enable/disable specific operations"; - ] in - let args = basic_args @ Sysprep_operation.extra_args () in -diff --git a/sysprep/test-virt-sysprep-docs.sh b/sysprep/test-virt-sysprep-docs.sh -index 51500b5e9..9d0298d68 100755 ---- a/sysprep/test-virt-sysprep-docs.sh -+++ b/sysprep/test-virt-sysprep-docs.sh -@@ -25,4 +25,4 @@ $top_srcdir/podcheck.pl "$srcdir/virt-sysprep.pod" virt-sysprep \ - --path $top_srcdir/common/options \ - --insert sysprep-extra-options.pod:__EXTRA_OPTIONS__ \ - --insert sysprep-operations.pod:__OPERATIONS__ \ -- --ignore=--dryrun,--dump-pod,--dump-pod-options,--no-selinux-relabel -+ --ignore=--dryrun,--dump-pod,--dump-pod-options --- -2.31.1 - diff --git a/0003-Remove-virt-dib.patch b/0003-Remove-virt-dib.patch new file mode 100644 index 0000000..5caa5d4 --- /dev/null +++ b/0003-Remove-virt-dib.patch @@ -0,0 +1,3630 @@ +From 7259f17fbb6d4e8bd8810541d77d06baebb24370 Mon Sep 17 00:00:00 2001 +From: "Richard W.M. Jones" +Date: Tue, 7 Feb 2023 13:20:36 +0000 +Subject: [PATCH] Remove virt-dib + +The tool only supports an older version of the diskimage-builder +metadata, and we do not have the time or inclination to update it to a +newer version. + +Fixes: https://bugzilla.redhat.com/show_bug.cgi?id=1910039 +(cherry picked from commit 57423d907270526ea664ff15601cce956353820e) +--- + .gitignore | 4 - + Makefile.am | 3 +- + bash/Makefile.am | 3 +- + bash/virt-alignment-scan | 6 - + configure.ac | 1 - + dib/Makefile.am | 169 ------ + dib/cmdline.ml | 267 --------- + dib/cmdline.mli | 52 -- + dib/dib.ml | 1007 --------------------------------- + dib/dib.mli | 19 - + dib/dummy.c | 2 - + dib/elements.ml | 207 ------- + dib/elements.mli | 61 -- + dib/output_format.ml | 192 ------- + dib/output_format.mli | 131 ----- + dib/output_format_docker.ml | 57 -- + dib/output_format_qcow2.ml | 56 -- + dib/output_format_raw.ml | 31 - + dib/output_format_squashfs.ml | 39 -- + dib/output_format_tar.ml | 35 -- + dib/output_format_tgz.ml | 35 -- + dib/output_format_vhd.ml | 47 -- + dib/test-virt-dib-docs.sh | 23 - + dib/utils.ml | 111 ---- + dib/utils.mli | 66 --- + dib/virt-dib.pod | 727 ------------------------ + run.in | 1 - + 27 files changed, 2 insertions(+), 3350 deletions(-) + delete mode 100644 dib/Makefile.am + delete mode 100644 dib/cmdline.ml + delete mode 100644 dib/cmdline.mli + delete mode 100644 dib/dib.ml + delete mode 100644 dib/dib.mli + delete mode 100644 dib/dummy.c + delete mode 100644 dib/elements.ml + delete mode 100644 dib/elements.mli + delete mode 100644 dib/output_format.ml + delete mode 100644 dib/output_format.mli + delete mode 100644 dib/output_format_docker.ml + delete mode 100644 dib/output_format_qcow2.ml + delete mode 100644 dib/output_format_raw.ml + delete mode 100644 dib/output_format_squashfs.ml + delete mode 100644 dib/output_format_tar.ml + delete mode 100644 dib/output_format_tgz.ml + delete mode 100644 dib/output_format_vhd.ml + delete mode 100755 dib/test-virt-dib-docs.sh + delete mode 100644 dib/utils.ml + delete mode 100644 dib/utils.mli + delete mode 100644 dib/virt-dib.pod + +diff --git a/.gitignore b/.gitignore +index da2a0266b..b0ada2e3c 100644 +--- a/.gitignore ++++ b/.gitignore +@@ -30,7 +30,6 @@ Makefile.in + /bash/virt-cat + /bash/virt-customize + /bash/virt-df +-/bash/virt-dib + /bash/virt-diff + /bash/virt-drivers + /bash/virt-edit +@@ -95,9 +94,6 @@ Makefile.in + /customize/test-settings-*.sh + /customize/virt-customize + /df/virt-df +-/dib/.depend +-/dib/output_format_*.mli +-/dib/virt-dib + /drivers/.depend + /drivers/virt-drivers + /diff/virt-diff +diff --git a/Makefile.am b/Makefile.am +index 311789ed1..ca1fc03c9 100644 +--- a/Makefile.am ++++ b/Makefile.am +@@ -60,7 +60,6 @@ SUBDIRS += get-kernel + SUBDIRS += resize + SUBDIRS += sparsify + SUBDIRS += sysprep +-SUBDIRS += dib + endif + + # bash-completion +@@ -121,7 +120,7 @@ po/POTFILES: configure.ac + po/POTFILES-ml: configure.ac + rm -f $@ $@-t + cd $(srcdir); \ +- find builder common/ml* customize dib drivers get-kernel resize sparsify sysprep -name '*.ml' | \ ++ find builder common/ml* customize drivers get-kernel resize sparsify sysprep -name '*.ml' | \ + grep -v '^builder/templates/' | \ + grep -v '^common/mlv2v/' | \ + grep -v -E '.*_tests\.ml$$' | \ +diff --git a/bash/Makefile.am b/bash/Makefile.am +index 000fab5eb..9a63736d2 100644 +--- a/bash/Makefile.am ++++ b/bash/Makefile.am +@@ -28,7 +28,6 @@ symlinks = \ + virt-customize \ + virt-diff \ + virt-df \ +- virt-dib \ + virt-drivers \ + virt-edit \ + virt-filesystems \ +@@ -55,7 +54,7 @@ CLEANFILES += \ + # common options like -d is handled by this common script. However + # this script cannot deal with commands that use --ro/--rw + # (eg. virt-rescue). Those tools have to be handled individually. +-virt-builder virt-cat virt-customize virt-df virt-dib virt-diff virt-drivers \ ++virt-builder virt-cat virt-customize virt-df virt-diff virt-drivers \ + virt-edit virt-filesystems virt-format virt-get-kernel virt-inspector \ + virt-log virt-ls \ + virt-resize virt-sparsify virt-sysprep \ +diff --git a/bash/virt-alignment-scan b/bash/virt-alignment-scan +index b93a00118..bb9a71ebf 100644 +--- a/bash/virt-alignment-scan ++++ b/bash/virt-alignment-scan +@@ -109,12 +109,6 @@ _virt_customize () + } && + complete -o default -F _virt_customize virt-customize + +-_virt_dib () +-{ +- _guestfs_virttools "virt-dib" 0 +-} && +-complete -o default -F _virt_dib virt-dib +- + _virt_df () + { + _guestfs_virttools "virt-df" 1 +diff --git a/configure.ac b/configure.ac +index 1f8acced2..e7fcff136 100644 +--- a/configure.ac ++++ b/configure.ac +@@ -136,7 +136,6 @@ AC_CONFIG_FILES([Makefile + customize/Makefile + docs/Makefile + df/Makefile +- dib/Makefile + diff/Makefile + drivers/Makefile + edit/Makefile +diff --git a/dib/Makefile.am b/dib/Makefile.am +deleted file mode 100644 +index 7581feb78..000000000 +--- a/dib/Makefile.am ++++ /dev/null +@@ -1,169 +0,0 @@ +-# 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_MLI) $(SOURCES_ML) $(SOURCES_C) \ +- test-virt-dib-docs.sh \ +- virt-dib.pod +- +-SOURCES_MLI = \ +- cmdline.mli \ +- dib.mli \ +- elements.mli \ +- output_format.mli \ +- $(patsubst %,output_format_%.mli,$(formats)) \ +- utils.mli +- +-# Filenames output_format_.ml in alphabetical order. +-formats = \ +- docker \ +- qcow2 \ +- raw \ +- squashfs \ +- tar \ +- tgz \ +- vhd +- +-SOURCES_ML = \ +- utils.ml \ +- output_format.ml \ +- cmdline.ml \ +- elements.ml \ +- $(patsubst %,output_format_%.ml,$(formats)) \ +- dib.ml +- +-SOURCES_C = \ +- dummy.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)/common/utils \ +- -I$(top_srcdir)/lib +-virt_dib_CFLAGS = \ +- -pthread \ +- $(WARN_CFLAGS) $(WERROR_CFLAGS) +- +-BOBJECTS = \ +- $(SOURCES_ML:.ml=.cmo) +-XOBJECTS = $(BOBJECTS:.cmo=.cmx) +- +-OCAMLPACKAGES = \ +- -package str,unix,guestfs \ +- -I $(top_builddir)/common/utils/.libs \ +- -I $(top_builddir)/gnulib/lib/.libs \ +- -I $(top_builddir)/ocaml \ +- -I $(top_builddir)/common/mlstdutils \ +- -I $(top_builddir)/common/mlutils \ +- -I $(top_builddir)/common/mlgettext \ +- -I $(top_builddir)/common/mlpcre \ +- -I $(top_builddir)/common/mltools +-if HAVE_OCAML_PKG_GETTEXT +-OCAMLPACKAGES += -package gettext-stub +-endif +- +-OCAMLCLIBS = \ +- -pthread -lpthread \ +- -lutils \ +- $(LIBXML2_LIBS) \ +- $(LIBGUESTFS_LIBS) \ +- $(LIBINTL) \ +- -lgnu +- +-OCAMLFLAGS = $(OCAML_FLAGS) $(OCAML_WARN_ERROR) -ccopt '$(CFLAGS)' +- +-if !HAVE_OCAMLOPT +-OBJECTS = $(BOBJECTS) +-else +-OBJECTS = $(XOBJECTS) +-endif +- +-OCAMLLINKFLAGS = \ +- mlstdutils.$(MLARCHIVE) \ +- mlguestfs.$(MLARCHIVE) \ +- mlcutils.$(MLARCHIVE) \ +- mlgettext.$(MLARCHIVE) \ +- mlpcre.$(MLARCHIVE) \ +- mltools.$(MLARCHIVE) \ +- $(LINK_CUSTOM_OCAMLC_ONLY) +- +-virt_dib_DEPENDENCIES = \ +- $(OBJECTS) \ +- ../common/mlstdutils/mlstdutils.$(MLARCHIVE) \ +- ../common/mlutils/mlcutils.$(MLARCHIVE) \ +- ../common/mlgettext/mlgettext.$(MLARCHIVE) \ +- ../common/mlpcre/mlpcre.$(MLARCHIVE) \ +- ../common/mltools/mltools.$(MLARCHIVE) \ +- $(top_builddir)/ocaml-link.sh +-virt_dib_LINK = \ +- $(top_builddir)/ocaml-link.sh -cclib '$(OCAMLCLIBS)' -- \ +- $(OCAMLFIND) $(BEST) $(OCAMLFLAGS) $(OCAMLPACKAGES) $(OCAMLLINKFLAGS) \ +- $(OBJECTS) -o $@ +- +-# The output_format_*.mli files are all empty and autogenerated. +-CLEANFILES += \ +- $(patsubst %,output_format_%.mli,$(formats)) +- +-output_format_%.mli: +- rm -f $@ $@-t +- echo '(* This file is generated by Makefile.am. *)' >> $@-t +- echo '(* Nothing is exported from output format modules. *)' >> $@-t +- mv $@-t $@ +- +-# Tests. +- +-TESTS_ENVIRONMENT = $(top_builddir)/run --test +- +-TESTS = test-virt-dib-docs.sh +- +-# Manual pages and HTML files for the website. +- +-man_MANS = virt-dib.1 +- +-noinst_DATA = $(top_builddir)/website/virt-dib.1.html +- +-virt-dib.1 $(top_builddir)/website/virt-dib.1.html: stamp-virt-dib.pod +- +-stamp-virt-dib.pod: virt-dib.pod +- $(PODWRAPPER) \ +- --man virt-dib.1 \ +- --html $(top_builddir)/website/virt-dib.1.html \ +- --license GPLv2+ \ +- --warning safe \ +- $< +- touch $@ +- +-# OCaml dependencies. +-.depend: $(SOURCES_MLI) $(SOURCES_ML) +- $(top_builddir)/ocaml-dep.sh $^ +--include .depend +- +-endif +- +-.PHONY: docs +diff --git a/dib/cmdline.ml b/dib/cmdline.ml +deleted file mode 100644 +index 11ff57341..000000000 +--- a/dib/cmdline.ml ++++ /dev/null +@@ -1,267 +0,0 @@ +-(* 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 Std_utils +-open Tools_utils +-open Common_gettext.Gettext +-open Getopt.OptionName +- +-open Utils +- +-open Printf +- +-type cmdline = { +- debug : int; +- basepath : string; +- elements : string list; +- excluded_elements : string list; +- element_paths : string list; +- excluded_scripts : string list; +- use_base : bool; +- drive : string option; +- drive_format : string option; +- image_name : string; +- fs_type : string; +- size : int64; +- root_label : string option; +- install_type : string; +- image_cache : string option; +- mkfs_options : string option; +- is_ramdisk : bool; +- ramdisk_element : string; +- extra_packages : string list; +- memsize : int option; +- network : bool; +- smp : int option; +- delete_on_failure : bool; +- formats : Output_format.set; +- arch : string; +- envvars : string list; +- checksum : bool; +- python : string option; +-} +- +-let parse_cmdline () = +- 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 = List.push_front element elements in +- +- let excluded_elements = ref [] in +- let append_excluded_element element = List.push_front element excluded_elements in +- +- let element_paths = ref [] in +- let append_element_path arg = List.push_front arg element_paths in +- +- let excluded_scripts = ref [] in +- let append_excluded_script arg = List.push_front 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 None in +- let set_format arg = +- let fmts = List.remove_duplicates (String.nsplit "," arg) in +- let fmtset = +- List.fold_left ( +- fun fmtset fmt -> +- try Output_format.add_to_set fmt fmtset +- with Not_found -> +- error (f_"invalid format ‘%s’ in --formats") fmt +- ) Output_format.empty_set fmts in +- formats := Some fmtset in +- +- let envvars = ref [] in +- let append_envvar arg = List.push_front 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 drive_format = ref None in +- let set_drive_format arg = drive_format := 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 delete_on_failure = ref true in +- +- let is_ramdisk = ref false in +- let ramdisk_element = ref "ramdisk" in +- +- let mkfs_options = ref None in +- let set_mkfs_options arg = mkfs_options := Some arg in +- +- let extra_packages = ref [] in +- let append_extra_packages arg = +- List.push_front_list (List.rev (String.nsplit "," arg)) extra_packages in +- +- let checksum = ref false in +- +- let python = ref None in +- let set_python arg = python := Some arg in +- +- let argspec = [ +- [ S 'p'; L"element-path" ], Getopt.String ("path", append_element_path), s_"Add new a elements location"; +- [ L"exclude-element" ], Getopt.String ("element", append_excluded_element), +- s_"Exclude the specified element"; +- [ L"exclude-script" ], Getopt.String ("script", append_excluded_script), +- s_"Exclude the specified script"; +- [ L"envvar" ], Getopt.String ("envvar[=value]", append_envvar), s_"Carry/set this environment variable"; +- [ L"skip-base" ], Getopt.Clear use_base, s_"Skip the inclusion of the ‘base’ element"; +- [ L"root-label" ], Getopt.String ("label", set_root_label), s_"Label for the root fs"; +- [ L"install-type" ], Getopt.Set_string ("type", install_type), s_"Installation type"; +- [ L"image-cache" ], Getopt.String ("directory", set_image_cache), s_"Location for cached images"; +- [ L"mkfs-options" ], Getopt.String ("option", set_mkfs_options), +- s_"Add mkfs options"; +- [ L"extra-packages" ], Getopt.String ("pkg,...", append_extra_packages), +- s_"Add extra packages to install"; +- [ L"checksum" ], Getopt.Set checksum, s_"Generate MD5 and SHA256 checksum files"; +- [ L"python" ], Getopt.String ("python", set_python), s_"Set Python interpreter"; +- +- [ L"ramdisk" ], Getopt.Set is_ramdisk, "Switch to a ramdisk build"; +- [ L"ramdisk-element" ], Getopt.Set_string ("name", ramdisk_element), s_"Main element for building ramdisks"; +- +- [ L"name" ], Getopt.Set_string ("name", image_name), s_"Name of the image"; +- [ L"fs-type" ], Getopt.Set_string ("fs", fs_type), s_"Filesystem for the image"; +- [ L"size" ], Getopt.String ("size", set_size), s_"Set output disk size"; +- [ L"formats" ], Getopt.String ("qcow2,tgz,...", set_format), s_"Output formats"; +- [ L"arch" ], Getopt.Set_string ("arch", arch), s_"Output architecture"; +- [ L"drive" ], Getopt.String ("path", set_drive), s_"Optional drive for caches"; +- [ L"drive-format" ], Getopt.String (s_"format", set_drive_format), s_"Format of optional drive"; +- +- [ S 'm'; L"memsize" ], Getopt.Int ("mb", set_memsize), s_"Set memory size"; +- [ L"network" ], Getopt.Set network, s_"Enable appliance network (default)"; +- [ L"no-network" ], Getopt.Clear network, s_"Disable appliance network"; +- [ L"smp" ], Getopt.Int ("vcpus", set_smp), s_"Set number of vCPUs"; +- [ L"no-delete-on-failure" ], Getopt.Clear delete_on_failure, +- s_"Don’t delete output file on failure"; +- +- [ L"debug" ], Getopt.Int ("level", set_debug), s_"Set debug level"; +- [ S 'B' ], Getopt.Set_string ("path", basepath), s_"Base path of diskimage-builder library"; +- ] in +- let argspec = argspec @ Output_format.extra_args () in +- +- let opthandle = create_standard_options argspec ~anon_fun:append_element ~machine_readable:true usage_msg in +- Getopt.parse opthandle.getopt; +- +- 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 drive_format = !drive_format in +- let root_label = !root_label in +- let install_type = !install_type in +- let image_cache = !image_cache in +- let delete_on_failure = !delete_on_failure in +- let is_ramdisk = !is_ramdisk in +- let ramdisk_element = !ramdisk_element in +- let mkfs_options = !mkfs_options in +- let extra_packages = List.rev !extra_packages in +- let checksum = !checksum in +- let python = !python in +- +- (* No elements and machine-readable mode? Print some facts. *) +- (match elements, machine_readable () with +- | [], Some { pr } -> +- pr "virt-dib\n"; +- let formats_list = Output_format.list_formats () in +- List.iter (pr "output:%s\n") formats_list; +- exit 0 +- | _, _ -> () +- ); +- +- if basepath = "" then +- error (f_"-B must be specified"); +- +- let formats = +- match formats with +- | None -> Output_format.add_to_set "qcow2" Output_format.empty_set +- | Some fmtset -> +- if Output_format.set_cardinal fmtset = 0 then +- error (f_"the list of output formats cannot be empty"); +- fmtset in +- +- if elements = [] then +- error (f_"at least one distribution root element must be specified"); +- +- let python = Option.map get_required_tool python in +- +- { debug = debug; basepath = basepath; elements = elements; +- excluded_elements = excluded_elements; element_paths = element_paths; +- excluded_scripts = excluded_scripts; use_base = use_base; drive = drive; +- drive_format = drive_format; image_name = image_name; fs_type = fs_type; +- size = size; root_label = root_label; install_type = install_type; +- image_cache = image_cache; mkfs_options = mkfs_options; +- is_ramdisk = is_ramdisk; ramdisk_element = ramdisk_element; +- extra_packages = extra_packages; memsize = memsize; network = network; +- smp = smp; delete_on_failure = delete_on_failure; +- formats = formats; arch = arch; envvars = envvars; +- checksum = checksum; python = python; +- } +diff --git a/dib/cmdline.mli b/dib/cmdline.mli +deleted file mode 100644 +index 5c82efd60..000000000 +--- a/dib/cmdline.mli ++++ /dev/null +@@ -1,52 +0,0 @@ +-(* 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. *) +- +-type cmdline = { +- debug : int; +- basepath : string; +- elements : string list; +- excluded_elements : string list; +- element_paths : string list; +- excluded_scripts : string list; +- use_base : bool; +- drive : string option; +- drive_format : string option; +- image_name : string; +- fs_type : string; +- size : int64; +- root_label : string option; +- install_type : string; +- image_cache : string option; +- mkfs_options : string option; +- is_ramdisk : bool; +- ramdisk_element : string; +- extra_packages : string list; +- memsize : int option; +- network : bool; +- smp : int option; +- delete_on_failure : bool; +- formats : Output_format.set; +- arch : string; +- envvars : string list; +- checksum : bool; +- python : string option; +-} +- +-val parse_cmdline : unit -> cmdline +diff --git a/dib/dib.ml b/dib/dib.ml +deleted file mode 100644 +index a4ba36040..000000000 +--- a/dib/dib.ml ++++ /dev/null +@@ -1,1007 +0,0 @@ +-(* 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 Std_utils +-open Tools_utils +-open Unix_utils +-open Common_gettext.Gettext +- +-open Cmdline +-open Utils +-open Elements +- +-open Printf +- +-module G = Guestfs +- +-let checksums = [ "md5"; "sha256" ] +-and tool_of_checksum csum = +- csum ^ "sum" +- +-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 = +- List.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.is_prefix x "DIB_") vars in +- let vars = List.map (fun x -> x ^ "\n") vars in +- String.concat "" vars +- +-let write_script fn text = +- with_open_out fn ( +- fun oc -> +- output_string oc text; +- flush oc +- ); +- Unix.chmod fn 0o755 +- +-let envvars_string l = +- let l = List.map ( +- fun (var, value) -> +- sprintf "export %s=%s" var (quote value) +- ) l in +- String.concat "\n" l +- +-let prepare_external ~envvars ~dib_args ~dib_vars ~out_name ~root_label +- ~rootfs_uuid ~image_cache ~arch ~network ~debug ~fs_type ~checksum +- ~python +- destdir libdir fakebindir loaded_elements all_elements element_paths = +- let network_string = if network then "" else "1" in +- let checksum_string = if checksum then "1" else "" in +- let elements_paths_yaml = +- List.map ( +- fun e -> +- sprintf "%s: %s" e (quote (Hashtbl.find loaded_elements e).directory) +- ) (StringSet.elements all_elements) in +- let elements_paths_yaml = String.concat ", " elements_paths_yaml in +- let elements_paths_array = +- List.map ( +- fun e -> +- sprintf "[%s]=%s" e (quote (Hashtbl.find loaded_elements e).directory) +- ) (StringSet.elements all_elements) in +- let elements_paths_array = String.concat " " elements_paths_array in +- +- let run_extra = sprintf "\ +-#!/bin/bash +-set -e +-%s +-mount_dir=$1 +-shift +-hooks_dir=$1 +-shift +-target_dir=$1 +-shift +-script=$1 +-shift +- +-VIRT_DIB_OURPATH=$(dirname $(realpath $0)) +- +-# user variables +-%s +- +-export PATH=%s:$PATH +- +-# d-i-b variables +-export TMP_MOUNT_PATH=\"$mount_dir\" +-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=\"$hooks_dir\" +-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 +-export FS_TYPE=%s +-export DIB_CHECKSUM=%s +-export DIB_PYTHON_EXEC=%s +- +-elinfo_out=$(<${VIRT_DIB_OURPATH}/elinfo_out) +-eval \"$elinfo_out\" +- +-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 +- +-source $_LIB/die +- +-$target_dir/$script +-" +- (if debug >= 1 then "set -x\n" else "") +- (envvars_string envvars) +- fakebindir +- network_string +- out_name +- root_label +- rootfs_uuid +- image_cache +- (quote libdir) +- arch +- dib_args +- (String.concat " " (StringSet.elements all_elements)) +- (String.concat ":" element_paths) +- (quote dib_vars) +- debug +- fs_type +- checksum_string +- python in +- write_script (destdir // "run-part-extra.sh") run_extra; +- let elinfo_out = sprintf "\ +-export IMAGE_ELEMENT_YAML=\"{%s}\" +-function get_image_element_array { +- echo \"%s\" +-}; +-export -f get_image_element_array; +-" +- elements_paths_yaml +- elements_paths_array in +- write_script (destdir // "elinfo_out") elinfo_out +- +-let prepare_aux ~envvars ~dib_args ~dib_vars ~log_file ~out_name ~rootfs_uuid +- ~arch ~network ~root_label ~install_type ~debug ~extra_packages ~fs_type +- ~checksum destdir all_elements = +- let network_string = if network then "" else "1" in +- let checksum_string = if checksum then "1" else "" 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/in_target.aux/perm/home +-export PATH=$mysysroot/tmp/in_target.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/in_target.aux/lib +-export _PREFIX=$mysysroot/tmp/in_target.aux/elements +-export ARCH=%s +-export TMP_HOOKS_PATH=$mysysroot/tmp/in_target.aux/hooks +-export DIB_ARGS=\"%s\" +-export DIB_MANIFEST_SAVE_DIR=\"$mysysroot/tmp/in_target.aux/out/${IMAGE_NAME}.d\" +-export IMAGE_BLOCK_DEVICE=$blockdev +-export IMAGE_BLOCK_DEVICE_WITHOUT_PART=$(echo ${IMAGE_BLOCK_DEVICE} | sed -e \"s|^\\(.*loop[0-9]*\\)p[0-9]*$|\\1|g\") +-export IMAGE_ELEMENT=\"%s\" +-export DIB_ENV=%s +-export DIB_DEBUG_TRACE=%d +-export DIB_NO_TMPFS=1 +-export FS_TYPE=%s +-export DIB_CHECKSUM=%s +- +-export TMP_BUILD_DIR=$mysysroot/tmp/in_target.aux +-export TMP_IMAGE_DIR=$mysysroot/tmp/in_target.aux +- +-if [ -n \"$mysysroot\" ]; then +- export PATH=$mysysroot/tmp/in_target.aux/fake-bin:$PATH +- source $_LIB/die +-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 "") +- (envvars_string envvars) +- network_string +- out_name +- rootfs_uuid +- root_label +- arch +- dib_args +- (String.concat " " (StringSet.elements all_elements)) +- (quote dib_vars) +- debug +- fs_type +- checksum_string 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 `awk 'BEGIN{for (i in ENVIRON) {print i}}'`; do +- case \"$envvar\" in +- PATH | USER | USERNAME | HOSTNAME | TERM | LANG | HOME | SHELL | LOGNAME ) ;; +- BASH_FUNC_* ) unset -f $envvar ;; +- *) unset $envvar ;; +- esac +- done +-fi +-# TMPDIR needs to be unset, regardless of -E +-unset TMPDIR +-# ... and do that also to the other \"TMPDIR\"-like variables +-unset TMP +-unset TMP_DIR +- +-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 Executable_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/in_target.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), "" -> "''" +- | (In|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/in_target.aux/run-and-log.sh '%s' '' '' '%s' '%s' '%s' '%s'" log_file blockdev hook_dir new_wd x) +- | Out -> +- g#debug "sh" [| "/sysroot/tmp/in_target.aux/run-and-log.sh"; "/sysroot" ^ log_file; "/sysroot"; "/sysroot"; blockdev; "/sysroot" ^ hook_dir; new_wd; x |] +- | Subroot -> +- g#debug "sh" [| "/sysroot/tmp/in_target.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 (g : Guestfs.guestfs) hook_name base_mount_dir scripts run_script = +- let scripts = List.sort digit_prefix_compare scripts in +- let mount_dir = base_mount_dir // hook_name in +- (* Point to the in-guest hooks, so that changes there can affect +- * other phases. +- *) +- let hooks_dir = mount_dir // "tmp" // "in_target.aux" // "hooks" in +- let hook_dir = hooks_dir // hook_name in +- do_mkdir mount_dir; +- +- let rec fork_and_run () = +- let pid = Unix.fork () in +- if pid = 0 then ( (* child *) +- let retcode = run_scripts () in +- flush_all (); +- let cmd = [ "guestunmount"; mount_dir ] in +- ignore (run_command cmd); +- Exit._exit retcode +- ); +- pid +- and run_scripts () = +- let timings = Hashtbl.create 13 in +- let rec loop = function +- | x :: xs -> +- message (f_"Running: %s/%s") hook_name x; +- let cmd = [ run_script; mount_dir; hooks_dir; hook_dir; x ] in +- let retcode = ref 0 in +- let run () = +- retcode := 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; +- let retcode = !retcode in +- if retcode <> 0 then retcode +- else loop xs +- | [] -> 0 +- in +- let retcode = loop scripts in +- if debug >= 1 then ( +- print_string (timing_output ~target_name:hook_name scripts timings) +- ); +- retcode +- in +- +- g#mount_local mount_dir; +- let pid = fork_and_run () in +- g#mount_local_run (); +- +- (match snd (Unix.waitpid [] pid) with +- | Unix.WEXITED 0 -> () +- | Unix.WEXITED i -> exit i +- | Unix.WSIGNALED i +- | Unix.WSTOPPED i -> +- error (f_"sub-process killed by signal (%d)") i +- ); +- +- 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/in_target.aux/run-and-log.sh '%s' '' '' '%s' '/tmp/in_target.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 +- +-(* Finalize the list of output formats. *) +-let () = Output_format.bake () +- +-let main () = +- let cmdline = parse_cmdline () in +- let debug = cmdline.debug 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 (cmdline.basepath // "die")) then +- error (f_"the specified base path is not the diskimage-builder library"); +- +- (* Check for required tools. *) +- let python = +- match cmdline.python with +- | None -> get_required_tool "python" +- | Some exe -> exe in +- require_tool "uuidgen"; +- Output_format.check_formats_prerequisites cmdline.formats; +- if cmdline.checksum then +- List.iter (fun x -> require_tool (tool_of_checksum x)) checksums; +- +- let image_basename = Filename.basename cmdline.image_name in +- let image_basename_d = image_basename ^ ".d" in +- +- let tmpdir = Mkdtemp.temp_dir "dib." in +- On_exit.rm_rf tmpdir; +- let auxtmpdir = tmpdir // "in_target.aux" in +- do_mkdir auxtmpdir; +- let hookstmpdir = auxtmpdir // "hooks" in +- do_mkdir (hookstmpdir // "environment.d"); (* Just like d-i-b does. *) +- do_mkdir (auxtmpdir // "out" // image_basename_d); +- let elements = +- if cmdline.use_base then ["base"] @ cmdline.elements +- else cmdline.elements in +- let elements = +- if cmdline.is_ramdisk then [cmdline.ramdisk_element] @ elements +- else elements in +- info (f_"Elements: %s") (String.concat " " elements); +- if debug >= 1 then ( +- printf "tmpdir: %s\n" tmpdir; +- printf "element paths: %s\n" (String.concat ":" cmdline.element_paths); +- ); +- +- let loaded_elements = load_elements ~debug cmdline.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 +- (cmdline.excluded_elements @ builtin_elements_blacklist) in +- +- info (f_"Expanded elements: %s") +- (String.concat " " (StringSet.elements all_elements)); +- +- let envvars = read_envvars cmdline.envvars in +- info (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 = stringify_args (Array.to_list 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 +- (cmdline.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/in_target.aux/perm/" ^ (log_filename ()) in +- +- let arch = +- match cmdline.arch with +- | "" -> current_arch () +- | arch -> arch in +- +- let root_label = +- match cmdline.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 cmdline.fs_type with +- | "xfs" -> "img-rootfs" +- | _ -> "cloudimg-rootfs") +- | Some label -> label in +- +- let image_cache = +- match cmdline.image_cache with +- | None -> Sys.getenv "HOME" // ".cache" // "image-create" +- | Some dir -> dir in +- do_mkdir image_cache; +- +- let rootfs_uuid = uuidgen () in +- +- prepare_aux ~envvars ~dib_args ~dib_vars ~log_file ~out_name:image_basename +- ~rootfs_uuid ~arch ~network:cmdline.network ~root_label +- ~install_type:cmdline.install_type ~debug +- ~extra_packages:cmdline.extra_packages +- ~fs_type:cmdline.fs_type +- ~checksum:cmdline.checksum +- auxtmpdir all_elements; +- +- let delete_output_file = ref cmdline.delete_on_failure in +- let delete_file () = +- if !delete_output_file then ( +- let filenames = Output_format.get_filenames cmdline.formats cmdline.image_name in +- List.iter ( +- fun fn -> +- try Unix.unlink fn with _ -> () +- ) filenames +- ) +- in +- at_exit delete_file; +- +- prepare_external ~envvars ~dib_args ~dib_vars ~out_name:image_basename +- ~root_label ~rootfs_uuid ~image_cache ~arch +- ~network:cmdline.network ~debug +- ~fs_type:cmdline.fs_type +- ~checksum:cmdline.checksum +- ~python +- tmpdir cmdline.basepath +- (auxtmpdir // "fake-bin") +- loaded_elements all_elements cmdline.element_paths; +- +- let run_hook ~blockdev ~sysroot ?(new_wd = "") (g : Guestfs.guestfs) hook = +- try +- let scripts = +- (* Sadly, scripts (especially in root.d and extra-data.d) +- * can add (by copying or symlinking) new scripts for other +- * phases, which would be ignored if we were using the lists +- * collected after composing the tree of hooks. +- * As result, when running in-chroot hooks, re-read the list +- * of scripts actually available for each hook. +- *) +- match hook with +- | "pre-install.d" | "install.d" | "post-install.d" | "finalise.d" -> +- let scripts_path = "/tmp/in_target.aux/hooks/" ^ hook in +- (* Cleanly handle cases when the phase directory does not exist. *) +- if g#is_dir ~followsymlinks:true scripts_path then +- load_scripts g scripts_path +- else +- raise Not_found +- | _ -> +- 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 +- +- let copy_in (g : Guestfs.guestfs) srcdir destdir = +- let desttar = Filename.temp_file ~temp_dir:tmpdir "virt-dib." ".tar.gz" in +- let cmd = [ "tar"; "czf"; desttar; "-C"; srcdir; "--owner=root"; +- "--group=root"; "." ] in +- if run_command cmd <> 0 then exit 1; +- g#mkdir_p destdir; +- g#tar_in ~compress:"gzip" desttar destdir; +- Sys.remove desttar in +- +- if debug >= 1 then +- ignore (run_command [ "tree"; "-ps"; tmpdir ]); +- +- message (f_"Opening the disks"); +- +- let is_ramdisk_build = +- cmdline.is_ramdisk || StringSet.mem "ironic-agent" all_elements in +- +- let g, tmpdisk, tmpdiskfmt, drive_partition = +- let g = open_guestfs () in +- Option.may g#set_memsize cmdline.memsize; +- Option.may g#set_smp cmdline.smp; +- g#set_network cmdline.network; +- +- (* 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 && Output_format.set_mem "raw" cmdline.formats then +- cmdline.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 cmdline.size; +- g#add_drive ~readonly:false ~format:fmt fn; +- +- (* Helper drive for elements and binaries. *) +- g#add_drive_scratch (unit_GB 5); +- +- (match cmdline.drive with +- | None -> +- g#add_drive_scratch (unit_GB 5) +- | Some drive -> +- g#add_drive ?format:cmdline.drive_format drive; +- ); +- +- g#launch (); +- +- Output_format.check_formats_appliance_prerequisites cmdline.formats g; +- +- (* Prepare the /in_target.aux partition. *) +- g#mkfs "ext2" "/dev/sdb"; +- g#mount "/dev/sdb" "/"; +- +- copy_in g auxtmpdir "/"; +- copy_in g cmdline.basepath "/lib"; +- g#umount "/"; +- +- (* Prepare the /in_target.aux/perm partition. *) +- let drive_partition = +- match cmdline.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.is_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/in_target.aux"; +- g#mount "/dev/sdb" "/tmp/in_target.aux"; +- g#mount drive_partition "/tmp/in_target.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) +- and 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 g hook tmpdir scripts +- (tmpdir // "run-part-extra.sh") +- with Not_found -> () 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 cmdline.mkfs_options with +- | None -> [] +- | Some o -> [ o ] in +- let mkfs_options = +- [ "-t"; cmdline.fs_type ] @ +- (match cmdline.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 @ [ blockdev ] in +- ignore (g#debug "sh" (Array.of_list ([ "mkfs" ] @ mkfs_options))); +- g#set_label blockdev root_label; +- if String.is_prefix cmdline.fs_type "ext" then +- 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/in_target.aux/perm"; +- g#umount "/tmp/in_target.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 "in_target.aux/hooks" "/tmp/in_target.d"; +- +- run_hook_host "extra-data.d"; +- +- run_hook_in "pre-install.d"; +- +- if cmdline.extra_packages <> [] then +- ignore (run_install_packages ~debug ~blockdev ~log_file g +- cmdline.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/in_target.aux still exists. *) +- ignore (g#is_dir "/tmp/in_target.aux"); +- g#mount "/dev/sdb" "/tmp/in_target.aux"; +- g#mount drive_partition "/tmp/in_target.aux/perm"; +- +- run_hook_in "finalise.d"; +- +- let out_dir = "/tmp/in_target.aux/out/" ^ image_basename_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 (cmdline.image_name ^ ".d"); +- g#copy_out out_dir (Filename.dirname cmdline.image_name); +- ); +- +- (* 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"); +- (* Truncate /var/log files in preparation for first boot. *) +- truncate_recursive g "/var/log"; +- let non_log fn = +- not (String.is_suffix fn ".log") +- in +- (* Remove root logs. *) +- rm_rf_only_files g ~filter:non_log "/root"; +- +- flush_all (); +- +- Output_format.run_formats_on_filesystem cmdline.formats g cmdline.image_name tmpdir; +- +- 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 +- Output_format.run_formats_on_file cmdline.formats cmdline.image_name (tmpdisk, tmpdiskfmt) tmpdir; +- +- if not is_ramdisk_build && cmdline.checksum then ( +- let file_flags = [ Unix.O_WRONLY; Unix.O_CREAT; Unix.O_TRUNC; ] in +- let filenames = Output_format.get_filenames cmdline.formats cmdline.image_name in +- List.iter ( +- fun fn -> +- message (f_"Generating checksums for %s") fn; +- let cmds = +- List.map ( +- fun csum -> +- let csum_fn = fn ^ "." ^ csum in +- let csum_tool = tool_of_checksum csum in +- let outfd = Unix.openfile csum_fn file_flags 0o640 in +- [ csum_tool; fn ], Some outfd, None +- ) checksums in +- let res = run_commands cmds in +- List.iteri ( +- fun i code -> +- if code <> 0 then ( +- let args, _, _ = List.nth cmds i in +- error (f_"external command ‘%s’ exited with error %d") +- (List.hd args) code +- ) +- ) res; +- ) filenames; +- ); +- +- message (f_"Done") +- +-let () = run_main_and_handle_errors main +diff --git a/dib/dib.mli b/dib/dib.mli +deleted file mode 100644 +index 84aa4fcdb..000000000 +--- a/dib/dib.mli ++++ /dev/null +@@ -1,19 +0,0 @@ +-(* 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. +- *) +- +-(* Nothing is exported. *) +diff --git a/dib/dummy.c b/dib/dummy.c +deleted file mode 100644 +index ebab6198c..000000000 +--- a/dib/dummy.c ++++ /dev/null +@@ -1,2 +0,0 @@ +-/* Dummy source, to be used for OCaml-based tools with no C sources. */ +-enum { foo = 1 }; +diff --git a/dib/elements.ml b/dib/elements.ml +deleted file mode 100644 +index 5a904baef..000000000 +--- a/dib/elements.ml ++++ /dev/null +@@ -1,207 +0,0 @@ +-(* 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 Std_utils +-open Tools_utils +-open Common_gettext.Gettext +- +-open Utils +- +-open Printf +- +-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 *) +- +-let builtin_elements_blacklist = [ +-] +- +-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_scripts (g : Guestfs.guestfs) path = +- let listing = Array.to_list (g#readdir path) in +- let scripts = List.filter ( +- function +- | { Guestfs.ftyp = ('r'|'l'|'u'|'?') } -> true +- | _ -> false +- ) listing in +- let scripts = List.filter (fun x -> valid_script_name x.Guestfs.name) scripts in +- List.filter_map ( +- fun x -> +- let { Guestfs.st_mode = mode } = g#statns (path ^ "/" ^ x.Guestfs.name) in +- if mode &^ 0o111_L > 0_L then Some x.Guestfs.name +- else None +- ) scripts +- +-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 +- let provided_by = Hashtbl.create 13 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 element_deps = get_deps elem in +- let element_provides = get_provides elem in +- (* Save which elements provide another element for potential +- * error message. +- *) +- StringSet.iter (fun x -> Hashtbl.add provided_by x elem) element_provides; +- provided := StringSet.union !provided element_provides; +- StringSet.iter (fun x -> Queue.push x queue) +- (StringSet.diff element_deps (StringSet.union !final !provided)); +- final := StringSet.union !final element_deps +- ) +- done; +- let conflicts = StringSet.inter (stringset_of_list elements) !provided in +- if not (StringSet.is_empty conflicts) then ( +- let buf = Buffer.create 100 in +- StringSet.iter ( +- fun elem -> +- let s = sprintf (f_" %s: already provided by %s") +- elem (Hashtbl.find provided_by elem) in +- Buffer.add_string buf s +- ) conflicts; +- error (f_"following elements are already provided by another element:\n%s") +- (Buffer.contents buf) +- ); +- 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 +- 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 +diff --git a/dib/elements.mli b/dib/elements.mli +deleted file mode 100644 +index f351afeff..000000000 +--- a/dib/elements.mli ++++ /dev/null +@@ -1,61 +0,0 @@ +-(* 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. *) +- +-type element = { +- directory : string; (** directory of the element *) +- hooks : hooks_map; (** available hooks, and scripts for each hook*) +-} +-and hooks_map = (string, string list) Hashtbl.t (** hook name, scripts *) +- +-val builtin_elements_blacklist : string list +-(** These are the elements which we don't ever try to use. *) +- +-val builtin_scripts_blacklist : string list +-(** 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. *) +- +-val load_elements : debug:int -> string list -> (string, element) Hashtbl.t +-(** [load_elements ~debug paths] loads elements from the specified +- [paths]; returns a [Hashtbl.t] of {!element} structs indexed by +- the element name. *) +- +-val load_dependencies : StringSet.elt list -> (string, element) Hashtbl.t -> StringSet.t +-(** [load_dependencies element_set elements] returns the whole set of +- elements needed to use [element_set], including [element_list] +- themselves. In other words, this recursively resolves the +- dependencies of [element_set]. *) +- +-val copy_elements : StringSet.t -> (string, element) Hashtbl.t -> string list -> string -> unit +-(** [copy_elements element_set elements blacklisted_scripts destdir] +- copies the elements in [element_set] (with the element definitions +- provided as [elements]) into the [destdir] directory. +- +- [blacklisted_scripts] contains names of scripts to never copy. *) +- +-val load_hooks : debug:int -> string -> hooks_map +-(** [load_hooks ~debug path] loads the hooks from the specified +- [path] (which usually represents an element). *) +- +-val load_scripts : Guestfs.guestfs -> string -> string list +-(** [load_scripts g path] loads the scripts from the specified [path] +- (which usually represents a directory of an hook). *) +diff --git a/dib/output_format.ml b/dib/output_format.ml +deleted file mode 100644 +index 247f33540..000000000 +--- a/dib/output_format.ml ++++ /dev/null +@@ -1,192 +0,0 @@ +-(* virt-dib +- * Copyright (C) 2012-2023 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 Std_utils +-open Tools_utils +-open Common_gettext.Gettext +-open Getopt.OptionName +- +-open Utils +- +-type format = { +- name : string; +- extra_args : extra_arg list; +- output_to_file : bool; +- check_prerequisites : (unit -> unit) option; +- check_appliance_prerequisites : (Guestfs.guestfs -> unit) option; +- run_on_filesystem : (Guestfs.guestfs -> string -> string -> unit) option; +- run_on_file : (string -> (string * string) -> string -> unit) option; +-} +-and extra_arg = { +- extra_argspec : Getopt.keys * Getopt.spec * Getopt.doc; +-} +- +-let defaults = { +- name = ""; +- extra_args = []; +- output_to_file = true; +- check_prerequisites = None; +- check_appliance_prerequisites = None; +- run_on_filesystem = None; +- run_on_file = None; +-} +- +-let all_formats = ref [] +- +-module FormatSet = Set.Make ( +- struct +- type t = format +- let compare a b = compare a.name b.name +- end +-) +-type set = FormatSet.t +- +-let empty_set = FormatSet.empty +- +-let add_to_set name set = +- let op = List.find (fun { name = n } -> name = n) !all_formats in +- FormatSet.add op set +- +-let set_mem x set = +- FormatSet.exists (fun { name = n } -> n = x) set +- +-let set_cardinal set = +- FormatSet.cardinal set +- +-let register_format op = +- List.push_front op all_formats +- +-let baked = ref false +-let rec bake () = +- (* Note we actually want all_formats to be sorted by name, +- * ignoring the order field. +- *) +- let ops = +- List.sort (fun { name = a } { name = b } -> compare a b) !all_formats in +- check_no_dupes ops; +- List.iter check ops; +- all_formats := ops; +- baked := true +-and check_no_dupes ops = +- ignore ( +- List.fold_left ( +- fun opset op -> +- if FormatSet.mem op opset then +- error (f_"duplicate format name (%s)") op.name; +- add_to_set op.name opset +- ) empty_set ops +- ) +-and check op = +- let n = String.length op.name in +- if n = 0 then +- error (f_"format name is an empty string"); +- for i = 0 to n-1 do +- match String.unsafe_get op.name i with +- | 'a'..'z' | 'A'..'Z' | '0'..'9' | '-' -> () +- | c -> +- error (f_"disallowed character (%c) in format name") c +- done +- +-let extra_args () = +- assert !baked; +- +- List.flatten ( +- List.map (fun { extra_args } -> +- List.map (fun { extra_argspec = argspec } -> argspec) extra_args +- ) !all_formats +- ) +- +-let list_formats () = +- assert !baked; +- +- List.map (fun { name = n } -> n) !all_formats +- +-let compare_formats { name = n1 } { name = n2 } = +- compare n1 n2 +- +-let check_formats_prerequisites ~formats = +- assert !baked; +- +- (* Run the formats in alphabetical, rather than random order. *) +- let formats = List.sort compare_formats (FormatSet.elements formats) in +- +- List.iter ( +- function +- | { check_prerequisites = Some fn } -> +- fn () +- | { check_prerequisites = None } -> () +- ) formats +- +-let check_formats_appliance_prerequisites ~formats g = +- assert !baked; +- +- (* Run the formats in alphabetical, rather than random order. *) +- let formats = List.sort compare_formats (FormatSet.elements formats) in +- +- List.iter ( +- function +- | { check_appliance_prerequisites = Some fn } -> +- fn g +- | { check_appliance_prerequisites = None } -> () +- ) formats +- +-let run_formats_on_filesystem ~formats g image_name tmpdir = +- assert !baked; +- +- (* Run the formats in alphabetical, rather than random order. *) +- let formats = List.sort compare_formats (FormatSet.elements formats) in +- +- List.iter ( +- function +- | { run_on_filesystem = Some fn; name; output_to_file } -> +- let filename = +- if output_to_file then output_filename image_name name +- else "" in +- fn g filename tmpdir +- | { run_on_filesystem = None } -> () +- ) formats +- +-let run_formats_on_file ~formats image_name tmpdisk tmpdir = +- assert !baked; +- +- (* Run the formats in alphabetical, rather than random order. *) +- let formats = List.sort compare_formats (FormatSet.elements formats) in +- +- List.iter ( +- function +- | { run_on_file = Some fn; name; output_to_file } -> +- let filename = +- if output_to_file then output_filename image_name name +- else "" in +- fn filename tmpdisk tmpdir +- | { run_on_file = None } -> () +- ) formats +- +-let get_filenames ~formats image_name = +- assert !baked; +- +- (* Run the formats in alphabetical, rather than random order. *) +- let formats = List.sort compare_formats (FormatSet.elements formats) in +- +- List.filter_map ( +- function +- | { output_to_file = true; name } -> +- Some (output_filename image_name name) +- | { output_to_file = false } -> +- None +- ) formats +diff --git a/dib/output_format.mli b/dib/output_format.mli +deleted file mode 100644 +index d545891b1..000000000 +--- a/dib/output_format.mli ++++ /dev/null +@@ -1,131 +0,0 @@ +-(* virt-dib +- * Copyright (C) 2012-2023 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. +- *) +- +-(** Handling of output formats. *) +- +-(** Structure used to describe output formats. *) +-type format = { +- name : string; +- (** The name of the format, which is exposed via the [--formats] +- command line parameter. Must contain only alphanumeric and +- '-' (dash) character. *) +- +- extra_args : extra_arg list; +- (** Extra command-line arguments, if any. eg. The [docker] +- format has an extra [--docker-target] parameter. +- +- For a description of each list element, see {!extra_arg} below. +- +- You can decide the types of the arguments, whether they are +- mandatory etc. *) +- +- output_to_file : bool; +- (** Whether the format writes to a file. Most of the formats +- produce a file as result, although some (e.g. docker) do +- not. *) +- +- check_prerequisites : (unit -> unit) option; +- (** The function which is called after the command line processing +- to check whether the requirements for this format (available +- tools, values for command line arguments, etc) are fulfilled. *) +- +- check_appliance_prerequisites : (Guestfs.guestfs -> unit) option; +- (** The function which is called after the appliance start to check +- whether the requirements in the appliance for this format +- (available features, filesystems, etc) are fulfilled. *) +- +- run_on_filesystem : (Guestfs.guestfs -> string -> string -> unit) option; +- (** The function which is called to perform the export while the +- guest is mounted. +- +- The parameters are: +- - [g]: the libguestfs handle +- - [filename]: the output filename for the format, or an empty +- string if {!output_to_file} is [false] +- - [tmpdir]: the temporary directory currently in use *) +- +- run_on_file : (string -> (string * string) -> string -> unit) option; +- (** The function which is called to perform the export using the +- temporary disk as reference. +- +- The parameters are: +- - [filename]: the output filename for the format, or an empty +- string if {!output_to_file} is [false] +- - [tmpdisk]: a tuple representing the temporary disk, as +- [(filename, format)] +- - [tmpdir]: the temporary directory currently in use *) +-} +- +-and extra_arg = { +- extra_argspec : Getopt.keys * Getopt.spec * Getopt.doc; +- (** The argspec. See [Getopt] module in [common/mltools]. *) +-} +- +-val defaults : format +-(** This is so formats can write [let op = { defaults with ... }]. *) +- +-val register_format : format -> unit +-(** Register a format. *) +- +-val bake : unit -> unit +-(** 'Bake' is called after all modules have been registered. We +- finalize the list of formats, sort it, and run some checks. *) +- +-val extra_args : unit -> Getopt.speclist +-(** Get the list of extra arguments for the command line. *) +- +-val list_formats : unit -> string list +-(** List supported formats. *) +- +-type set +-(** A (sub-)set of formats. *) +- +-val empty_set : set +-(** Empty set of formats. *) +- +-val add_to_set : string -> set -> set +-(** [add_to_set name set] adds the format named [name] to [set]. +- +- Note that this will raise [Not_found] if [name] is not +- a valid format name. *) +- +-val set_mem : string -> set -> bool +-(** Check whether the specified format is in the set. *) +- +-val set_cardinal : set -> int +-(** Return the size of the formats set. *) +- +-val check_formats_prerequisites : formats:set -> unit +-(** Check the prerequisites in all the formats listed in the [formats] set. *) +- +-val check_formats_appliance_prerequisites : formats:set -> Guestfs.guestfs -> unit +-(** Check the appliance prerequisites in all the formats listed in the +- [formats] set. *) +- +-val run_formats_on_filesystem : formats:set -> Guestfs.guestfs -> string -> string -> unit +-(** Run the filesystem-based export for all the formats listed in the +- [formats] set. *) +- +-val run_formats_on_file : formats:set -> string -> (string * string) -> string -> unit +-(** Run the disk-based export for all the formats listed in the +- [formats] set. *) +- +-val get_filenames : formats:set -> string -> string list +-(** Return the list of all the output filenames for formats in the +- [formats] set. Only formats with {!output_to_file} as [true] +- will be taken into account. *) +diff --git a/dib/output_format_docker.ml b/dib/output_format_docker.ml +deleted file mode 100644 +index 7f254ba96..000000000 +--- a/dib/output_format_docker.ml ++++ /dev/null +@@ -1,57 +0,0 @@ +-(* virt-dib +- * Copyright (C) 2016-2023 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 Tools_utils +-open Common_gettext.Gettext +-open Getopt.OptionName +- +-open Utils +-open Output_format +- +-let docker_target = ref None +-let set_docker_target arg = docker_target := Some arg +- +-let docker_check () = +- require_tool "docker"; +- if !docker_target = None then +- error (f_"docker: a target was not specified, use ‘--docker-target’") +- +-let docker_run_fs (g : Guestfs.guestfs) _ temp_dir = +- let docker_target = +- match !docker_target with +- | None -> assert false (* checked earlier *) +- | Some t -> t in +- message (f_"Importing the image to docker as ‘%s’") docker_target; +- let dockertmp = Filename.temp_file ~temp_dir "docker." ".tar" in +- g#tar_out ~excludes:[| "./sys/*"; "./proc/*" |] ~xattrs:true ~selinux:true +- "/" dockertmp; +- let cmd = [ "sudo"; "docker"; "import"; dockertmp; docker_target ] in +- if run_command cmd <> 0 then exit 1 +- +-let fmt = { +- defaults with +- name = "docker"; +- output_to_file = false; +- extra_args = [ +- { extra_argspec = [ L"docker-target" ], Getopt.String ("target", set_docker_target), s_"Repo and tag for docker"; }; +- ]; +- check_prerequisites = Some docker_check; +- run_on_filesystem = Some docker_run_fs; +-} +- +-let () = register_format fmt +diff --git a/dib/output_format_qcow2.ml b/dib/output_format_qcow2.ml +deleted file mode 100644 +index d12605620..000000000 +--- a/dib/output_format_qcow2.ml ++++ /dev/null +@@ -1,56 +0,0 @@ +-(* virt-dib +- * Copyright (C) 2015-2023 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 Std_utils +-open Tools_utils +-open Common_gettext.Gettext +-open Getopt.OptionName +- +-open Utils +-open Output_format +- +-let compressed = ref true +-let qemu_img_options = ref None +-let set_qemu_img_options arg = qemu_img_options := Some arg +- +-let qcow2_check () = +- require_tool "qemu-img" +- +-let qcow2_run_file filename (tmpdisk, tmpdiskfmt) _ = +- message (f_"Converting to qcow2"); +- let cmd = [ "qemu-img"; "convert" ] @ +- (if !compressed then [ "-c" ] else []) @ +- [ "-f"; tmpdiskfmt; tmpdisk; "-O"; "qcow2" ] @ +- (match !qemu_img_options with +- | None -> [] +- | Some opt -> [ "-o"; opt ]) @ +- [ qemu_input_filename filename ] in +- if run_command cmd <> 0 then exit 1 +- +-let fmt = { +- defaults with +- name = "qcow2"; +- extra_args = [ +- { extra_argspec = [ S 'u' ], Getopt.Clear compressed, s_"Do not compress the qcow2 image"; }; +- { extra_argspec = [ L"qemu-img-options" ], Getopt.String ("option", set_qemu_img_options), s_"Add qemu-img options"; }; +- ]; +- check_prerequisites = Some qcow2_check; +- run_on_file = Some qcow2_run_file; +-} +- +-let () = register_format fmt +diff --git a/dib/output_format_raw.ml b/dib/output_format_raw.ml +deleted file mode 100644 +index a36679894..000000000 +--- a/dib/output_format_raw.ml ++++ /dev/null +@@ -1,31 +0,0 @@ +-(* virt-dib +- * Copyright (C) 2015-2023 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 Output_format +- +-(* The raw format is currently handled on its own in virt-dib, +- * so this is merely to add the output format to the available +- * ones. This might change in the future, though. +- *) +- +-let fmt = { +- defaults with +- name = "raw"; +-} +- +-let () = register_format fmt +diff --git a/dib/output_format_squashfs.ml b/dib/output_format_squashfs.ml +deleted file mode 100644 +index d81589b09..000000000 +--- a/dib/output_format_squashfs.ml ++++ /dev/null +@@ -1,39 +0,0 @@ +-(* virt-dib +- * Copyright (C) 2017 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 Tools_utils +-open Common_gettext.Gettext +- +-open Output_format +- +-let squashfs_check (g : Guestfs.guestfs) = +- g#available [| "squashfs" |] +- +-let squashfs_run_fs (g : Guestfs.guestfs) filename _ = +- message (f_"Compressing the image as squashfs"); +- g#mksquashfs ~excludes:[| "sys/*"; "proc/*"; "dev/*" |] ~compress:"xz" +- "/" filename +- +-let fmt = { +- defaults with +- name = "squashfs"; +- check_appliance_prerequisites = Some squashfs_check; +- run_on_filesystem = Some squashfs_run_fs; +-} +- +-let () = register_format fmt +diff --git a/dib/output_format_tar.ml b/dib/output_format_tar.ml +deleted file mode 100644 +index 6f749f870..000000000 +--- a/dib/output_format_tar.ml ++++ /dev/null +@@ -1,35 +0,0 @@ +-(* virt-dib +- * Copyright (C) 2015-2023 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 Tools_utils +-open Common_gettext.Gettext +- +-open Output_format +- +-let tar_run_fs (g : Guestfs.guestfs) filename _ = +- message (f_"Compressing the image as tar"); +- g#tar_out ~excludes:[| "./sys/*"; "./proc/*" |] ~xattrs:true ~selinux:true +- "/" filename +- +-let fmt = { +- defaults with +- name = "tar"; +- run_on_filesystem = Some tar_run_fs; +-} +- +-let () = register_format fmt +diff --git a/dib/output_format_tgz.ml b/dib/output_format_tgz.ml +deleted file mode 100644 +index 447dfe6d9..000000000 +--- a/dib/output_format_tgz.ml ++++ /dev/null +@@ -1,35 +0,0 @@ +-(* virt-dib +- * Copyright (C) 2017 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 Tools_utils +-open Common_gettext.Gettext +- +-open Output_format +- +-let tgz_run_fs (g : Guestfs.guestfs) filename _ = +- message (f_"Compressing the image as tar.gz"); +- g#tar_out ~excludes:[| "./sys/*"; "./proc/*" |] ~xattrs:true ~selinux:true +- ~compress:"gzip" "/" filename +- +-let fmt = { +- defaults with +- name = "tgz"; +- run_on_filesystem = Some tgz_run_fs; +-} +- +-let () = register_format fmt +diff --git a/dib/output_format_vhd.ml b/dib/output_format_vhd.ml +deleted file mode 100644 +index 1d56947a6..000000000 +--- a/dib/output_format_vhd.ml ++++ /dev/null +@@ -1,47 +0,0 @@ +-(* virt-dib +- * Copyright (C) 2015-2023 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 Tools_utils +-open Common_gettext.Gettext +- +-open Utils +-open Output_format +- +-let vhd_check () = +- require_tool "vhd-util" +- +-let vhd_run_file filename (tmpdisk, _) temp_dir = +- message (f_"Converting to VHD"); +- let fn_intermediate = Filename.temp_file ~temp_dir "vhd-intermediate." "" in +- let cmd = [ "vhd-util"; "convert"; "-s"; "0"; "-t"; "1"; +- "-i"; tmpdisk; "-o"; fn_intermediate ] in +- if run_command cmd <> 0 then exit 1; +- let cmd = [ "vhd-util"; "convert"; "-s"; "1"; "-t"; "2"; +- "-i"; fn_intermediate; "-o"; filename ] in +- if run_command cmd <> 0 then exit 1; +- if not (Sys.file_exists filename) then +- error (f_"VHD output not produced, most probably vhd-util is old or not patched for ‘convert’") +- +-let fmt = { +- defaults with +- name = "vhd"; +- check_prerequisites = Some vhd_check; +- run_on_file = Some vhd_run_file; +-} +- +-let () = register_format fmt +diff --git a/dib/test-virt-dib-docs.sh b/dib/test-virt-dib-docs.sh +deleted file mode 100755 +index 2ce7223f3..000000000 +--- a/dib/test-virt-dib-docs.sh ++++ /dev/null +@@ -1,23 +0,0 @@ +-#!/bin/bash - +-# libguestfs +-# Copyright (C) 2016 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. +- +-set -e +- +-$TEST_FUNCTIONS +- +-$top_srcdir/podcheck.pl "$srcdir/virt-dib.pod" virt-dib +diff --git a/dib/utils.ml b/dib/utils.ml +deleted file mode 100644 +index 856705d09..000000000 +--- a/dib/utils.ml ++++ /dev/null +@@ -1,111 +0,0 @@ +-(* 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 Std_utils +-open Tools_utils +-open Common_gettext.Gettext +- +-open Printf +- +-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 Guestfs_config.host_cpu with +- | "amd64" | "x86_64" -> "amd64" +- | "i386" | "i486" | "i586" | "i686" -> "i386" +- | arch when String.is_prefix arch "armv" -> "armhf" +- | arch -> arch +- +-let output_filename image_name = function +- | "squashfs" -> image_name ^ ".squash" +- | 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.is_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 = +- try string_index_fn (fun x -> not (Char.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 get_required_tool tool = +- try which tool +- with Executable_not_found tool -> +- error (f_"%s needed but not found") tool +- +-let require_tool tool = +- ignore (get_required_tool tool) +- +-let do_cp src destdir = +- let cmd = [ "cp"; "-t"; destdir; "-a"; src ] in +- if run_command cmd <> 0 then exit 1 +- +-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) +diff --git a/dib/utils.mli b/dib/utils.mli +deleted file mode 100644 +index dbbf82113..000000000 +--- a/dib/utils.mli ++++ /dev/null +@@ -1,66 +0,0 @@ +-(* 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. +- *) +- +-val unit_GB : int -> int64 +-(** [unit_GB n] returns n * 2^30 *) +- +-val current_arch : unit -> string +-(** Turn the host_cpu into the dpkg architecture naming. *) +- +-val output_filename : string -> string -> string +-(** [output_filename image_name format] generates a suitable output +- filename based on the image filename and output format. *) +- +-val log_filename : unit -> string +-(** Generate a name for the log file containing the program name and +- current date/time. *) +- +-val var_from_lines : string -> string list -> string +-(** Find variable definition in a set of lines of the form [var=value]. *) +- +-val string_index_fn : (char -> bool) -> string -> int +-(** Apply function to each character in the string. If the function +- returns true, return the index of the character. +- +- In other words, like {!String.index} but using a function +- instead of a single character. +- +- @raise Not_found if no match *) +- +-val digit_prefix_compare : string -> string -> int +- +-val do_mkdir : string -> unit +-(** Wrapper around [mkdir -p -m 0755] *) +- +-val get_required_tool : string -> string +-(** Ensure external program is installed. Return the full path of the +- program or fail with an error message. *) +- +-val require_tool : string -> unit +-(** Same as {!get_required_tool} but only checks the external program +- is installed and does not return the path. *) +- +-val do_cp : string -> string -> unit +-(** Wrapper around [cp -a src destdir]. *) +- +-val ensure_trailing_newline : string -> string +-(** If the input string is not [""], ensure there is a trailing ['\n'], +- adding one if necessary. *) +- +-val not_in_list : 'a list -> 'a -> bool +-(** Opposite of {!List.mem}. *) +diff --git a/dib/virt-dib.pod b/dib/virt-dib.pod +deleted file mode 100644 +index c0119d278..000000000 +--- a/dib/virt-dib.pod ++++ /dev/null +@@ -1,727 +0,0 @@ +-=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 +-to build a new disk image, generate new ramdisks, etc. +- +-Virt-dib is intended as safe replacement for C +-and its C mode, see +-L for a quick comparison with +-usage of C. +- +-C is part of the TripleO OpenStack project: +-L. +- +-=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. +- +-=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. This is +-usually the F subdirectory in the sources and when installed, +-and F when installed in F. +- +-This parameter is B, 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> ARCHITECTURE +- +-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 +-environment variable for the elements, and it’s up to them to +-produce an image for the requested architecture. +- +-=item B<--checksum> +- +-Generate checksum files for the generated image. The supported +-checksums are MD5, and SHA256. +- +-=item B<--colors> +- +-=item B<--colours> +- +-Use ANSI colour sequences to colourize messages. This is the default +-when the output is a tty. If the output of the program is redirected +-to a file, ANSI colour sequences are disabled unless you use this +-option. +- +-=item B<--debug> LEVEL +- +-Set the debug level to C, 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, and any value +-E C<0> enables tracing in the scripts executed. +- +-=item B<--docker-target> TARGET +- +-Set the repository and tag for docker. +- +-This is used only when the formats include C, and it is +-required in that case. +- +-=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. +- +-=item B<--drive-format> raw +- +-=item B<--drive-format> qcow2 +- +-Specify the format of the helper drive. If this flag is not given +-then it is auto-detected from the drive itself. +- +-If working with untrusted raw-format guest disk images, you should +-ensure the format is always specified. +- +-This option is used only if I<--drive> is specified. +- +-See L. +- +-=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, 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 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 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. If it is not set, nothing +-is exported to the elements. +- +-=item B<--envvar> VARIABLE=VALUE +- +-Set the environment variable C with value C 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