Libguestfs - Mar 2014 - Re: [supermin 3/3] Use the file tuple up to the point where files are copied into the filesystem / chroot

---
 src/build.ml  | 43 ++++++++++++++++++++++++++-----------------
 src/chroot.ml | 12 +++++++-----
 src/dpkg.ml   | 17 +++++++++++++++--
 src/ext2.ml   |  8 +++++++-
 4 files changed, 55 insertions(+), 25 deletions(-)

diff --git a/src/build.ml b/src/build.ml
index 9225184..205701b 100644
--- a/src/build.ml
+++ b/src/build.ml
@@ -106,11 +106,7 @@ let rec build debug
    *)
   let files = get_all_files packages in
   let files -    filter_map (
-      function
-      | { ft_config = false; ft_path = path } -> Some path
-      | { ft_config = true } -> None
-    ) files in
+    List.filter (fun file -> not file.ft_config) files in
 
   if debug >= 1 then
     printf "supermin: build: %d files\n%!" (List.length files);
@@ -120,9 +116,11 @@ let rec build debug
    *)
   let files      List.filter (
-      fun path ->
-        try ignore (lstat path); true
-        with Unix_error (err, fn, _) -> false
+      fun file ->
+        try ignore (lstat file.ft_source_path); true
+        with Unix_error (err, fn, _) ->
+          try ignore (lstat file.ft_path); true
+          with Unix_error (err, fn, _) -> false
     ) files in
 
   if debug >= 1 then
@@ -139,9 +137,9 @@ let rec build debug
     else (
       let fn_flags = [FNM_NOESCAPE] in
       List.filter (
-        fun path ->
+        fun file ->
           List.for_all (
-            fun pattern -> not (fnmatch pattern path fn_flags)
+            fun pattern -> not (fnmatch pattern file.ft_path fn_flags)
           ) appliance.excludefiles
       ) files
     ) in
@@ -159,7 +157,9 @@ let rec build debug
       ) appliance.hostfiles in
       let hostfiles = List.map Array.to_list hostfiles in
       let hostfiles = List.flatten hostfiles in
-      files @ hostfiles
+      files @ (List.map
+                 (fun path -> {ft_path = path; ft_source_path = path;
ft_config = false})
+                 hostfiles)
     ) in
 
   if debug >= 1 then
@@ -326,7 +326,9 @@ and isalnum = function
  * symlink.
  *)
 and munge files -  let files = List.sort compare files in
+  let paths +    List.sort compare
+      (List.map (fun file -> file.ft_path) files) in
 
   let rec stat_is_dir dir      try (stat dir).st_kind = S_DIR with Unix_error _
-> false
@@ -336,7 +338,7 @@ and munge files    in
 
   let insert_dir, dir_seen -    let h = Hashtbl.create (List.length files) in
+    let h = Hashtbl.create (List.length paths) in
     let insert_dir dir = Hashtbl.replace h dir true in
     let dir_seen dir = Hashtbl.mem h dir in
     insert_dir, dir_seen
@@ -385,10 +387,17 @@ and munge files        (* Have we seen this parent
directory before? *)
       let dir = Filename.dirname file in
       if not (dir_seen dir) then
-        loop (dir :: file :: rest)
+        loop (dir :: rest)
       else
-        file :: loop rest
+        loop rest
   in
-  let files = loop files in
+  let dir_paths = loop paths in
+
+  let dirs = List.map (fun path ->
+    {ft_path = path; ft_source_path = path; ft_config = false}
+  ) dir_paths in
+  let files = List.filter (fun file ->
+    not (dir_seen file.ft_path)
+  ) files in
 
-  files
+  dirs @ files
diff --git a/src/chroot.ml b/src/chroot.ml
index 1e1ddb2..b5c1e53 100644
--- a/src/chroot.ml
+++ b/src/chroot.ml
@@ -20,13 +20,15 @@ open Unix
 open Printf
 
 open Utils
+open Package_handler
 
 let build_chroot debug files outputdir    List.iter (
-    fun path ->
+    fun file ->
       try
+        let path = file.ft_source_path in
         let st = lstat path in
-        let opath = outputdir // path in
+        let opath = outputdir // file.ft_path in
         match st.st_kind with
         | S_DIR ->
           (* Note we fix up the permissions of directories in a second
@@ -65,9 +67,9 @@ let build_chroot debug files outputdir  
   (* Second pass: fix up directory permissions in reverse. *)
   let dirs = filter_map (
-    fun path ->
-      let st = lstat path in
-      if st.st_kind = S_DIR then Some (path, st) else None
+    fun file ->
+      let st = lstat file.ft_source_path in
+      if st.st_kind = S_DIR then Some (file.ft_path, st) else None
   ) files in
   List.iter (
     fun (path, st) ->
diff --git a/src/dpkg.ml b/src/dpkg.ml
index 5a650b8..efc8123 100644
--- a/src/dpkg.ml
+++ b/src/dpkg.ml
@@ -155,6 +155,17 @@ let dpkg_get_all_requires pkgs    loop pkgs
 
 let dpkg_get_all_files pkgs +  let cmd = sprintf "%s --list"
Config.dpkg_divert in
+  let lines = run_command_get_lines cmd in
+  let diversions = Hashtbl.create (List.length lines) in
+  List.iter (
+    fun line ->
+    let items = string_split " " line in
+    match items with
+    | ["diversion"; "of"; path; "to"; real_path;
"by"; pkg] ->
+      Hashtbl.add diversions path real_path
+    | _ -> ()
+  ) lines;
   let cmd      sprintf "%s --listfiles %s | grep '^/' | grep -v
'^/.$' | sort -u"
       Config.dpkg_query
@@ -166,8 +177,10 @@ let dpkg_get_all_files pkgs        let config  	try
string_prefix "/etc/" path && (lstat path).st_kind = S_REG
 	with Unix_error _ -> false in
-      let cmd = sprintf "%s --truename %s" Config.dpkg_divert path in
-      { ft_path = path; ft_source_path = path; ft_config = config }
+      let source_path +        try Hashtbl.find diversions path
+        with Not_found -> path in
+      { ft_path = path; ft_source_path = source_path; ft_config = config }
   ) lines
 
 let dpkg_download_all_packages pkgs dir diff --git a/src/ext2.ml b/src/ext2.ml
index 701f52e..ccaa81f 100644
--- a/src/ext2.ml
+++ b/src/ext2.ml
@@ -21,6 +21,7 @@ open Printf
 
 open Utils
 open Ext2fs
+open Package_handler
 
 (* The ext2 image that we build always has a fixed size, and we 'hope'
  * that the files fit in (otherwise we'll get an error).  Note that
@@ -66,7 +67,12 @@ let build_ext2 debug basedir files modpath kernel_version
appliance      printf "supermin: ext2: copying files from host
filesystem\n%!";
 
   (* Copy files from host filesystem. *)
-  List.iter (fun path -> ext2fs_copy_file_from_host fs path path) files;
+  List.iter (fun file ->
+    if file_exists file.ft_source_path then
+      ext2fs_copy_file_from_host fs file.ft_source_path file.ft_path
+    else
+      ext2fs_copy_file_from_host fs file.ft_path file.ft_path
+  ) files;
 
   if debug >= 1 then
     printf "supermin: ext2: copying kernel modules\n%!";
-- 
1.9.0

On Mon, Mar 10, 2014 at 11:33:51AM +0100, Hilko Bengen
wrote:
>  and munge files > -  let files = List.sort compare files in
> +  let paths > +    List.sort compare
> +      (List.map (fun file -> file.ft_path) files) in
>  
>    let rec stat_is_dir dir >      try (stat dir).st_kind = S_DIR with
Unix_error _ -> false
> @@ -336,7 +338,7 @@ and munge files >    in
>  
>    let insert_dir, dir_seen > -    let h = Hashtbl.create (List.length
files) in
> +    let h = Hashtbl.create (List.length paths) in
>      let insert_dir dir = Hashtbl.replace h dir true in
>      let dir_seen dir = Hashtbl.mem h dir in
>      insert_dir, dir_seen
> @@ -385,10 +387,17 @@ and munge files >        (* Have we seen this
parent directory before? *)
>        let dir = Filename.dirname file in
>        if not (dir_seen dir) then
> -        loop (dir :: file :: rest)
> +        loop (dir :: rest)
Why did file get dropped from the list here?
>        else
> -        file :: loop rest
> +        loop rest
And here?
>    in
> -  let files = loop files in
> +  let dir_paths = loop paths in
> +
> +  let dirs = List.map (fun path ->
> +    {ft_path = path; ft_source_path = path; ft_config = false}
> +  ) dir_paths in
> +  let files = List.filter (fun file ->
> +    not (dir_seen file.ft_path)
> +  ) files in
>  
> -  files
> +  dirs @ files
This seems to change the result of this (very important and complex)
function.

Rich.

-- 
Richard Jones, Virtualization Group, Red Hat http://people.redhat.com/~rjones
Read my programming blog: http://rwmj.wordpress.com
Fedora now supports 80 OCaml packages (the OPEN alternative to F#)

* Richard W.M. Jones:
> This seems to change the result of this (very important and complex)
> function.
Yeah, I guess this needs some more explanation. If I understand the
original munge function correctly, it is only about reordering (and
inserting) directories and symlinks to directories so that directories
are created before any members (subdirectories or files) they contain.

This property is preserved by putting the re-ordered list of directories
in front of the unchanged list of files.

Cheers,
-Hilko

* Richard W.M. Jones:
> This seems to change the result of this (very important and complex)
> function.
Since you didn't answer my followup message, I take it that I failed to
convince you. I noticed that I can get away with leaving the structure
of the function as-is, just changing the type... What do you think about
this diff?

Cheers,
-Hilko

diff --git a/src/build.ml b/src/build.ml
index 9225184..0e2893d 100644
--- a/src/build.ml
+++ b/src/build.ml
@@ -345,21 +346,21 @@ and munge files    let rec loop = function
     | [] -> []
 
-    | "/" :: rest ->
+    | root :: rest when root.ft_path = "/" ->
       (* This is just to avoid a corner-case in subsequent rules. *)
       loop rest
 
-    | dir :: rest when stat_is_dir dir && dir_seen dir ->
+    | dir :: rest when stat_is_dir dir.ft_path && dir_seen dir.ft_path
->
       dir :: loop rest
 
-    | dir :: rest when is_lnk_to_dir dir ->
-      insert_dir dir;
+    | dir :: rest when is_lnk_to_dir dir.ft_path ->
+      insert_dir dir.ft_path;
 
       (* Symlink to a directory.  Insert the target directory before
        * if we've not seen it yet.
        *)
-      let target = readlink dir in
-      let parent = Filename.dirname dir in
+      let target = readlink dir.ft_path in
+      let parent = Filename.dirname dir.ft_path in
       (* Make the target an absolute path. *)
       let target          if String.length target < 1 || target.[0] <>
'/' then
@@ -367,24 +368,27 @@ and munge files          else
           target in
       if not (dir_seen target) then
+        let target = {ft_path = target; ft_source_path = target; ft_config =
false} in
         loop (target :: dir :: rest)
       else
         dir :: loop rest
 
-    | dir :: rest when stat_is_dir dir ->
-      insert_dir dir;
+    | dir :: rest when stat_is_dir dir.ft_path ->
+      insert_dir dir.ft_path;
 
       (* Have we seen the parent? *)
-      let parent = Filename.dirname dir in
+      let parent = Filename.dirname dir.ft_path in
       if not (dir_seen parent) then
+        let parent = {ft_path = parent; ft_source_path = parent; ft_config =
false} in
         loop (parent :: dir :: rest)
       else
         dir :: loop rest
 
     | file :: rest ->
       (* Have we seen this parent directory before? *)
-      let dir = Filename.dirname file in
+      let dir = Filename.dirname file.ft_path in
       if not (dir_seen dir) then
+        let dir = {ft_path = dir; ft_source_path = dir; ft_config = false} in
         loop (dir :: file :: rest)
       else
         file :: loop rest