Libguestfs - Nov 2017 - [PATCH v12 2/3] builder: add a template parameter to get_index

Hi there!

Here is the latest version of the series including Richard's comments.
I also reworked the repository_main.ml code to avoid setting an
empty entry if not found.

Cédric Bosdonnat (3):
  builder: change arch type to distinguish guesses
  builder: add a template parameter to get_index
  New tool: virt-builder-repository

 .gitignore                              |   4 +
 builder/Makefile.am                     |  87 ++++-
 builder/builder.ml                      |   8 +-
 builder/cache.ml                        |   8 +
 builder/cache.mli                       |   6 +-
 builder/downloader.mli                  |   2 +-
 builder/index.ml                        |  10 +-
 builder/index.mli                       |   5 +-
 builder/index_parser.ml                 |  50 ++-
 builder/index_parser.mli                |   5 +-
 builder/list_entries.ml                 |  13 +-
 builder/repository_main.ml              | 621 ++++++++++++++++++++++++++++++++
 builder/simplestreams_parser.ml         |   2 +-
 builder/test-docs.sh                    |   2 +
 builder/test-virt-builder-repository.sh |  98 +++++
 builder/utils.ml                        |   4 +
 builder/utils.mli                       |   3 +
 builder/virt-builder-repository.pod     | 213 +++++++++++
 builder/virt-builder.pod                |   4 +
 fish/guestfish.pod                      |   1 +
 installcheck.sh.in                      |   1 +
 lib/guestfs.pod                         |   1 +
 22 files changed, 1121 insertions(+), 27 deletions(-)
 create mode 100644 builder/repository_main.ml
 create mode 100755 builder/test-virt-builder-repository.sh
 create mode 100644 builder/virt-builder-repository.pod

-- 
2.14.3

Change Index.arch to the type (Arch of string | GuessedArch of string).

In a future commit, the index parser will allow arch not to be set
for some cases. Thus arch value will be guessed by inspecting the
image. However we need to distinguish between a set value and a guessed
one. Using this new type will help it:

    match arch with
    | Arch s        -> (* This is a set value *)
    | GuessedArch s -> (* This is a guessed value *)
---
 builder/builder.ml              |  8 +++++---
 builder/cache.ml                |  8 ++++++++
 builder/cache.mli               |  6 +++---
 builder/downloader.mli          |  2 +-
 builder/index.ml                | 10 ++++++++--
 builder/index.mli               |  5 ++++-
 builder/index_parser.ml         |  6 ++++--
 builder/list_entries.ml         | 13 ++++++++++---
 builder/simplestreams_parser.ml |  2 +-
 9 files changed, 44 insertions(+), 16 deletions(-)

diff --git a/builder/builder.ml b/builder/builder.ml
index 3f7c79bc9..8a950cd8f 100644
--- a/builder/builder.ml
+++ b/builder/builder.ml
@@ -94,7 +94,9 @@ let selected_cli_item cmdline index    let item      try
List.find (
       fun (name, { Index.arch = a }) ->
-        name = arg && cmdline.arch = normalize_arch a
+        match a with
+        | Index.Arch a
+        | Index.GuessedArch a -> name = arg && cmdline.arch =
normalize_arch a
     ) index
     with Not_found ->
       error (f_"cannot find os-version ‘%s’ with architecture ‘%s’.\nUse
--list to list available guest types.")
@@ -252,7 +254,7 @@ let main ()          List.iter (
           fun (name,
                { Index.revision; file_uri; proxy }) ->
-            let template = name, cmdline.arch, revision in
+            let template = name, (Index.Arch cmdline.arch), revision in
             message (f_"Downloading: %s") file_uri;
             let progress_bar = not (quiet ()) in
             ignore (Downloader.download downloader ~template ~progress_bar
@@ -300,7 +302,7 @@ let main ()    let template      let template,
delete_on_exit        let { Index.revision; file_uri; proxy } = entry in
-      let template = arg, cmdline.arch, revision in
+      let template = arg, (Index.Arch cmdline.arch), revision in
       message (f_"Downloading: %s") file_uri;
       let progress_bar = not (quiet ()) in
       Downloader.download downloader ~template ~progress_bar ~proxy
diff --git a/builder/cache.ml b/builder/cache.ml
index dbd222fda..e313a8bcf 100644
--- a/builder/cache.ml
+++ b/builder/cache.ml
@@ -41,6 +41,10 @@ let create ~directory    }
 
 let cache_of_name t name arch revision +  let arch +    match arch with
+    | Index.Arch arch
+    | Index.GuessedArch arch -> arch in
   t.directory // sprintf "%s.%s.%s" name arch (string_of_revision
revision)
 
 let is_cached t name arch revision @@ -54,6 +58,10 @@ let print_item_status t
~header l    List.iter (
     fun (name, arch, revision) ->
       let cached = is_cached t name arch revision in
+      let arch +        match arch with
+        | Index.Arch arch
+        | Index.GuessedArch arch -> arch in
       printf "%-24s %-10s %s\n" name arch
         (if cached then s_"cached" else (*s_*)"no")
   ) l
diff --git a/builder/cache.mli b/builder/cache.mli
index f27fc235b..f88cbdf2f 100644
--- a/builder/cache.mli
+++ b/builder/cache.mli
@@ -27,16 +27,16 @@ type t
 val create : directory:string -> t
 (** Create the abstract type. *)
 
-val cache_of_name : t -> string -> string -> Utils.revision ->
string
+val cache_of_name : t -> string -> Index.arch -> Utils.revision ->
string
 (** [cache_of_name t name arch revision] return the filename
     of the cached file.  (Note: It doesn't check if the filename
     exists, this is just a simple string transformation). *)
 
-val is_cached : t -> string -> string -> Utils.revision -> bool
+val is_cached : t -> string -> Index.arch -> Utils.revision -> bool
 (** [is_cached t name arch revision] return whether the file with
     specified name, architecture and revision is cached. *)
 
-val print_item_status : t -> header:bool -> (string * string *
Utils.revision) list -> unit
+val print_item_status : t -> header:bool -> (string * Index.arch *
Utils.revision) list -> unit
 (** [print_item_status t header items] print the status in the cache
     of the specified items (which are tuples of name, architecture,
     and revision).
diff --git a/builder/downloader.mli b/builder/downloader.mli
index 7f39f7e36..e2dd49f27 100644
--- a/builder/downloader.mli
+++ b/builder/downloader.mli
@@ -27,7 +27,7 @@ type t
 val create : curl:string -> tmpdir:string -> cache:Cache.t option -> t
 (** Create the abstract type. *)
 
-val download : t -> ?template:(string*string*Utils.revision) ->
?progress_bar:bool -> ?proxy:Curl.proxy -> uri -> (filename * bool)
+val download : t -> ?template:(string*Index.arch*Utils.revision) ->
?progress_bar:bool -> ?proxy:Curl.proxy -> 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
diff --git a/builder/index.ml b/builder/index.ml
index 84f66c265..5bc11b6f7 100644
--- a/builder/index.ml
+++ b/builder/index.ml
@@ -25,12 +25,13 @@ open Utils
 open Printf
 open Unix
 
+
 type index = (string * entry) list      (* string = "os-version" *)
 and entry = {
   printable_name : string option;       (* the name= field *)
   osinfo : string option;
   file_uri : string;
-  arch : string;
+  arch : arch;
   signature_uri : string option;        (* deprecated, will be removed in 1.26
*)
   checksums : Checksums.csum_t list option;
   revision : Utils.revision;
@@ -46,6 +47,9 @@ and entry = {
   sigchecker : Sigchecker.t;
   proxy : Curl.proxy;
 }
+and arch +  | Arch of string
+  | GuessedArch of string
 
 let print_entry chan (name, { printable_name; file_uri; arch; osinfo;
                               signature_uri; checksums; revision; format;
@@ -56,7 +60,9 @@ let print_entry chan (name, { printable_name; file_uri; arch;
osinfo;
   Option.may (fp "name=%s\n") printable_name;
   Option.may (fp "osinfo=%s\n") osinfo;
   fp "file=%s\n" file_uri;
-  fp "arch=%s\n" arch;
+  match arch with
+  | Arch arch
+  | GuessedArch arch -> fp "arch=%s\n" arch;
   Option.may (fp "sig=%s\n") signature_uri;
   Option.may (
     List.iter (
diff --git a/builder/index.mli b/builder/index.mli
index 6202d636e..26413da10 100644
--- a/builder/index.mli
+++ b/builder/index.mli
@@ -21,7 +21,7 @@ and entry = {
   printable_name : string option;       (* the name= field *)
   osinfo : string option;
   file_uri : string;
-  arch : string;
+  arch : arch;
   signature_uri : string option;        (* deprecated, will be removed in 1.26
*)
   checksums : Checksums.csum_t list option;
   revision : Utils.revision;
@@ -37,6 +37,9 @@ and entry = {
   sigchecker : Sigchecker.t;
   proxy : Curl.proxy;
 }
+and arch +  | Arch of string
+  | GuessedArch of string
 
 val print_entry : out_channel -> (string * entry) -> unit
 (** Debugging helper function dumping an index entry to a stream.
diff --git a/builder/index_parser.ml b/builder/index_parser.ml
index f76aed65d..a4d1e466e 100644
--- a/builder/index_parser.ml
+++ b/builder/index_parser.ml
@@ -97,7 +97,7 @@ let get_index ~downloader ~sigchecker { Sources.uri; proxy }  
eprintf (f_"%s: no ‘file’ (URI) entry for ‘%s’\n") prog n;
             corrupt_file () in
           let arch -            try List.assoc ("arch", None) fields
+            try Index.Arch (List.assoc ("arch", None) fields)
             with Not_found ->
               eprintf (f_"%s: no ‘arch’ entry for ‘%s’\n") prog n;
             corrupt_file () in
@@ -236,7 +236,9 @@ let write_entry chan (name, { Index.printable_name;
file_uri; arch; osinfo;
   Option.may (fp "name=%s\n") printable_name;
   Option.may (fp "osinfo=%s\n") osinfo;
   fp "file=%s\n" file_uri;
-  fp "arch=%s\n" arch;
+  match arch with
+  | Index.Arch arch
+  | Index.GuessedArch arch -> fp "arch=%s\n" arch;
   Option.may (fp "sig=%s\n") signature_uri;
   (match checksums with
   | None -> ()
diff --git a/builder/list_entries.ml b/builder/list_entries.ml
index af1d2419b..c0b7e48dd 100644
--- a/builder/list_entries.ml
+++ b/builder/list_entries.ml
@@ -46,7 +46,9 @@ and list_entries_short index      fun (name, {
Index.printable_name; arch; hidden }) ->
       if not hidden then (
         printf "%-24s" name;
-        printf " %-10s" arch;
+        match arch with
+        | Index.Arch arch
+        | Index.GuessedArch arch -> printf " %-10s" arch;
         Option.may (printf " %s") printable_name;
         printf "\n"
       )
@@ -74,7 +76,9 @@ and list_entries_long ~sources index        if not hidden then
(
         printf "%-24s %s\n" "os-version:" name;
         Option.may (printf "%-24s %s\n" (s_"Full name:"))
printable_name;
-        printf "%-24s %s\n" (s_"Architecture:") arch;
+        match arch with
+        | Index.Arch arch
+        | Index.GuessedArch arch -> printf "%-24s %s\n"
(s_"Architecture:") arch;
         printf "%-24s %s\n" (s_"Minimum/default size:")
(human_size size);
         Option.may (fun size ->
             printf "%-24s %s\n" (s_"Download size:")
(human_size size)
@@ -116,7 +120,10 @@ and list_entries_json ~sources index            match
printable_name with
           | None -> item
           | Some str -> ("full-name", JSON.String str) :: item in
-        let item = ("arch", JSON.String arch) :: item in
+        let item +          match arch with
+          | Index.Arch arch
+          | Index.GuessedArch arch -> ("arch", JSON.String arch)
:: item in
         let item = ("size", JSON.Int64 size) :: item in
         let item            match compressed_size with
diff --git a/builder/simplestreams_parser.ml b/builder/simplestreams_parser.ml
index 75592e377..996c334f5 100644
--- a/builder/simplestreams_parser.ml
+++ b/builder/simplestreams_parser.ml
@@ -83,7 +83,7 @@ let get_index ~downloader ~sigchecker { Sources.uri; proxy }  
let products = Array.to_list products_node in
     filter_map (
       fun (prod, prod_desc) ->
-        let arch = object_get_string "arch" prod_desc in
+        let arch = Index.Arch (object_get_string "arch" prod_desc) in
         let prods = Array.to_list (object_get_object "versions"
prod_desc) in
         let prods = filter_map (
           fun (rel, rel_desc) ->
-- 
2.14.3

get_index now gets a new template parameter. Setting it to true will
make the index parsing less picky about missing important data. This
can be used to parse a partial index file.
---
 builder/index_parser.ml  | 44 ++++++++++++++++++++++++++++++++++++--------
 builder/index_parser.mli |  5 ++++-
 2 files changed, 40 insertions(+), 9 deletions(-)

diff --git a/builder/index_parser.ml b/builder/index_parser.ml
index a4d1e466e..bf1c6a557 100644
--- a/builder/index_parser.ml
+++ b/builder/index_parser.ml
@@ -25,7 +25,7 @@ open Utils
 open Printf
 open Unix
 
-let get_index ~downloader ~sigchecker { Sources.uri; proxy } +let get_index
~downloader ~sigchecker ?(template = false) { Sources.uri; proxy }    let
corrupt_file ()      error (f_"The index file downloaded from ‘%s’ is
corrupt.\nYou need to ask the supplier of this file to fix it and upload a fixed
version.") uri
   in
@@ -99,8 +99,23 @@ let get_index ~downloader ~sigchecker { Sources.uri; proxy } 
let arch              try Index.Arch (List.assoc ("arch", None)
fields)
             with Not_found ->
-              eprintf (f_"%s: no ‘arch’ entry for ‘%s’\n") prog n;
-            corrupt_file () in
+              if template then
+                let g = new Guestfs.guestfs () in
+                g#add_drive_ro file_uri;
+                g#launch ();
+                let roots = g#inspect_os () in
+                let nroots = Array.length roots in
+                if nroots <> 1 then (
+                  eprintf (f_"%s: no ‘arch’ entry for %s and failed to
guess it\n") prog n;
+                  corrupt_file ()
+                );
+                let inspected_arch = g#inspect_get_arch (Array.get roots 0) in
+                g#close();
+                Index.GuessedArch inspected_arch
+              else (
+                eprintf (f_"%s: no ‘arch’ entry for ‘%s’\n") prog n;
+                corrupt_file ()
+              ) in
           let signature_uri              try Some (make_absolute_uri
(List.assoc ("sig", None) fields))
             with Not_found -> None in
@@ -112,21 +127,34 @@ let get_index ~downloader ~sigchecker { Sources.uri; proxy
}            let revision              try Rev_int (int_of_string (List.assoc
("revision", None) fields))
             with
-            | Not_found -> Rev_int 1
+            | Not_found -> if template then Rev_int 0 else Rev_int 1
             | Failure _ ->
               eprintf (f_"%s: cannot parse ‘revision’ field for
‘%s’\n") prog n;
               corrupt_file () in
           let format              try Some (List.assoc ("format",
None) fields) with Not_found -> None in
           let size +            let get_image_size filepath +              (*
If a compressed image manages to reach this code, qemu-img just
+                 returns a virtual-size equal to actual-size *)
+              let infos = Utils.get_image_infos filepath in
+              Yajl.object_get_number "virtual-size" infos in
             try Int64.of_string (List.assoc ("size", None) fields)
             with
             | Not_found ->
-              eprintf (f_"%s: no ‘size’ field for ‘%s’\n") prog n;
-              corrupt_file ()
+              if template then
+                get_image_size file_uri
+              else (
+                eprintf (f_"%s: no ‘size’ field for ‘%s’\n") prog n;
+                corrupt_file ()
+              )
             | Failure _ ->
-              eprintf (f_"%s: cannot parse ‘size’ field for ‘%s’\n")
prog n;
-              corrupt_file () in
+              if template then
+                get_image_size file_uri
+              else (
+                eprintf (f_"%s: cannot parse ‘size’ field for
‘%s’\n") prog n;
+                corrupt_file ()
+              ) in
           let compressed_size              try Some (Int64.of_string
(List.assoc ("compressed_size", None) fields))
             with
diff --git a/builder/index_parser.mli b/builder/index_parser.mli
index f77ae9376..dc6b0b407 100644
--- a/builder/index_parser.mli
+++ b/builder/index_parser.mli
@@ -16,7 +16,10 @@
  * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
  *)
 
-val get_index : downloader:Downloader.t -> sigchecker:Sigchecker.t ->
Sources.source -> Index.index
+val get_index : downloader:Downloader.t -> sigchecker:Sigchecker.t ->
?template:bool -> Sources.source -> Index.index
+(** [get_index download sigchecker template source] will parse the source
+    index file into an index entry list. If the template flag is set to
+    true, the parser will be less picky about missing values. *)
 
 val write_entry : out_channel -> (string * Index.entry) -> unit
 (** [write_entry chan entry] writes the index entry to the chan output
-- 
2.14.3

virt-builder-repository allows users to easily create or update
a virt-builder source repository out of disk images. The tool can
be run in either interactive or automated mode.
---
 .gitignore                              |   4 +
 builder/Makefile.am                     |  87 ++++-
 builder/repository_main.ml              | 621 ++++++++++++++++++++++++++++++++
 builder/test-docs.sh                    |   2 +
 builder/test-virt-builder-repository.sh |  98 +++++
 builder/utils.ml                        |   4 +
 builder/utils.mli                       |   3 +
 builder/virt-builder-repository.pod     | 213 +++++++++++
 builder/virt-builder.pod                |   4 +
 fish/guestfish.pod                      |   1 +
 installcheck.sh.in                      |   1 +
 lib/guestfs.pod                         |   1 +
 12 files changed, 1037 insertions(+), 2 deletions(-)
 create mode 100644 builder/repository_main.ml
 create mode 100755 builder/test-virt-builder-repository.sh
 create mode 100644 builder/virt-builder-repository.pod

diff --git a/.gitignore b/.gitignore
index f3569aa73..e54ea2d45 100644
--- a/.gitignore
+++ b/.gitignore
@@ -98,14 +98,18 @@ Makefile.in
 /builder/oUnit-*
 /builder/*.out
 /builder/*.qcow2
+/builder/repository-testdata
 /builder/stamp-virt-builder.pod
+/builder/stamp-virt-builder-repository.pod
 /builder/stamp-virt-index-validate.pod
 /builder/test-config/virt-builder/repos.d/test-index.conf
 /builder/test-console-*.sh
 /builder/test-simplestreams/virt-builder/repos.d/cirros.conf
 /builder/test-website/virt-builder/repos.d/libguestfs.conf
 /builder/virt-builder
+/builder/virt-builder-repository
 /builder/virt-builder.1
+/builder/virt-builder-repository.1
 /builder/virt-index-validate
 /builder/virt-index-validate.1
 /builder/*.xz
diff --git a/builder/Makefile.am b/builder/Makefile.am
index 757af75c7..e132335f5 100644
--- a/builder/Makefile.am
+++ b/builder/Makefile.am
@@ -21,6 +21,8 @@ AM_YFLAGS = -d
 
 EXTRA_DIST = \
 	$(SOURCES_MLI) $(SOURCES_ML) $(SOURCES_C) \
+	$(REPOSITORY_SOURCES_ML) \
+	$(REPOSITORY_SOURCES_MLI) \
 	index_parser_tests.ml \
 	libguestfs.gpg \
 	opensuse.gpg \
@@ -33,6 +35,7 @@ EXTRA_DIST = \
 	test-virt-builder-list.sh \
 	test-virt-builder-list-simplestreams.sh \
 	test-virt-builder-planner.sh \
+	test-virt-builder-repository.sh \
 	test-virt-index-validate.sh \
 	test-virt-index-validate-bad-1 \
 	test-virt-index-validate-good-1 \
@@ -40,6 +43,7 @@ EXTRA_DIST = \
 	test-virt-index-validate-good-3 \
 	test-virt-index-validate-good-4 \
 	virt-builder.pod \
+	virt-builder-repository.pod \
 	virt-index-validate.pod \
 	yajl_tests.ml
 
@@ -90,13 +94,45 @@ SOURCES_C = \
 	setlocale-c.c \
 	yajl-c.c
 
+REPOSITORY_SOURCES_ML = \
+	yajl.ml \
+	utils.ml \
+	index.ml \
+	cache.ml \
+	downloader.ml \
+	sigchecker.ml \
+	ini_reader.ml \
+	index_parser.ml \
+	paths.ml \
+	sources.ml \
+	osinfo_config.ml \
+	osinfo.ml \
+	repository_main.ml
+
+REPOSITORY_SOURCES_MLI = \
+	cache.mli \
+	downloader.mli \
+	index.mli \
+	index_parser.mli \
+	ini_reader.mli \
+	sigchecker.mli \
+	sources.mli \
+	yajl.mli
+
+REPOSITORY_SOURCES_C = \
+	index-scan.c \
+	index-struct.c \
+	index-parse.c \
+	index-parser-c.c \
+	yajl-c.c
+
 man_MANS  noinst_DATA  bin_PROGRAMS  
 if HAVE_OCAML
 
-bin_PROGRAMS += virt-builder
+bin_PROGRAMS += virt-builder virt-builder-repository
 
 virt_builder_SOURCES = $(SOURCES_C)
 virt_builder_CPPFLAGS = \
@@ -119,12 +155,31 @@ virt_builder_CFLAGS = \
 BOBJECTS = $(SOURCES_ML:.ml=.cmo)
 XOBJECTS = $(BOBJECTS:.cmo=.cmx)
 
+virt_builder_repository_SOURCES = $(REPOSITORY_SOURCES_C)
+virt_builder_repository_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)/lib
+virt_builder_repository_CFLAGS = \
+	-pthread \
+	$(WARN_CFLAGS) $(WERROR_CFLAGS) \
+	-Wno-unused-macros \
+	$(LIBTINFO_CFLAGS) \
+	$(LIBXML2_CFLAGS) \
+	$(YAJL_CFLAGS)
+REPOSITORY_BOBJECTS = $(REPOSITORY_SOURCES_ML:.ml=.cmo)
+REPOSITORY_XOBJECTS = $(REPOSITORY_BOBJECTS:.cmo=.cmx)
+
 # -I $(top_builddir)/lib/.libs is a hack which forces corresponding -L
 # option to be passed to gcc, so we don't try linking against an
 # installed copy of libguestfs.
 OCAMLPACKAGES = \
 	-package str,unix \
 	-I $(top_builddir)/common/utils/.libs \
+	-I $(top_builddir)/common/mlxml \
 	-I $(top_builddir)/lib/.libs \
 	-I $(top_builddir)/gnulib/lib/.libs \
 	-I $(top_builddir)/ocaml \
@@ -157,13 +212,16 @@ OCAMLFLAGS = $(OCAML_FLAGS) $(OCAML_WARN_ERROR)
 
 if !HAVE_OCAMLOPT
 OBJECTS = $(BOBJECTS)
+REPOSITORY_OBJECTS = $(REPOSITORY_BOBJECTS)
 else
 OBJECTS = $(XOBJECTS)
+REPOSITORY_OBJECTS = $(REPOSITORY_XOBJECTS)
 endif
 
 OCAMLLINKFLAGS = \
 	mlgettext.$(MLARCHIVE) \
 	mlpcre.$(MLARCHIVE) \
+	mlxml.$(MLARCHIVE) \
 	mlstdutils.$(MLARCHIVE) \
 	mlguestfs.$(MLARCHIVE) \
 	mlcutils.$(MLARCHIVE) \
@@ -185,6 +243,16 @@ virt_builder_LINK = \
 	  $(OCAMLFIND) $(BEST) $(OCAMLFLAGS) $(OCAMLPACKAGES) $(OCAMLLINKFLAGS) \
 	  $(OBJECTS) -o $@
 
+virt_builder_repository_DEPENDENCIES = \
+	$(REPOSITORY_OBJECTS) \
+	../common/mltools/mltools.$(MLARCHIVE) \
+	../common/mlxml/mlxml.$(MLARCHIVE) \
+	$(top_srcdir)/ocaml-link.sh
+virt_builder_repository_LINK = \
+	$(top_srcdir)/ocaml-link.sh -cclib '$(OCAMLCLIBS)' -- \
+	  $(OCAMLFIND) $(BEST) $(OCAMLFLAGS) $(OCAMLPACKAGES) $(OCAMLLINKFLAGS) \
+	  $(REPOSITORY_OBJECTS) -o $@
+
 # Manual pages and HTML files for the website.
 
 man_MANS += virt-builder.1
@@ -203,6 +271,20 @@ stamp-virt-builder.pod: virt-builder.pod
$(top_srcdir)/customize/customize-synop
 	  $<
 	touch $@
 
+man_MANS += virt-builder-repository.1
+noinst_DATA += $(top_builddir)/website/virt-builder-repository.1.html
+
+virt-builder-repository.1
$(top_builddir)/website/virt-builder-repository.1.html:
stamp-virt-builder-repository.pod
+
+stamp-virt-builder-repository.pod: virt-builder-repository.pod
+	$(PODWRAPPER) \
+	  --man virt-builder-repository.1 \
+	  --html $(top_builddir)/website/virt-builder-repository.1.html \
+	  --license GPLv2+ \
+	  --warning safe \
+	  $<
+	touch $@
+
 # Tests.
 
 TESTS_ENVIRONMENT = $(top_builddir)/run --test
@@ -321,7 +403,8 @@ check-valgrind:
 
 SLOW_TESTS = \
 	$(console_test_scripts) \
-	test-virt-builder-planner.sh
+	test-virt-builder-planner.sh \
+	test-virt-builder-repository.sh
 
 check-slow:
 	$(MAKE) check TESTS="$(SLOW_TESTS)" SLOW=1
diff --git a/builder/repository_main.ml b/builder/repository_main.ml
new file mode 100644
index 000000000..75ece806d
--- /dev/null
+++ b/builder/repository_main.ml
@@ -0,0 +1,621 @@
+(* virt-builder
+ * Copyright (C) 2016-2017 SUSE 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 Common_gettext.Gettext
+open Tools_utils
+open Unix_utils
+open Getopt.OptionName
+open Utils
+open Yajl
+open Xpath_helpers
+
+open Printf
+
+type cmdline = {
+  gpg : string;
+  gpgkey : string option;
+  interactive : bool;
+  keep_unsigned : bool;
+  compression : bool;
+  repo : string;
+}
+
+type disk_image_info = {
+  format : string;
+  size : int64;
+}
+
+let parse_cmdline () +  let gpg = ref "gpg" in
+  let gpgkey = ref None in
+  let set_gpgkey arg = gpgkey := Some arg in
+
+  let interactive = ref false in
+  let keep_unsigned = ref false in
+  let compression = ref true in
+  let machine_readable = ref false in
+
+  let argspec = [
+    [ L"gpg" ], Getopt.Set_string ("gpg", gpg), s_"Set
GPG binary/command";
+    [ S 'K'; L"gpg-key" ], Getopt.String ("gpgkey",
set_gpgkey),
+      s_"ID of the GPG key to sign the repo with";
+    [ S 'i'; L"interactive" ], Getopt.Set interactive,
s_"Ask the user about missing data";
+    [ L"keep-index" ], Getopt.Set keep_unsigned, s_"Keep
unsigned index";
+    [ L"no-compression" ], Getopt.Clear compression, s_"Don’t
compress the new images in the index";
+    [ L"machine-readable" ], Getopt.Set machine_readable,
s_"Make output machine readable";
+  ] in
+
+  let args = ref [] in
+  let anon_fun s = push_front s args in
+  let usage_msg +    sprintf (f_"\
+%s: create a repository for virt-builder
+
+  virt-builder-repository REPOSITORY_PATH
+
+A short summary of the options is given below.  For detailed help please
+read the man page virt-builder-repository(1).
+")
+      prog in
+  let opthandle = create_standard_options argspec ~anon_fun usage_msg in
+  Getopt.parse opthandle;
+
+  (* Machine-readable mode?  Print out some facts about what
+   * this binary supports.
+   *)
+  if !machine_readable then (
+    printf "virt-builder-repository\n";
+    exit 0
+  );
+
+  (* Dereference options. *)
+  let args = List.rev !args in
+  let gpg = !gpg in
+  let gpgkey = !gpgkey in
+  let interactive = !interactive in
+  let keep_unsigned = !keep_unsigned in
+  let compression = !compression in
+
+  (* Check options *)
+  let repo +    match args with
+    | [repo] -> repo
+    | [] ->
+      error (f_"virt-builder-repository /path/to/repo
+
+Use ‘/path/to/repo’ to point to the repository folder.")
+    | _ ->
+      error (f_"too many parameters, only one path to repository is
allowed") in
+
+  {
+    gpg = gpg;
+    gpgkey = gpgkey;
+    interactive = interactive;
+    keep_unsigned = keep_unsigned;
+    compression = compression;
+    repo = repo;
+  }
+
+let do_mv src dest +  let cmd = [ "mv"; src; dest ] in
+  let r = run_command cmd in
+  if r <> 0 then
+    error (f_"moving file ‘%s’ to ‘%s’ failed") src dest
+
+let checksums_get_sha512 = function
+  | None -> None
+  | Some csums ->
+      try
+        Some (List.find (
+          function
+          | Checksums.SHA512 _ -> true
+          | _ -> false
+        ) csums)
+      with Not_found -> None
+
+let osinfo_ids = ref None
+
+let rec osinfo_get_short_ids () +  match !osinfo_ids with
+  | Some ids -> ids
+  | None ->
+    osinfo_ids :+      Some (
+        Osinfo.fold (
+          fun set filepath ->
+            let doc = Xml.parse_file filepath in
+            let xpathctx = Xml.xpath_new_context doc in
+            let nodes = xpath_get_nodes xpathctx
"/libosinfo/os/short-id" in
+            List.fold_left (
+              fun set node ->
+                let id = Xml.node_as_string node in
+                StringSet.add id set
+            ) set nodes
+        ) StringSet.empty
+      );
+    osinfo_get_short_ids ()
+
+let compress_to file outdir +  let outimg = outdir // (Filename.basename file)
^ ".xz" in
+
+  info "Compressing ...%!";
+  let cmd = [ "xz"; "-f"; "--best";
"--block-size=16777216"; "-c"; file ] in
+  let file_flags = [ Unix.O_WRONLY; Unix.O_CREAT; Unix.O_TRUNC; ] in
+  let outfd = Unix.openfile outimg file_flags 0o666 in
+  let res = run_command cmd ~stdout_chan:outfd in
+  if res <> 0 then
+    error (f_"‘xz’ command failed");
+  outimg
+
+let get_mime_type filepath +  let file_cmd = "file --mime-type --brief
" ^ (quote filepath) in
+  match external_command file_cmd with
+  | [] -> None
+  | line :: _ -> Some line
+
+let get_disk_image_info filepath +  let infos = get_image_infos filepath in
+  {
+    format = object_get_string "format" infos;
+    size = object_get_number "virtual-size" infos
+  }
+
+let compute_short_id distro major minor +  match distro with
+  | "centos" when major >= 7 ->
+    sprintf "%s%d.0" distro major
+  | "debian" when major >= 4 ->
+    sprintf "%s%d" distro major
+  | ("fedora"|"mageia") ->
+    sprintf "%s%d" distro major
+  | "sles" when major = 0 ->
+    sprintf "%s%d" distro major
+  | "sles" ->
+    sprintf "%s%dsp%d" distro major minor
+  | "ubuntu" ->
+    sprintf "%s%d.%02d" distro major minor
+  | _ (* Any other combination. *) ->
+    sprintf "%s%d.%d" distro major minor
+
+let cmp a b +  let string_of_arch = function Index.Arch s -> s |
Index.GuessedArch s -> s in
+  (string_of_arch a) = (string_of_arch b)
+
+let has_entry id arch index +  List.exists (
+    fun (item_id, { Index.arch = item_arch }) ->
+      item_id = id && (cmp item_arch arch)
+  ) index
+
+let process_image acc_entries filename repo tmprepo index interactive
+                  compression sigchecker +  message (f_"Preparing
%s") filename;
+
+  let filepath = repo // filename in
+  let { format = format; size = size } = get_disk_image_info filepath in
+  let out_path +    if not compression then filepath
+    else compress_to filepath tmprepo in
+  let out_filename = Filename.basename out_path in
+  let checksum = Checksums.compute_checksum "sha512" out_path in
+  let compressed_size = (Unix.LargeFile.stat out_path).Unix.LargeFile.st_size
in
+
+  let ask ?default ?values message +    let default_str = match default with
+    | None -> ""
+    | Some x -> sprintf " [%s] " x in
+
+    let list_str = match values with
+    | None -> ""
+    | Some x ->
+      sprintf (f_"Choose one from the list below:\n %s\n")
+              (String.concat "\n " x) in
+
+    printf "%s%s%s%!" message default_str list_str;
+
+    let value = read_line () in
+    match value with
+    | "" -> default
+    | "-" -> None
+    | s -> Some s
+  in
+
+  let rec ask_id default +    match ask (s_"Identifier: ") ~default
with
+    | None -> default
+    | Some id ->
+      if not (Str.string_match (Str.regexp "[a-zA-Z0-9-_.]+") id 0)
then (
+        warning (f_"Allowed characters are letters, digits, - _ and
.");
+        ask_id default
+      ) else
+        id in
+
+  let rec ask_arch guess +    let arches = [ "x86_64";
"aarch64"; "armv7l"; "i686"; "ppc64";
"ppc64le"; "s390x" ] in
+    match (ask (s_"Architecture: ") ~default:guess ~values:arches)
with
+    | None -> ask_arch guess
+    | Some x ->
+      if x = "" then
+        ask_arch guess
+      else
+        Index.Arch x
+  in
+
+  let ask_osinfo default +    match ask (s_ "osinfo short ID: ")
+              ~default with
+    | None -> None
+    | Some osinfo ->
+      let osinfo_ids = osinfo_get_short_ids () in
+      if not (StringSet.mem osinfo osinfo_ids) then
+        warning (f_"‘%s’ is not a recognized osinfo OS id; using it
anyway") osinfo;
+      Some osinfo in
+
+  let extract_entry_data ?entry () +    message (f_"Extracting data from
the image...");
+    let g = new Guestfs.guestfs () in
+    g#add_drive_ro filepath;
+    g#launch ();
+
+    let roots = g#inspect_os () in
+    let nroots = Array.length roots in
+    if nroots <> 1 then
+      error (f_"virt-builder template images must have one and only one
root file system, found %d")
+            nroots;
+
+    let root = Array.get roots 0 in
+    let inspected_arch = g#inspect_get_arch root in
+    let product = g#inspect_get_product_name root in
+    let distro = g#inspect_get_distro root in
+    let version_major = g#inspect_get_major_version root in
+    let version_minor = g#inspect_get_minor_version root in
+    let lvs = g#lvs () in
+    let filesystems = g#inspect_get_filesystems root in
+
+    let shortid = compute_short_id distro version_major version_minor in
+
+    g#close ();
+
+    let id +      match entry with
+      | Some (id, _) -> id
+      | None -> (
+        if interactive then ask_id shortid
+        else error (f_"missing image identifier")
+      ) in
+
+    let arch +      match entry with
+      | Some (_, { Index.arch = arch }) -> (
+        match arch with
+        | Index.Arch arch -> Index.Arch arch
+        | Index.GuessedArch arch ->
+          if interactive then ask_arch arch
+          else Index.Arch arch )
+      | None ->
+        if interactive then ask_arch inspected_arch
+        else Index.Arch inspected_arch in
+
+    if has_entry id arch acc_entries then (
+      let arch +        match arch with
+        | Index.Arch arch
+        | Index.GuessedArch arch -> arch in
+      error (f_"Already existing image with id %s and architecture
%s") id arch
+    );
+
+    let printable_name +      match entry with
+      | Some (_, { Index.printable_name = printable_name }) ->
+        if printable_name = None then
+          if interactive then ask (s_"Display name: ")
~default:product
+          else Some product
+        else
+          printable_name
+      | None -> Some product in
+
+    let osinfo +      match entry with
+      | Some (_, { Index.osinfo = osinfo }) ->
+        if osinfo = None then
+          if interactive then ask_osinfo shortid else Some shortid
+        else
+          osinfo
+      | None ->
+        if interactive then ask_osinfo shortid else Some shortid in
+
+    let expand +      match entry with
+      | Some (_, { Index.expand = expand }) ->
+        if expand = None then
+          if interactive then ask (s_"Expandable partition: ")
~default:root
+                                  ~values:(Array.to_list filesystems)
+          else Some root
+        else
+          expand
+      | None ->
+        if interactive then ask (s_"Expandable partition: ")
~default:root
+                                ~values:(Array.to_list filesystems)
+        else Some root in
+
+    let lvexpand +      match entry with
+      | Some (_, { Index.lvexpand = lvexpand }) ->
+        if lvexpand = None && lvs <> [||] then
+          if interactive then
+            ask (s_"Expandable volume: ") ~values:(Array.to_list lvs)
+          else Some (Array.get lvs 0)
+        else
+          lvexpand
+      | None ->
+        if interactive then
+          ask (s_"Expandable volume: ") ~values:(Array.to_list lvs)
+        else Some (Array.get lvs 0) in
+
+    let revision +      match entry with
+      | Some (_, { Index.revision = revision }) ->
+        Utils.increment_revision revision
+      | None -> Rev_int 1 in
+
+    let notes +      match entry with
+      | Some (_, { Index.notes = notes }) -> notes
+      | None -> [] in
+
+    let hidden +      match entry with
+      | Some (_, { Index.hidden = hidden }) -> hidden
+      | None -> false in
+
+    let aliases +      match entry with
+      | Some (_, { Index.aliases = aliases }) -> aliases
+      | None -> None in
+
+    (id, { Index.printable_name = printable_name;
+           osinfo = osinfo;
+           file_uri = Filename.basename out_path;
+           arch = arch;
+           signature_uri = None;
+           checksums = Some [checksum];
+           revision = revision;
+           format = Some format;
+           size = size;
+           compressed_size = Some compressed_size;
+           expand = expand;
+           lvexpand = lvexpand;
+           notes = notes;
+           hidden = hidden;
+           aliases = aliases;
+           sigchecker = sigchecker;
+           proxy = Curl.SystemProxy })
+  in
+
+  (* Do we have an entry for that file already? *)
+  let file_entry +    try
+      List.hd (
+        List.filter (
+          fun (_, { Index.file_uri = file_uri }) ->
+            let basename = Filename.basename file_uri in
+            basename = out_filename || basename = filename
+        ) index
+      )
+    with
+    | Failure _ -> extract_entry_data () in
+
+  let _, { Index.checksums = checksums } = file_entry in
+  let old_checksum = checksums_get_sha512 checksums in
+
+  match old_checksum with
+  | Some old_sum ->
+      if old_sum = checksum then
+        let id, entry = file_entry in
+        (id, { entry with Index.file_uri = out_filename })
+      else
+        extract_entry_data ~entry:file_entry ()
+  | None ->
+    extract_entry_data ~entry:file_entry ()
+
+let main () +  let cmdline = parse_cmdline () in
+
+  (* If debugging, echo the command line arguments. *)
+  debug "command line: %s" (String.concat " "
(Array.to_list Sys.argv));
+
+  (* Check that the paths are existing *)
+  if not (Sys.file_exists cmdline.repo) then
+    error (f_"repository folder ‘%s’ doesn’t exist") cmdline.repo;
+
+  (* Create a temporary folder to work in *)
+  let tmpdir = Mkdtemp.temp_dir ~base_dir:cmdline.repo
+                                "virt-builder-repository." in
+  rmdir_on_exit tmpdir;
+
+  let tmprepo = tmpdir // "repo" in
+  mkdir_p tmprepo 0o700;
+
+  let sigchecker = Sigchecker.create ~gpg:cmdline.gpg
+                                     ~check_signature:false
+                                     ~gpgkey:No_Key
+                                     ~tmpdir in
+
+  let index +    try
+      let index_filename +        List.find (
+          fun filename -> Sys.file_exists (cmdline.repo // filename)
+        ) [ "index.asc"; "index" ] in
+
+      let downloader = Downloader.create ~curl:"do-not-use-curl"
+                                         ~cache:None ~tmpdir in
+
+      let source = { Sources.name = index_filename;
+                     uri = cmdline.repo // index_filename;
+                     gpgkey = No_Key;
+                     proxy = Curl.SystemProxy;
+                     format = Sources.FormatNative } in
+
+      Index_parser.get_index ~downloader ~sigchecker ~template:true source
+    with Not_found -> [] in
+
+  (* Check for index/interactive consistency *)
+  if not cmdline.interactive && index = [] then
+    error (f_"the repository must contain an index file when running in
automated mode");
+
+  debug "Searching for images ...";
+
+  let images +    let is_supported_format file +      let extension =
last_part_of file '.' in
+      match extension with
+      | Some ext -> List.mem ext [ "qcow2"; "raw";
"img" ]
+      | None ->
+        match (get_mime_type file) with
+        | None -> false
+        | Some mime -> mime = "application/octet-stream" in
+    let is_new file +      try
+        let _, { Index.checksums = checksums } +          List.find (
+            fun (_, { Index.file_uri = file_uri }) ->
+              Filename.basename file_uri = file
+          ) index in
+        let checksum = checksums_get_sha512 checksums in
+        let path = cmdline.repo // file in
+        let file_checksum = Checksums.compute_checksum "sha512" path
in
+        match checksum with
+        | None -> true
+        | Some sum -> sum <> file_checksum
+      with Not_found -> true in
+    let files = Array.to_list (Sys.readdir cmdline.repo) in
+    let files = List.filter (
+      fun file -> is_regular_file (cmdline.repo // file)
+    ) files in
+    List.filter (
+      fun file ->
+        if is_supported_format (cmdline.repo // file) then
+          is_new file
+        else
+          false
+    ) files in
+
+  if images = [] then (
+    info (f_ "No new image found");
+    exit 0
+  );
+
+  info (f_ "Found new images: %s") (String.concat " "
images);
+
+  let outindex_path = tmprepo // "index" in
+  let index_channel = open_out outindex_path in
+
+  (* Generate entries for uncompressed images *)
+  let images_entries = List.fold_right (
+    fun filename acc ->
+      let image_entry = process_image acc
+                                      filename
+                                      cmdline.repo
+                                      tmprepo
+                                      index
+                                      cmdline.interactive
+                                      cmdline.compression
+                                      sigchecker in
+      image_entry :: acc
+  ) images [] in
+
+  (* Filter out entries for newly found images and entries
+     without a corresponding image file or with empty arch *)
+  let index = List.filter (
+    fun (id, { Index.arch = arch;
+               Index.file_uri = file_uri }) ->
+      not (has_entry id arch images_entries) && Sys.file_exists
file_uri
+  ) index in
+
+  (* Convert all URIs back to relative ones *)
+  let index = List.map (
+    fun (id, entry) ->
+      let { Index.file_uri = file_uri } = entry in
+      let rel_path +        try
+          subdirectory cmdline.repo file_uri
+        with
+        | Invalid_argument _ ->
+          file_uri in
+      let rel_entry = { entry with Index.file_uri = rel_path } in
+      (id, rel_entry)
+  ) index in
+
+  (* Write all the entries *)
+  List.iter (
+    fun entry ->
+      Index_parser.write_entry index_channel entry;
+  ) (index @ images_entries);
+
+  close_out index_channel;
+
+  (* GPG sign the generated index *)
+  (match cmdline.gpgkey with
+  | None ->
+    debug "Skip index signing"
+  | Some gpgkey ->
+    message (f_"Signing index with the GPG key %s") gpgkey;
+    let cmd = sprintf "%s --armor --output %s --export %s"
+                      (quote (cmdline.gpg // "index.gpg"))
+                      (quote tmprepo) (quote gpgkey) in
+    if shell_command cmd <> 0 then
+      error (f_"failed to export the GPG key %s") gpgkey;
+
+    let cmd = sprintf "%s --armor --default-key %s --clearsign %s"
+                       (quote cmdline.gpg) (quote gpgkey)
+                       (quote (tmprepo // "index" )) in
+    if shell_command cmd <> 0 then
+      error (f_"failed to sign index");
+
+    (* Remove the index file since we have the signed version of it *)
+    if not cmdline.keep_unsigned then
+      Sys.remove (tmprepo // "index")
+  );
+
+  message (f_"Creating index backup copy");
+
+  List.iter (
+    fun filename ->
+      let filepath = cmdline.repo // filename in
+      if Sys.file_exists filepath then
+        do_mv filepath (filepath ^ ".bak")
+  ) ["index"; "index.asc"];
+
+  message (f_"Moving files to final destination");
+
+  Array.iter (
+    fun filename ->
+      do_mv (tmprepo // filename) cmdline.repo
+  ) (Sys.readdir tmprepo);
+
+  debug "Cleanup";
+
+  (* Remove the processed image files *)
+  if cmdline.compression then
+    List.iter (
+      fun filename -> Sys.remove (cmdline.repo // filename)
+    ) images
+
+let () = run_main_and_handle_errors main
diff --git a/builder/test-docs.sh b/builder/test-docs.sh
index 884135de6..6f39b906d 100755
--- a/builder/test-docs.sh
+++ b/builder/test-docs.sh
@@ -25,3 +25,5 @@ $top_srcdir/podcheck.pl virt-builder.pod virt-builder \
   --insert $top_srcdir/customize/customize-synopsis.pod:__CUSTOMIZE_SYNOPSIS__
\
   --insert $top_srcdir/customize/customize-options.pod:__CUSTOMIZE_OPTIONS__ \
   --ignore=--check-signatures,--no-check-signatures
+
+$srcdir/../podcheck.pl virt-builder-repository.pod virt-builder-repository
diff --git a/builder/test-virt-builder-repository.sh
b/builder/test-virt-builder-repository.sh
new file mode 100755
index 000000000..5ff270bcc
--- /dev/null
+++ b/builder/test-virt-builder-repository.sh
@@ -0,0 +1,98 @@
+#!/bin/bash -
+# libguestfs
+# Copyright (C) 2017 SUSE 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
+slow_test
+skip_if_skipped "$script"
+
+test_data=repository-testdata
+rm -rf $test_data
+mkdir $test_data
+
+# Make a copy of the Fedora image
+cp ../test-data/phony-guests/fedora.img $test_data
+
+# Create minimal index file
+cat > $test_data/index << EOF
+[fedora]
+file=fedora.img
+EOF
+
+# Run virt-builder-repository (no compression, interactive)
+echo 'x86_64
+Fedora Test Image
+fedora14
+/dev/sda1
+/dev/VG/Root
+' | virt-builder-repository -v -x --no-compression -i $test_data
+
+assert_config () {
+    item=$1
+    regex=$2
+
+    sed -n -e "/\[$item]/,/^$/p" $test_data/index | grep
"$regex"
+}
+
+# Check the generated index file
+assert_config 'fedora' 'revision=1'
+assert_config 'fedora' 'arch=x86_64'
+assert_config 'fedora' 'name=Fedora Test Image'
+assert_config 'fedora' 'osinfo=fedora14'
+assert_config 'fedora' 'checksum'
+assert_config 'fedora' 'format=raw'
+assert_config 'fedora' '^size='
+assert_config 'fedora' 'compressed_size='
+assert_config 'fedora' 'expand=/dev/'
+
+
+# Copy the debian image and add the minimal piece to index
+cp ../test-data/phony-guests/debian.img $test_data
+
+cat >> $test_data/index << EOF
+
+[debian]
+file=debian.img
+EOF
+
+# Run virt-builder-repository again
+echo 'x86_64
+Debian Test Image
+debian9
+
+' | virt-builder-repository --no-compression -i $test_data
+
+# Check that the new image is complete and the first one hasn't changed
+assert_config 'fedora' 'revision=1'
+
+assert_config 'debian' 'revision=1'
+assert_config 'debian' 'checksum'
+
+# Modify the fedora image
+export EDITOR='echo newline >>'
+virt-edit -a $test_data/fedora.img /etc/test3
+
+# Rerun the tool (with compression)
+virt-builder-repository -i $test_data
+
+# Check that the revision, file and size have been updated
+assert_config 'fedora' 'revision=2'
+assert_config 'fedora' 'file=fedora.img.xz'
+test -e $test_data/fedora.img.xz
+! test -e $test_data/fedora.img
diff --git a/builder/utils.ml b/builder/utils.ml
index d0e51a049..4cca4c21d 100644
--- a/builder/utils.ml
+++ b/builder/utils.ml
@@ -35,6 +35,10 @@ let string_of_revision = function
   | Rev_int n -> string_of_int n
   | Rev_string s -> s
 
+let increment_revision = function
+  | Rev_int n -> Rev_int (n + 1)
+  | Rev_string s -> Rev_int ((int_of_string s) + 1)
+
 let get_image_infos filepath    let qemuimg_cmd = "qemu-img info --output
json " ^ quote filepath in
   let lines = external_command qemuimg_cmd in
diff --git a/builder/utils.mli b/builder/utils.mli
index 5c7bfa1e4..7440e4b3d 100644
--- a/builder/utils.mli
+++ b/builder/utils.mli
@@ -32,3 +32,6 @@ val string_of_revision : revision -> string
 val get_image_infos : string -> Yajl.yajl_val
 (** [get_image_infos path] Run qemu-img info on the image pointed at
     path as YAJL tree. *)
+
+val increment_revision : revision -> revision
+(** Add one to the version number *)
diff --git a/builder/virt-builder-repository.pod
b/builder/virt-builder-repository.pod
new file mode 100644
index 000000000..11fec8f07
--- /dev/null
+++ b/builder/virt-builder-repository.pod
@@ -0,0 +1,213 @@
+=begin html
+
+<img src="virt-builder.svg" width="250"
+  style="float: right; clear: right;" />
+
+=end html
+
+=head1 NAME
+
+virt-builder-repository - Build virt-builder source repository easily
+
+=head1 SYNOPSIS
+
+ virt-builder-repository /path/to/repository
+    [-i|--interactive] [--gpg-key KEYID]
+
+=head1 DESCRIPTION
+
+Virt-builder is a tool for quickly building new virtual machines. It can
+be configured to use template repositories. However creating and
+maintaining a repository involves many tasks which can be automated.
+virt-builder-repository is a tool helping to manage these repositories.
+
+Virt-builder-repository loops over the files in the directory specified
+as argument, compresses the files with a name ending by C<qcow2>,
C<raw>,
+C<img> or without extension, extracts data from them and creates or
+updates the C<index> file.
+
+Some of the image-related data needed for the index file can’t be
+computed from the image file. virt-builder-repository first tries to
+find them in the existing index file. If data are still missing after
+this, they are prompted in interactive mode, otherwise an error will
+be triggered.
+
+If a C<KEYID> is provided, the generated index file will be signed
+with this GPG key.
+
+=head1 EXAMPLES
+
+=head2 Create the initial repository
+
+Create a folder and copy the disk image template files in it. Then
+run a command like the following one:
+
+ virt-builder-repository --gpg-key "joe@hacker.org" -i
/path/to/folder
+
+Note that this example command runs in interactive mode. To run in
+automated mode, a minimal index file needs to be created before running
+the command containing sections like this one:
+
+ [template_id]
+ file=template_filename.qcow.xz
+
+The file value needs to match the image name extended with the C<.xz>
+suffix if the I<--no-compression> parameter is not provided or the
+image name if no compression is involved. Other optional data can be
+prefilled. Default values are computed by inspecting the disk image.
+For more informations, see
+L<virt-builder(1)/Creating and signing the index file>.
+
+=head2 Update images in an existing repository
+
+In this use case, an new image or a new revision of an existing image
+needs to be added to the repository. Place the corresponding image
+template files in the repository folder.
+
+To update the revision of an image, the file needs to have the same
+name than the existing one (without the C<xz> extension).
+
+As in the repository creation use case, a minimal fragment can be
+added to the index file for the automated mode. This can be done
+on the signed index even if it may sound a strange idea: the index
+will be signed again by the tool.
+
+To remove an image from the repository, just remove the corresponding
+image file before running virt-builder-repository.
+
+Then running the following command will complete and update the index
+file:
+
+ virt-builder-repository --gpg-key "joe@hacker.org" -i
/path/to/folder
+
+virt-builder-repository works in a temporary folder inside the repository
+one. If anything wrong happens when running the tool, the repository is
+left untouched.
+
+=head1 OPTIONS
+
+=over 4
+
+=item B<--help>
+
+Display help.
+
+=item B<--gpg> GPG
+
+Specify an alternate L<gpg(1)> (GNU Privacy Guard) binary.  You can
+also use this to add gpg parameters, for example to specify an
+alternate home directory:
+
+ virt-builder-repository --gpg "gpg --homedir /tmp" [...]
+
+This can also be used to avoid gpg asking for the key passphrase:
+
+ virt-builder-repository --gpg "gpg --passphrase-file /tmp/pass
--batch" [...]
+
+=item B<-K> KEYID
+
+=item B<--gpg-key> KEYID
+
+Specify the GPG key to be used to sign the repository index file.
+If not provided, the index will left unsigned. C<KEYID> is used to
+identify the GPG key to use. This value is passed to gpg’s
+I<--default-key> option and can thus be an email address or a
+fingerprint.
+
+B<NOTE>: by default, virt-builder-repository searches for the key
+in the user’s GPG keyring.
+
+=item B<-i>
+
+=item B<--interactive>
+
+Prompt for missing data. Default values are computed from the disk
+image.
+
+When prompted for data, inputting C<-> corresponds to leaving the
+value empty. This can be used to avoid setting the default computed value.
+
+=item B<--keep-index>
+
+When using a GPG key, don’t remove the unsigned index.
+
+=item B<--no-compression>
+
+Don’t compress the template images.
+
+=item B<--machine-readable>
+
+This option is used to make the output more machine friendly
+when being parsed by other programs.  See
+L</MACHINE READABLE OUTPUT> below.
+
+
+=item B<--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<-q>
+
+=item B<--quiet>
+
+Don’t print ordinary progress messages.
+
+=item B<-v>
+
+=item B<--verbose>
+
+Enable debug messages and/or produce verbose output.
+
+When reporting bugs, use this option and attach the complete output to
+your bug report.
+
+=item B<-V>
+
+=item B<--version>
+
+Display version number and exit.
+
+=item B<-x>
+
+Enable tracing of libguestfs API calls.
+
+
+=back
+
+=head1 MACHINE READABLE OUTPUT
+
+The I<--machine-readable> option can be used to make the output more
+machine friendly, which is useful when calling virt-builder-repository from
+other programs, GUIs etc.
+
+Use the option on its own to query the capabilities of the
+virt-builder-repository binary.  Typical output looks like this:
+
+ $ virt-builder-repository --machine-readable
+ virt-builder-repository
+
+A list of features is printed, one per line, and the program exits
+with status 0.
+
+=head1 EXIT STATUS
+
+This program returns 0 if successful, or non-zero if there was an
+error.
+
+=head1 SEE ALSO
+
+L<virt-builder(1)>
+L<http://libguestfs.org/>.
+
+=head1 AUTHOR
+
+Cédric Bosdonnat L<mailto:cbosdonnat@suse.com>
+
+=head1 COPYRIGHT
+
+Copyright (C) 2016-2017 SUSE Inc.
diff --git a/builder/virt-builder.pod b/builder/virt-builder.pod
index 74bf7bb11..1ed18a7c7 100644
--- a/builder/virt-builder.pod
+++ b/builder/virt-builder.pod
@@ -1319,6 +1319,9 @@ digital signature):
 The part in square brackets is the C<os-version>, which is the same
 string that is used on the virt-builder command line to build that OS.
 
+The index file creation and signature can be eased with the
+L<virt-builder-repository(1)> tool.
+
 After preparing the C<index> file in the correct format, clearsign it
 using the following command:
 
@@ -1875,6 +1878,7 @@ error.
 L<guestfs(3)>,
 L<guestfish(1)>,
 L<guestmount(1)>,
+L<virt-builder-repository(1)>,
 L<virt-copy-out(1)>,
 L<virt-customize(1)>,
 L<virt-get-kernel(1)>,
diff --git a/fish/guestfish.pod b/fish/guestfish.pod
index 11f2bbeb5..c37189bd8 100644
--- a/fish/guestfish.pod
+++ b/fish/guestfish.pod
@@ -1617,6 +1617,7 @@ L<guestfs(3)>,
 L<http://libguestfs.org/>,
 L<virt-alignment-scan(1)>,
 L<virt-builder(1)>,
+L<virt-builder-repository(1)>,
 L<virt-cat(1)>,
 L<virt-copy-in(1)>,
 L<virt-copy-out(1)>,
diff --git a/installcheck.sh.in b/installcheck.sh.in
index 6b05ab812..a4829cda6 100644
--- a/installcheck.sh.in
+++ b/installcheck.sh.in
@@ -46,6 +46,7 @@ cp @bindir@/guestfish             fish/
 cp @bindir@/guestmount            fuse/
 cp @bindir@/virt-alignment-scan   align/
 cp @bindir@/virt-builder          builder/
+cp @bindir@/virt-builder-repository builder/
 cp @bindir@/virt-cat              cat/
 cp @bindir@/virt-copy-in          fish/
 cp @bindir@/virt-copy-out         fish/
diff --git a/lib/guestfs.pod b/lib/guestfs.pod
index 8d31f3200..55467e92e 100644
--- a/lib/guestfs.pod
+++ b/lib/guestfs.pod
@@ -3417,6 +3417,7 @@ L<guestfish(1)>,
 L<guestmount(1)>,
 L<virt-alignment-scan(1)>,
 L<virt-builder(1)>,
+L<virt-builder-repository(1)>,
 L<virt-cat(1)>,
 L<virt-copy-in(1)>,
 L<virt-copy-out(1)>,
-- 
2.14.3

On Mon, Nov 13, 2017 at 02:56:10PM +0100, Cédric Bosdonnat
wrote:
> Change Index.arch to the type (Arch of string | GuessedArch of string).
> 
> In a future commit, the index parser will allow arch not to be set
> for some cases. Thus arch value will be guessed by inspecting the
> image. However we need to distinguish between a set value and a guessed
> one. Using this new type will help it:
> 
>     match arch with
>     | Arch s        -> (* This is a set value *)
>     | GuessedArch s -> (* This is a guessed value *)
This commit would be a lot simpler if you defined a ‘string_of_arch’
function in index.ml like this:

  let string_of_arch = function Arch a | GuessedArch a -> a

More comments inline below.
> --- a/builder/builder.ml
> +++ b/builder/builder.ml
> @@ -94,7 +94,9 @@ let selected_cli_item cmdline index >    let item >
try List.find (
>        fun (name, { Index.arch = a }) ->
> -        name = arg && cmdline.arch = normalize_arch a
> +        match a with
> +        | Index.Arch a
> +        | Index.GuessedArch a -> name = arg && cmdline.arch =
normalize_arch a
With string_of_arch this becomes:

-        name = arg && cmdline.arch = normalize_arch a
+        name = arg && cmdline.arch = normalize_arch
(Index.string_of_arch a)
> @@ -252,7 +254,7 @@ let main () >          List.iter (
>            fun (name,
>                 { Index.revision; file_uri; proxy }) ->
> -            let template = name, cmdline.arch, revision in
> +            let template = name, (Index.Arch cmdline.arch), revision in
You don't need parentheses here.

Constructors like Arch behave in the same way as function application
(in SML they are actually functions, but not in OCaml), so they bind
tighter than any other operator.
> @@ -300,7 +302,7 @@ let main () >    let template >      let
template, delete_on_exit >        let { Index.revision; file_uri; proxy } =
entry in
> -      let template = arg, cmdline.arch, revision in
> +      let template = arg, (Index.Arch cmdline.arch), revision in
Similarly, no parens.
>        message (f_"Downloading: %s") file_uri;
>        let progress_bar = not (quiet ()) in
>        Downloader.download downloader ~template ~progress_bar ~proxy
> diff --git a/builder/cache.ml b/builder/cache.ml
> index dbd222fda..e313a8bcf 100644
> --- a/builder/cache.ml
> +++ b/builder/cache.ml
> @@ -41,6 +41,10 @@ let create ~directory >    }
>  
>  let cache_of_name t name arch revision > +  let arch > +    match
arch with
> +    | Index.Arch arch
> +    | Index.GuessedArch arch -> arch in
This can be replaced by Index.string_of_arch.
>    t.directory // sprintf "%s.%s.%s" name arch
(string_of_revision revision)
>  
>  let is_cached t name arch revision > @@ -54,6 +58,10 @@ let
print_item_status t ~header l >    List.iter (
>      fun (name, arch, revision) ->
>        let cached = is_cached t name arch revision in
> +      let arch > +        match arch with
> +        | Index.Arch arch
> +        | Index.GuessedArch arch -> arch in
string_of_arch
> --- a/builder/downloader.mli
> +++ b/builder/downloader.mli
> @@ -27,7 +27,7 @@ type t
>  val create : curl:string -> tmpdir:string -> cache:Cache.t option
-> t
>  (** Create the abstract type. *)
>  
> -val download : t -> ?template:(string*string*Utils.revision) ->
?progress_bar:bool -> ?proxy:Curl.proxy -> uri -> (filename * bool)
> +val download : t -> ?template:(string*Index.arch*Utils.revision) ->
More spaces needed, and I think you don't need the parens either.
>      ?progress_bar:bool -> ?proxy:Curl.proxy -> uri -> (filename *
bool)
You don't need parens around ‘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
> diff --git a/builder/index.ml b/builder/index.ml
> index 84f66c265..5bc11b6f7 100644
> --- a/builder/index.ml
> +++ b/builder/index.ml
> @@ -25,12 +25,13 @@ open Utils
>  open Printf
>  open Unix
>  
> +
>  type index = (string * entry) list      (* string = "os-version"
*)
You've added an extra blank line.
> @@ -56,7 +60,9 @@ let print_entry chan (name, { printable_name; file_uri;
arch; osinfo;
>    Option.may (fp "name=%s\n") printable_name;
>    Option.may (fp "osinfo=%s\n") osinfo;
>    fp "file=%s\n" file_uri;
> -  fp "arch=%s\n" arch;
> +  match arch with
> +  | Arch arch
> +  | GuessedArch arch -> fp "arch=%s\n" arch;
string_of_arch could be used here.
> diff --git a/builder/index_parser.ml b/builder/index_parser.ml
> index f76aed65d..a4d1e466e 100644
> --- a/builder/index_parser.ml
> +++ b/builder/index_parser.ml
> @@ -97,7 +97,7 @@ let get_index ~downloader ~sigchecker { Sources.uri;
proxy } >                eprintf (f_"%s: no ‘file’ (URI) entry for
‘%s’\n") prog n;
>              corrupt_file () in
>            let arch > -            try List.assoc ("arch",
None) fields
> +            try Index.Arch (List.assoc ("arch", None) fields)
>              with Not_found ->
>                eprintf (f_"%s: no ‘arch’ entry for ‘%s’\n") prog
n;
>              corrupt_file () in
> @@ -236,7 +236,9 @@ let write_entry chan (name, { Index.printable_name;
file_uri; arch; osinfo;
>    Option.may (fp "name=%s\n") printable_name;
>    Option.may (fp "osinfo=%s\n") osinfo;
>    fp "file=%s\n" file_uri;
> -  fp "arch=%s\n" arch;
> +  match arch with
> +  | Index.Arch arch
> +  | Index.GuessedArch arch -> fp "arch=%s\n" arch;
string_of_arch
>    Option.may (fp "sig=%s\n") signature_uri;
>    (match checksums with
>    | None -> ()
> diff --git a/builder/list_entries.ml b/builder/list_entries.ml
> index af1d2419b..c0b7e48dd 100644
> --- a/builder/list_entries.ml
> +++ b/builder/list_entries.ml
> @@ -46,7 +46,9 @@ and list_entries_short index >      fun (name, {
Index.printable_name; arch; hidden }) ->
>        if not hidden then (
>          printf "%-24s" name;
> -        printf " %-10s" arch;
> +        match arch with
> +        | Index.Arch arch
> +        | Index.GuessedArch arch -> printf " %-10s" arch;
string_of_arch
>          Option.may (printf " %s") printable_name;
>          printf "\n"
>        )
> @@ -74,7 +76,9 @@ and list_entries_long ~sources index >        if not
hidden then (
>          printf "%-24s %s\n" "os-version:" name;
>          Option.may (printf "%-24s %s\n" (s_"Full
name:")) printable_name;
> -        printf "%-24s %s\n" (s_"Architecture:") arch;
> +        match arch with
> +        | Index.Arch arch
> +        | Index.GuessedArch arch -> printf "%-24s %s\n"
(s_"Architecture:") arch;
string_of_arch
>          printf "%-24s %s\n" (s_"Minimum/default
size:") (human_size size);
>          Option.may (fun size ->
>              printf "%-24s %s\n" (s_"Download size:")
(human_size size)
> @@ -116,7 +120,10 @@ and list_entries_json ~sources index >           
match printable_name with
>            | None -> item
>            | Some str -> ("full-name", JSON.String str) ::
item in
> -        let item = ("arch", JSON.String arch) :: item in
> +        let item > +          match arch with
> +          | Index.Arch arch
> +          | Index.GuessedArch arch -> ("arch", JSON.String
arch) :: item in
string_of_arch

- - -

Basically the patch is fine with the changes as noted.

Rich.

-- 
Richard Jones, Virtualization Group, Red Hat http://people.redhat.com/~rjones
Read my programming and virtualization blog: http://rwmj.wordpress.com
virt-builder quickly builds VMs from scratch
http://libguestfs.org/virt-builder.1.html

On Mon, Nov 13, 2017 at 02:56:11PM +0100, Cédric Bosdonnat
wrote:
> +                let g = new Guestfs.guestfs () in
Instead of this, use:

  let g = open_guestfs ~identifier:"template" () in

‘open_guestfs’ is a wrapper around ‘new guestfs’ defined in
common/mltools/tools_utils.ml which applies the --trace and --verbose
flags from the command line and lets you set a per-handle identifier
for debugging.  You can choose any useful identifier for the handle,
in case "template" is not a good one.
>            let size > +            let get_image_size filepath > +   
(* If a compressed image manages to reach this code, qemu-img just
> +                 returns a virtual-size equal to actual-size *)
> +              let infos = Utils.get_image_infos filepath in
> +              Yajl.object_get_number "virtual-size" infos in
Is this the right thing to do?  qemu-img info returns the compressed
size in this case, which is ... wrong (maybe?)?

If a compressed image is wrong here then you could use
detect_file_type from common/mltools/tools_utils.ml to detect that
situation.

Rich.

-- 
Richard Jones, Virtualization Group, Red Hat http://people.redhat.com/~rjones
Read my programming and virtualization blog: http://rwmj.wordpress.com
virt-p2v converts physical machines to virtual machines.  Boot with a
live CD or over the network (PXE) and turn machines into KVM guests.
http://libguestfs.org/virt-v2v

On Mon, Nov 13, 2017 at 02:56:12PM +0100, Cédric Bosdonnat
wrote:
> +let checksums_get_sha512 = function
> +  | None -> None
> +  | Some csums ->
> +      try
> +        Some (List.find (
> +          function
> +          | Checksums.SHA512 _ -> true
> +          | _ -> false
> +        ) csums)
> +      with Not_found -> None
This is still a bit difficult to understand.  How about this explicit
loop?

  let checksums_get_sha512 = function
    | None -> None
    | Some csums ->
        let rec loop = function
        | [] -> None
        | Checksums.SHA512 csum :: _ -> Some csum
        | _ :: rest -> loop rest
        in
        loop csums
> +let osinfo_ids = ref None
> +
> +let rec osinfo_get_short_ids () > +  match !osinfo_ids with
> +  | Some ids -> ids
> +  | None ->
> +    osinfo_ids :> +      Some (
> +        Osinfo.fold (
> +          fun set filepath ->
> +            let doc = Xml.parse_file filepath in
> +            let xpathctx = Xml.xpath_new_context doc in
> +            let nodes = xpath_get_nodes xpathctx
"/libosinfo/os/short-id" in
> +            List.fold_left (
> +              fun set node ->
> +                let id = Xml.node_as_string node in
> +                StringSet.add id set
> +            ) set nodes
> +        ) StringSet.empty
> +      );
> +    osinfo_get_short_ids ()
It doesn't really matter for this, but there is a nice way to write a
generic "memoize" higher-order function:

  https://stackoverflow.com/questions/14454981/memoization-in-ocaml

(You wouldn't need the recursive variant here)
> +let compress_to file outdir > +  let outimg = outdir //
(Filename.basename file) ^ ".xz" in
Don't need parens around function application.
> +  info "Compressing ...%!";
You don't need %! here because the ‘info’ function calls
‘print_newline’ from stdlib and ‘print_newline’ calls ‘flush stdout’:

 
https://github.com/libguestfs/libguestfs/blob/a88385add653c4fc2592639d72b638f693798091/common/mltools/tools_utils.ml#L96
 
https://github.com/ocaml/ocaml/blob/c5fe6932b2151d0e4426072b4df3510318bc4edc/stdlib/pervasives.ml#L477
> +  let cmd = [ "xz"; "-f"; "--best";
"--block-size=16777216"; "-c"; file ] in
> +  let file_flags = [ Unix.O_WRONLY; Unix.O_CREAT; Unix.O_TRUNC; ] in
> +  let outfd = Unix.openfile outimg file_flags 0o666 in
> +  let res = run_command cmd ~stdout_chan:outfd in
I read the code of run_command but I don't think it closes outfd, and
so outfd would be leaked here.

Also it'd be nice to use with_openfile, if it was upstream.

  https://www.redhat.com/archives/libguestfs/2017-November/msg00028.html

Pino ^ x 2 ?
> +  if res <> 0 then
> +    error (f_"‘xz’ command failed");
> +  outimg
> +
> +let get_mime_type filepath > +  let file_cmd = "file --mime-type
--brief " ^ (quote filepath) in
Don't need parens.
> +let cmp a b > +  let string_of_arch = function Index.Arch s -> s |
Index.GuessedArch s -> s in
> +  (string_of_arch a) = (string_of_arch b)
You don't need parens here.

If you define Index.string_of_arch in the earlier then you can remove
the definition of string_of_arch here as well.
> +
> +let has_entry id arch index > +  List.exists (
> +    fun (item_id, { Index.arch = item_arch }) ->
> +      item_id = id && (cmp item_arch arch)
Don't need parens.
> +let process_image acc_entries filename repo tmprepo index interactive
> +                  compression sigchecker > +  message
(f_"Preparing %s") filename;
> +
> +  let filepath = repo // filename in
> +  let { format = format; size = size } = get_disk_image_info filepath in
Since commit c7651744da45 you can now write this as:

  let { format; size } = get_disk_image_info filepath in
> +  let ask ?default ?values message > +    let default_str = match
default with
> +    | None -> ""
> +    | Some x -> sprintf " [%s] " x in
> +    let list_str = match values with
> +    | None -> ""
> +    | Some x ->
> +      sprintf (f_"Choose one from the list below:\n %s\n")
> +              (String.concat "\n " x) in
> +
> +    printf "%s%s%s%!" message default_str list_str;
Seems quite a long way of writing:

  let ask ?default ?values message     printf "%s" message;
    (match default with
    | None -> ()
    | Some x -> printf " [%s] " x);
    (match values with
    | None -> ()
    | Some x -> printf (f_"Choose ... etc ..));
    let value = read_line () in
    ...

I don't think you need to flush the channel because stdout is line
buffered, and read_line will flush stdout anyway.
> +      if not (Str.string_match (Str.regexp "[a-zA-Z0-9-_.]+") id
0) then (
It's not wrong to use Str, but you might want to use PCRE instead (see
common/mlpcre) since Perl regexps are more familiar for most people.
This could be written as:

    let re_valid_id = PCRE.compile ~anchored:true "[-a-zA-Z0-9_.]+"

    ...

    if not (PCRE.matches re_valid_id id) then (
      etc.

Note that Str regexps are anchored by default but PCRE regexps are not.
> +        warning (f_"Allowed characters are letters, digits, - _ and
.");
> +        ask_id default
> +      ) else
> +        id in
> +
> +  let rec ask_arch guess > +    let arches = [ "x86_64";
"aarch64"; "armv7l"; "i686"; "ppc64";
"ppc64le"; "s390x" ] in
> +    match (ask (s_"Architecture: ") ~default:guess
~values:arches) with
> +    | None -> ask_arch guess
> +    | Some x ->
> +      if x = "" then
> +        ask_arch guess
It seems as if the ‘ask’ function returns ‘default’ if the user just
hits return already.
> +  let extract_entry_data ?entry () > +    message (f_"Extracting
data from the image...");
> +    let g = new Guestfs.guestfs () in
Use open_guestfs from Tools_utils instead of this line.
> +    let printable_name > +      match entry with
> +      | Some (_, { Index.printable_name = printable_name }) ->
You can just write this with the same meaning:

      | Some (_, { Index.printable_name }) ->
> +    (id, { Index.printable_name = printable_name;
> +           osinfo = osinfo;
> +           file_uri = Filename.basename out_path;
              [etc]

This can be written more concisely as:

    (id, { Index.printable_name;
           osinfo;
           file_uri = Filename.basename out_path;
           arch;
           signature_uri = None;
           checksums = Some [checksum];
           revision;
           [etc]
> +  let _, { Index.checksums = checksums } = file_entry in
This can be written as:

  let _, { Index.checksums } = file_entry in
> +  let images > +    let is_supported_format file > +      let
extension = last_part_of file '.' in
> +      match extension with
> +      | Some ext -> List.mem ext [ "qcow2"; "raw";
"img" ]
> +      | None ->
> +        match (get_mime_type file) with
You don't need parens here.
> +        | None -> false
> +        | Some mime -> mime = "application/octet-stream" in
> +    let is_new file > +      try
> +        let _, { Index.checksums = checksums } 
You can now write this as:

    let _, { Index.checksums } 
> +          List.find (
> +            fun (_, { Index.file_uri = file_uri }) ->
and:

      fun (_, { Index.file_uri }) ->
> +    List.filter (
> +      fun file ->
> +        if is_supported_format (cmdline.repo // file) then
> +          is_new file
> +        else
> +          false
How about:

  List.filter (
    fun file -> is_supported_format (cmdline.repo // file) && is_new
file
  ) files
> +  let index_channel = open_out outindex_path in
Be nice to use with_open_out here, if that patch was upstream.

Pino ^ ?
> +  (* Filter out entries for newly found images and entries
> +     without a corresponding image file or with empty arch *)
> +  let index = List.filter (
> +    fun (id, { Index.arch = arch;
> +               Index.file_uri = file_uri }) ->
You can write:

   fun (id, { Index.arch; Index.file_uri }) ->
> +      not (has_entry id arch images_entries) && Sys.file_exists
file_uri
> +  ) index in
> +
> +  (* Convert all URIs back to relative ones *)
> +  let index = List.map (
> +    fun (id, entry) ->
> +      let { Index.file_uri = file_uri } = entry in
     let { Index.file_uri } = entry in
> +    (* Remove the index file since we have the signed version of it *)
> +    if not cmdline.keep_unsigned then
> +      Sys.remove (tmprepo // "index")
We normally keep the index files even if we have a signed version.

Not sure which is better actually.  Maybe we should delete them.
> diff --git a/builder/test-virt-builder-repository.sh
b/builder/test-virt-builder-repository.sh
> new file mode 100755
> index 000000000..5ff270bcc
> --- /dev/null
> +++ b/builder/test-virt-builder-repository.sh
> @@ -0,0 +1,98 @@
> +#!/bin/bash -
> +# libguestfs
> +# Copyright (C) 2017 SUSE 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
> +slow_test
> +skip_if_skipped "$script"
> +
> +test_data=repository-testdata
> +rm -rf $test_data
> +mkdir $test_data
> +
> +# Make a copy of the Fedora image
> +cp ../test-data/phony-guests/fedora.img $test_data
> +
> +# Create minimal index file
> +cat > $test_data/index << EOF
> +[fedora]
> +file=fedora.img
> +EOF
> +
> +# Run virt-builder-repository (no compression, interactive)
> +echo 'x86_64
> +Fedora Test Image
> +fedora14
> +/dev/sda1
> +/dev/VG/Root
> +' | virt-builder-repository -v -x --no-compression -i $test_data
> +
> +assert_config () {
> +    item=$1
> +    regex=$2
> +
> +    sed -n -e "/\[$item]/,/^$/p" $test_data/index | grep
"$regex"
> +}
> +
> +# Check the generated index file
> +assert_config 'fedora' 'revision=1'
> +assert_config 'fedora' 'arch=x86_64'
> +assert_config 'fedora' 'name=Fedora Test Image'
> +assert_config 'fedora' 'osinfo=fedora14'
> +assert_config 'fedora' 'checksum'
> +assert_config 'fedora' 'format=raw'
> +assert_config 'fedora' '^size='
> +assert_config 'fedora' 'compressed_size='
> +assert_config 'fedora' 'expand=/dev/'
> +
> +
> +# Copy the debian image and add the minimal piece to index
> +cp ../test-data/phony-guests/debian.img $test_data
> +
> +cat >> $test_data/index << EOF
> +
> +[debian]
> +file=debian.img
> +EOF
> +
> +# Run virt-builder-repository again
> +echo 'x86_64
> +Debian Test Image
> +debian9
> +
> +' | virt-builder-repository --no-compression -i $test_data
> +
> +# Check that the new image is complete and the first one hasn't
changed
> +assert_config 'fedora' 'revision=1'
> +
> +assert_config 'debian' 'revision=1'
> +assert_config 'debian' 'checksum'
> +
> +# Modify the fedora image
> +export EDITOR='echo newline >>'
> +virt-edit -a $test_data/fedora.img /etc/test3
> +
> +# Rerun the tool (with compression)
> +virt-builder-repository -i $test_data
> +
> +# Check that the revision, file and size have been updated
> +assert_config 'fedora' 'revision=2'
> +assert_config 'fedora' 'file=fedora.img.xz'
> +test -e $test_data/fedora.img.xz
> +! test -e $test_data/fedora.img
The test should ‘rm’ any temporary files it created after a successful
run (but not on error paths).
> --- a/builder/utils.mli
> +++ b/builder/utils.mli
> @@ -32,3 +32,6 @@ val string_of_revision : revision -> string
>  val get_image_infos : string -> Yajl.yajl_val
>  (** [get_image_infos path] Run qemu-img info on the image pointed at
>      path as YAJL tree. *)
> +
> +val increment_revision : revision -> revision
> +(** Add one to the version number *)
s/version/revision/



Looks good in general.

Rich.

-- 
Richard Jones, Virtualization Group, Red Hat http://people.redhat.com/~rjones
Read my programming and virtualization blog: http://rwmj.wordpress.com
Fedora Windows cross-compiler. Compile Windows programs, test, and
build Windows installers. Over 100 libraries supported.
http://fedoraproject.org/wiki/MinGW