builder: complete architecture handling

Add the possibility to choose which architecture use to build the wanted
image (--arch). Since this implies that running commands on the guest is
usually not possible when the architecture is different than the host
one, virt-builder will nevertheless try to check whether the host is
compatible with the guest, allowing to run commands only in that case.

The caching scheme is adapted to account for the architecture (with
--print-cache showing the architecture as well).

builder/Makefile.am

@@ -38,6 +38,7 @@ CLEANFILES = *~ *.cmi *.cmo *.cmx *.cmxa *.o virt-builder
 
 # Alphabetical order.
 SOURCES = \
+	architecture.ml \
 	builder.ml \
 	cmdline.ml \
 	downloader.mli \
@@ -63,7 +64,10 @@ SOURCES = \
 	sigchecker.mli \
 	sigchecker.ml \
 	sources.mli \
-	sources.ml
+	sources.ml \
+	uname.ml \
+	uname.mli \
+	uname-c.c
 
 man_MANS =
 noinst_DATA =
@@ -101,6 +105,9 @@ deps = \
 	pxzcat.cmx \
 	setlocale-c.o \
 	setlocale.cmx \
+	uname-c.o \
+	uname.cmx \
+	architecture.cmx \
 	ini_reader.cmx \
 	paths.cmx \
 	languages.cmx \

builder/architecture.ml

@@ -0,0 +1,41 @@
+(* virt-builder
+ * Copyright (C) 2014 Red Hat Inc.
+ *
+ * This program is free software; you can redistribute it and/or modify
+ * it under the terms of the GNU General Public License as published by
+ * the Free Software Foundation; either version 2 of the License, or
+ * (at your option) any later version.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License along
+ * with this program; if not, write to the Free Software Foundation, Inc.,
+ * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+ *)
+
+open Common_gettext.Gettext
+open Common_utils
+
+open Unix
+
+let filter_arch = function
+  | "amd64" | "x86_64" | "x64" -> "x86_64"
+  | "powerpc" | "ppc" -> "ppc"
+  | arch -> arch
+
+let arch_is_compatible nativearch otherarch =
+  let nativearch = filter_arch nativearch in
+  let otherarch = filter_arch otherarch in
+  match nativearch, otherarch with
+  | a, b when a = b -> true
+  | "x86_64", "i386" -> true
+  | "ppc64", "ppc" -> true
+  | "sparc64", "sparc" -> true
+  | a, b -> false
+
+let current_arch =
+  try filter_arch ((Uname.uname ()).Uname.machine)
+  with Unix_error _ -> "unknown"

builder/builder.ml

@@ -38,9 +38,9 @@ let () = Random.self_init ()
 let main () =
   (* Command line argument parsing - see cmdline.ml. *)
   let mode, arg,
-    attach, cache, check_signature, curl, debug, delete, delete_on_failure,
-    edit, firstboot, run, format, gpg, hostname, install, list_format, links,
-    memsize, mkdirs,
+    arch, attach, cache, check_signature, curl, debug, delete,
+    delete_on_failure, edit, firstboot, run, format, gpg, hostname, install,
+    list_format, links, memsize, mkdirs,
     network, output, password_crypto, quiet, root_password, scrub,
     scrub_logfile, selinux_relabel, size, smp, sources, sync, timezone,
     update, upload, writes =
@@ -172,11 +172,11 @@ let main () =
       | Some cachedir ->
         printf (f_"cache directory: %s\n") cachedir;
         List.iter (
-          fun (name, { Index_parser.revision = revision; hidden = hidden }) ->
+          fun (name, { Index_parser.revision = revision; arch = arch; hidden = hidden }) ->
             if not hidden then (
-              let filename = Downloader.cache_of_name cachedir name revision in
+              let filename = Downloader.cache_of_name cachedir name arch revision in
               let cached = Sys.file_exists filename in
-              printf "%-24s %s\n" name
+              printf "%-24s %-10s %s\n" name arch
                 (if cached then s_"cached" else (*s_*)"no")
             )
         ) index
@@ -193,7 +193,7 @@ let main () =
         List.iter (
           fun (name,
                { Index_parser.revision = revision; file_uri = file_uri }) ->
-            let template = name, revision in
+            let template = name, arch, revision in
             msg (f_"Downloading: %s") file_uri;
             let progress_bar = not quiet in
             ignore (Downloader.download ~prog downloader ~template ~progress_bar
@@ -205,12 +205,16 @@ let main () =
     | (`Install|`Notes) as mode -> mode in
 
   (* Which os-version (ie. index entry)? *)
-  let entry =
-    try List.assoc arg index
+  let item =
+    try List.find (
+      fun (name, { Index_parser.arch = a }) ->
+        name = arg && arch = Architecture.filter_arch a
+    ) index
     with Not_found ->
-      eprintf (f_"%s: cannot find os-version '%s'.\nUse --list to list available guest types.\n")
-        prog arg;
+      eprintf (f_"%s: cannot find os-version '%s' with architecture '%s'.\nUse --list to list available guest types.\n")
+        prog arg arch;
       exit 1 in
+  let entry = snd item in
   let sigchecker = entry.Index_parser.sigchecker in
 
   (match mode with
@@ -235,7 +239,7 @@ let main () =
   let template =
     let template, delete_on_exit =
       let { Index_parser.revision = revision; file_uri = file_uri } = entry in
-      let template = arg, revision in
+      let template = arg, arch, revision in
       msg (f_"Downloading: %s") file_uri;
       let progress_bar = not quiet in
       Downloader.download ~prog downloader ~template ~progress_bar file_uri in

builder/cmdline.ml

@@ -44,6 +44,8 @@ let parse_cmdline () =
   let print_cache_mode () = mode := `Print_cache in
   let delete_cache_mode () = mode := `Delete_cache in
 
+  let arch = ref "" in
+
   let attach = ref [] in
   let attach_format = ref None in
   let set_attach_format = function
@@ -221,6 +223,7 @@ let parse_cmdline () =
 
   let ditto = " -\"-" in
   let argspec = Arg.align [
+    "--arch",    Arg.Set_string arch,       "arch" ^ " " ^ s_"Set the output architecture";
     "--attach",  Arg.String attach_disk,    "iso" ^ " " ^ s_"Attach data disk/ISO during install";
     "--attach-format",  Arg.String set_attach_format,
                                             "format" ^ " " ^ s_"Set attach disk format";
@@ -319,6 +322,7 @@ read the man page virt-builder(1).
   (* Dereference options. *)
   let args = List.rev !args in
   let mode = !mode in
+  let arch = !arch in
   let attach = List.rev !attach in
   let cache = !cache in
   let check_signature = !check_signature in
@@ -431,10 +435,25 @@ read the man page virt-builder(1).
     (* Combine the sources and fingerprints into a single list of pairs. *)
     List.combine sources fingerprints in
 
+  (* Check the architecture. *)
+  let arch =
+    match arch with
+    | "" -> Architecture.current_arch
+    | arch ->
+      let target_arch = Architecture.filter_arch arch in
+      if Architecture.arch_is_compatible Architecture.current_arch target_arch <> true then (
+        if install <> [] || run <> [] || update then (
+          eprintf (f_"%s: sorry, cannot run commands on a guest with a different architecture\n")
+            prog;
+          exit 1
+        );
+      );
+      target_arch in
+
   mode, arg,
-  attach, cache, check_signature, curl, debug, delete, delete_on_failure,
-  edit, firstboot, run, format, gpg, hostname, install, list_format, links,
-  memsize, mkdirs,
+  arch, attach, cache, check_signature, curl, debug, delete,
+  delete_on_failure, edit, firstboot, run, format, gpg, hostname, install,
+  list_format, links, memsize, mkdirs,
   network, output, password_crypto, quiet, root_password, scrub,
   scrub_logfile, selinux_relabel, size, smp, sources, sync, timezone,
   update, upload, writes

builder/downloader.ml

@@ -25,8 +25,8 @@ open Printf
 let quote = Filename.quote
 let (//) = Filename.concat
 
-let cache_of_name cachedir name revision =
-  cachedir // sprintf "%s.%d" name revision
+let cache_of_name cachedir name arch revision =
+  cachedir // sprintf "%s.%s.%d" name arch revision
 
 type uri = string
 type filename = string
@@ -51,14 +51,14 @@ let rec download ~prog t ?template ?progress_bar uri =
     download_to ~prog t ?progress_bar uri tmpfile;
     (tmpfile, true)
 
-  | Some (name, revision) ->
+  | Some (name, arch, revision) ->
     match t.cache with
     | None ->
       (* Not using the cache at all? *)
       download t ~prog ?progress_bar uri
 
     | Some cachedir ->
-      let filename = cache_of_name cachedir name revision in
+      let filename = cache_of_name cachedir name arch revision in
 
       (* Is the requested template name + revision in the cache already?
        * If not, download it.

builder/downloader.mli

@@ -18,7 +18,7 @@
 
 (** This module is a wrapper around curl, plus local caching. *)
 
-val cache_of_name : string -> string -> int -> string
+val cache_of_name : string -> string -> string -> int -> string
 (** [cache_of_name cachedir name revision] returns the filename
     of the cached file.  (Note: It doesn't check if the filename
     exists, this is just a simple string transformation). *)
@@ -32,15 +32,15 @@ type t
 val create : debug:bool -> curl:string -> cache:string option -> t
 (** Create the abstract type. *)
 
-val download : prog:string -> t -> ?template:(string*int) -> ?progress_bar:bool -> uri -> (filename * bool)
+val download : prog:string -> t -> ?template:(string*string*int) -> ?progress_bar:bool -> uri -> (filename * bool)
 (** Download the URI, returning the downloaded filename and a
     temporary file flag.  The temporary file flag is [true] iff
     the downloaded file is temporary and should be deleted by the
     caller (otherwise it's in the cache and you shouldn't delete it).
 
-    For templates, you must supply [~template:(name, revision)].  This
-    causes the cache to be used (if possible).  Name and revision are
-    used for cache control (see the man page for details).
+    For templates, you must supply [~template:(name, arch, revision)].
+    This causes the cache to be used (if possible).  Name, arch(itecture)
+    and revision are used for cache control (see the man page for details).
 
     If [~progress_bar:true] then display a progress bar if the file
     doesn't come from the cache.  In debug mode, progress messages

builder/index_parser.ml

@@ -123,16 +123,26 @@ let get_index ~prog ~debug ~downloader ~sigchecker source =
     if delete_tmpfile then
       (try Unix.unlink tmpfile with _ -> ());
 
-    (* Check for repeated os-version names. *)
+    (* Check for repeated os-version+arch combination. *)
+    let name_arch_map = List.map (
+      fun (n, fields) ->
+        let rec find_arch = function
+          | ("arch", None, value) :: y -> value
+          | _ :: y -> find_arch y
+          | [] -> ""
+        in
+        n, (find_arch fields)
+    ) sections in
     let nseen = Hashtbl.create 13 in
     List.iter (
-      fun (n, _) ->
-        if Hashtbl.mem nseen n then (
-          eprintf (f_"virt-builder: index is corrupt: os-version '%s' appears two or more times\n") n;
+      fun (n, arch) ->
+        let id = n, arch in
+        if Hashtbl.mem nseen id then (
+          eprintf (f_"virt-builder: index is corrupt: os-version '%s' with architecture '%s' appears two or more times\n") n arch;
           corrupt_file ()
         );
-        Hashtbl.add nseen n true
-    ) sections;
+        Hashtbl.add nseen id true
+    ) name_arch_map;
 
     (* Check for repeated fields. *)
     List.iter (

builder/test-virt-builder.sh

@@ -52,6 +52,7 @@ rm -f $output
 $VG ./virt-builder phony-fedora \
     -v --no-cache --no-check-signature $no_network \
     -o $output --size 2G --format $format \
+    --arch x86_64 \
     --hostname test.example.com \
     --timezone Europe/London \
     --root-password password:123456 \

builder/uname-c.c

@@ -0,0 +1,55 @@
+/* virt-builder
+ * Copyright (C) 2014 Red Hat Inc.
+ *
+ * This program is free software; you can redistribute it and/or modify
+ * it under the terms of the GNU General Public License as published by
+ * the Free Software Foundation; either version 2 of the License, or
+ * (at your option) any later version.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with this program; if not, write to the Free Software
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+ */
+
+#include <config.h>
+
+#include <errno.h>
+#include <sys/utsname.h>
+
+#include <caml/alloc.h>
+#include <caml/fail.h>
+#include <caml/memory.h>
+#include <caml/mlvalues.h>
+
+#ifdef HAVE_CAML_UNIXSUPPORT_H
+#include <caml/unixsupport.h>
+#else
+#define Nothing ((value) 0)
+extern void unix_error (int errcode, char * cmdname, value arg) Noreturn;
+#endif
+
+value
+virt_builder_uname (value unit)
+{
+  CAMLparam0 ();
+  CAMLlocal1 (rv);
+  struct utsname u;
+
+  if (uname (&u) < 0)
+    unix_error (errno, (char *) "uname", Val_int (0));
+
+  rv = caml_alloc (5, 0);
+
+  Store_field (rv, 0, caml_copy_string (u.sysname));
+  Store_field (rv, 1, caml_copy_string (u.nodename));
+  Store_field (rv, 2, caml_copy_string (u.release));
+  Store_field (rv, 3, caml_copy_string (u.version));
+  Store_field (rv, 4, caml_copy_string (u.machine));
+
+  CAMLreturn (rv);
+}

builder/uname.ml

@@ -0,0 +1,27 @@
+(* virt-builder
+ * Copyright (C) 2014 Red Hat Inc.
+ *
+ * This program is free software; you can redistribute it and/or modify
+ * it under the terms of the GNU General Public License as published by
+ * the Free Software Foundation; either version 2 of the License, or
+ * (at your option) any later version.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License along
+ * with this program; if not, write to the Free Software Foundation, Inc.,
+ * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+ *)
+
+type uname_struct = {
+  sysname : string;
+  nodename : string;
+  release : string;
+  version : string;
+  machine : string;
+}
+
+external uname : unit -> uname_struct = "virt_builder_uname"

builder/uname.mli

@@ -0,0 +1,28 @@
+(* virt-builder
+ * Copyright (C) 2014 Red Hat Inc.
+ *
+ * This program is free software; you can redistribute it and/or modify
+ * it under the terms of the GNU General Public License as published by
+ * the Free Software Foundation; either version 2 of the License, or
+ * (at your option) any later version.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License along
+ * with this program; if not, write to the Free Software Foundation, Inc.,
+ * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+ *)
+
+type uname_struct = {
+  sysname : string;
+  nodename : string;
+  release : string;
+  version : string;
+  machine : string;
+}
+
+val uname : unit -> uname_struct
+(** [uname] Tiny wrapper to the C [uname]. *)

builder/virt-builder.pod

@@ -15,6 +15,7 @@ virt-builder - Build virtual machine images quickly
 
  virt-builder os-version
     [-o|--output DISKIMAGE] [--size SIZE] [--format raw|qcow2]
+    [--arch ARCHITECTURE]
     [--attach ISOFILE]
     [--root-password SELECTOR]
     [--hostname HOSTNAME]
@@ -81,7 +82,9 @@ are any installation notes:
 
  virt-builder fedora-20
 
-will build a Fedora 20 image.  This will have all default
+will build a Fedora 20 image for the same architecture as virt-builder
+(so running it from an i386 installation will try to build an i386
+image, if available).  This will have all default
 configuration (minimal size, no user accounts, random root password,
 only the bare minimum installed software, etc.).
 
@@ -109,6 +112,10 @@ As above, but the output size will be 20 GB.  The guest OS is resized
 as it is copied to the output (automatically, using
 L<virt-resize(1)>).
 
+ virt-builder fedora-20 --arch i386
+
+As above, but using an i386 template, if available.
+
 =head2 Setting the root password
 
  virt-builder fedora-20 --root-password file:/tmp/rootpw
@@ -189,6 +196,14 @@ You can combine these options, and have multiple options of all types.
 
 Display help.
 
+=item B<--arch> ARCHITECTURE
+
+Use the specified architecture for the output image.  This means
+there must be sources providing the requested template for the
+requested architecture.
+
+See also L</ARCHITECTURE>.
+
 =item B<--attach> ISOFILE
 
 During the customization phase, the given disk is attached to the
@@ -1635,7 +1650,7 @@ highly recommended that you always create signed index and templates.
 Virt-builder can build a guest for any architecture no matter what the
 host architecture is.  For example an x86-64 guest on an ARM host.
 
-However certain options may not work correctly, specifically options
+However certain options may not work, specifically options
 that require running commands in the guest during the build process:
 I<--install>, I<--update>, I<--run>, I<--run-command>.  You may need
 to replace these with their firstboot-equivalents.

po/POTFILES

@@ -6,6 +6,7 @@ builder/index-struct.c
 builder/index-validate.c
 builder/pxzcat-c.c
 builder/setlocale-c.c
+builder/uname-c.c
 cat/cat.c
 cat/filesystems.c
 cat/ls.c

po/POTFILES-ml

@@ -1,3 +1,4 @@
+builder/architecture.ml
 builder/builder.ml
 builder/cmdline.ml
 builder/downloader.ml
@@ -11,6 +12,7 @@ builder/pxzcat.ml
 builder/setlocale.ml
 builder/sigchecker.ml
 builder/sources.ml
+builder/uname.ml
 mllib/common_gettext.ml
 mllib/common_utils.ml
 mllib/common_utils_tests.ml