febootstrap.ml

   1 (* febootstrap 3
   2  * Copyright (C) 2009-2010 Red Hat Inc.
   3  *
   4  * This program is free software; you can redistribute it and/or modify
   5  * it under the terms of the GNU General Public License as published by
   6  * the Free Software Foundation; either version 2 of the License, or
   7  * (at your option) any later version.
   8  *
   9  * This program is distributed in the hope that it will be useful,
  10  * but WITHOUT ANY WARRANTY; without even the implied warranty of
  11  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  12  * GNU General Public License for more details.
  13  *
  14  * You should have received a copy of the GNU General Public License
  15  * along with this program; if not, write to the Free Software
  16  * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
  17  *)
  18
  19 open Unix
  20 open Printf
  21
  22 open Febootstrap_package_handlers
  23 open Febootstrap_utils
  24 open Febootstrap_cmdline
  25
  26 (* Create a temporary directory for use by all the functions in this file. *)
  27 let tmpdir = tmpdir ()
  28
  29 let () =
  30   debug "%s %s" Config.package_name Config.package_version;
  31
  32   (* Instead of printing out warnings as we go along, accumulate them
  33    * in lists and print them all out at the end.
  34    *)
  35   let warn_unreadable = ref [] in
  36
  37   (* Determine which package manager this system uses. *)
  38   check_system ();
  39   let ph = get_package_handler () in
  40
  41   debug "selected package handler: %s" (get_package_handler_name ());
  42
  43   (* Not --names: check files exist. *)
  44   if not names_mode then (
  45     List.iter (
  46       fun pkg ->
  47         if not (file_exists pkg) then (
  48           eprintf "febootstrap: %s: no such file (did you miss out the --names option?)\n" pkg;
  49           exit 1
  50         )
  51     ) packages
  52   );
  53
  54   (* --names: resolve the package list to a full list of package names
  55    * (including dependencies).
  56    *)
  57   let packages =
  58     if names_mode then (
  59       let packages = ph.ph_resolve_dependencies_and_download packages in
  60       debug "resolved packages: %s" (String.concat " " packages);
  61       packages
  62     )
  63     else packages in
  64
  65   (* Get the list of files. *)
  66   let files =
  67     List.flatten (
  68       List.map (
  69         fun pkg ->
  70           let files = ph.ph_list_files pkg in
  71           List.map (fun (filename, ft) -> filename, ft, pkg) files
  72       ) packages
  73     ) in
  74
  75   (* Canonicalize the name of directories, so that /a and /a/ are the same. *)
  76   let files =
  77     List.map (
  78       fun (filename, ft, pkg) ->
  79         let len = String.length filename in
  80         let filename =
  81           if len > 1 (* don't rewrite "/" *) && ft.ft_dir
  82             && filename.[len-1] = '/' then
  83               String.sub filename 0 (len-1)
  84           else
  85             filename in
  86         (filename, ft, pkg)
  87     ) files in
  88
  89   (* Sort and combine duplicate files. *)
  90   let files =
  91     let files = List.sort compare files in
  92
  93     let combine (name1, ft1, pkg1) (name2, ft2, pkg2) =
  94       (* Rules for combining files. *)
  95       if ft1.ft_config || ft2.ft_config then (
  96         (* It's a fairly frequent bug in Fedora for two packages to
  97          * incorrectly list the same config file.  Allow this, provided
  98          * the size of both files is 0.
  99          *)
 100         if ft1.ft_size = 0 && ft2.ft_size = 0 then
 101           (name1, ft1, pkg1)
 102         else (
 103           eprintf "febootstrap: error: %s is a config file which is listed in two packages (%s, %s)\n"
 104             name1 pkg1 pkg2;
 105           exit 1
 106         )
 107       )
 108       else if (ft1.ft_dir || ft2.ft_dir) && (not (ft1.ft_dir && ft2.ft_dir)) then (
 109         eprintf "febootstrap: error: %s appears as both directory and ordinary file (%s, %s)\n"
 110           name1 pkg1 pkg2;
 111         exit 1
 112       )
 113       else if ft1.ft_ghost then
 114         (name2, ft2, pkg2)
 115       else
 116         (name1, ft1, pkg1)
 117     in
 118
 119     let rec loop = function
 120       | [] -> []
 121       | (name1, _, _ as f1) :: (name2, _, _ as f2) :: fs when name1 = name2 ->
 122           let f = combine f1 f2 in loop (f :: fs)
 123       | f :: fs -> f :: loop fs
 124     in
 125     loop files in
 126
 127   (* Because we may have excluded some packages, and also because of
 128    * distribution packaging errors, it's not necessarily true that a
 129    * directory is created before each file in that directory.
 130    * Determine those missing directories and add them now.
 131    *)
 132   let files =
 133     let insert_dir, dir_seen =
 134       let h = Hashtbl.create (List.length files) in
 135       let insert_dir dir = Hashtbl.replace h dir true in
 136       let dir_seen dir = Hashtbl.mem h dir in
 137       insert_dir, dir_seen
 138     in
 139     let files =
 140       List.map (
 141         fun (path, { ft_dir = is_dir }, _ as f) ->
 142           if is_dir then
 143             insert_dir path;
 144
 145           let rec loop path =
 146             let parent = Filename.dirname path in
 147             if dir_seen parent then []
 148             else (
 149               insert_dir parent;
 150               let newdir = (parent, { ft_dir = true; ft_config = false;
 151                                       ft_ghost = false; ft_mode = 0o40755;
 152                                       ft_size = 0 },
 153                             "") in
 154               newdir :: loop parent
 155             )
 156           in
 157           List.rev (f :: loop path)
 158       ) files in
 159     List.flatten files in
 160
 161   (* Debugging. *)
 162   debug "%d files and directories" (List.length files);
 163   if false then (
 164     List.iter (
 165       fun (name, { ft_dir = dir; ft_ghost = ghost; ft_config = config;
 166                    ft_mode = mode; ft_size = size }, pkg) ->
 167         printf "%s [%s%s%s%o %d] from %s\n" name
 168           (if dir then "dir " else "")
 169           (if ghost then "ghost " else "")
 170           (if config then "config " else "")
 171           mode size
 172           pkg
 173     ) files
 174   );
 175
 176   (* Split the list of files into ones for hostfiles and ones for base image. *)
 177   let p_hmac = Str.regexp "^\\..*\\.hmac$" in
 178
 179   let hostfiles = ref []
 180   and baseimgfiles = ref [] in
 181   List.iter (
 182     fun (path, {ft_dir = dir; ft_ghost = ghost; ft_config = config} ,_ as f) ->
 183       let file = Filename.basename path in
 184
 185       (* Ignore boot files, kernel, kernel modules.  Supermin appliances
 186        * are booted from external kernel and initrd, and
 187        * febootstrap-supermin-helper copies the host kernel modules.
 188        * Note we want to keep the /boot and /lib/modules directory entries.
 189        *)
 190       if string_prefix "/boot/" path then ()
 191       else if string_prefix "/lib/modules/" path then ()
 192
 193       (* Always write directory names to both output files. *)
 194       else if dir then (
 195         hostfiles := f :: !hostfiles;
 196         baseimgfiles := f :: !baseimgfiles;
 197       )
 198
 199       (* Timezone configuration is config, but copy it from host system. *)
 200       else if path = "/etc/localtime" then
 201         hostfiles := f :: !hostfiles
 202
 203       (* Ignore FIPS files (.*.hmac) (RHBZ#654638). *)
 204       else if Str.string_match p_hmac file 0 then ()
 205
 206       (* Ghost files are created empty in the base image. *)
 207       else if ghost then
 208         baseimgfiles := f :: !baseimgfiles
 209
 210       (* For config files we can't rely on the host-installed copy
 211        * since the admin may have modified then.  We have to get the
 212        * original file from the package and put it in the base image.
 213        *)
 214       else if config then
 215         baseimgfiles := f :: !baseimgfiles
 216
 217       (* Anything else comes from the host. *)
 218       else
 219         hostfiles := f :: !hostfiles
 220   ) files;
 221   let hostfiles = List.rev !hostfiles
 222   and baseimgfiles = List.rev !baseimgfiles in
 223
 224   (* Write hostfiles. *)
 225
 226   (* Regexps used below. *)
 227   let p_ld_so = Str.regexp "^ld-[.0-9]+\\.so$" in
 228   let p_libbfd = Str.regexp "^libbfd-.*\\.so$" in
 229   let p_libgcc = Str.regexp "^libgcc_s-.*\\.so\\.\\([0-9]+\\)$" in
 230   let p_libntfs3g = Str.regexp "^libntfs-3g\\.so\\..*$" in
 231   let p_lib123so = Str.regexp "^lib\\(.*\\)-[-.0-9]+\\.so$" in
 232   let p_lib123so123 =
 233     Str.regexp "^lib\\(.*\\)-[-.0-9]+\\.so\\.\\([0-9]+\\)\\." in
 234   let p_libso123 = Str.regexp "^lib\\(.*\\)\\.so\\.\\([0-9]+\\)\\." in
 235   let ntfs3g_once = ref false in
 236
 237   let chan = open_out (tmpdir // "hostfiles") in
 238   List.iter (
 239     fun (path, {ft_dir = is_dir; ft_ghost = ghost; ft_config = config;
 240                 ft_mode = mode }, _) ->
 241       let dir = Filename.dirname path in
 242       let file = Filename.basename path in
 243
 244       if is_dir then
 245         fprintf chan "%s\n" path
 246
 247       (* Warn about hostfiles which are unreadable by non-root.  We
 248        * won't be able to add those to the appliance at run time, but
 249        * there's not much else we can do about it except get the
 250        * distros to fix this nonsense.
 251        *)
 252       else if mode land 0o004 = 0 then
 253         warn_unreadable := path :: !warn_unreadable
 254
 255       (* Replace fixed numbers in some library names by wildcards. *)
 256       else if Str.string_match p_ld_so file 0 then
 257         fprintf chan "%s/ld-*.so\n" dir
 258
 259       (* Special case for libbfd. *)
 260       else if Str.string_match p_libbfd file 0 then
 261         fprintf chan "%s/libbfd-*.so\n" dir
 262
 263       (* Special case for libgcc_s-<gccversion>-<date>.so.N *)
 264       else if Str.string_match p_libgcc file 0 then
 265         fprintf chan "%s/libgcc_s-*.so.%s\n" dir (Str.matched_group 1 file)
 266
 267       (* Special case for libntfs-3g.so.* *)
 268       else if Str.string_match p_libntfs3g file 0 then (
 269         if not !ntfs3g_once then (
 270           fprintf chan "%s/libntfs-3g.so.*\n" dir;
 271           ntfs3g_once := true
 272         )
 273       )
 274
 275       (* libfoo-1.2.3.so *)
 276       else if Str.string_match p_lib123so file 0 then
 277         fprintf chan "%s/lib%s-*.so\n" dir (Str.matched_group 1 file)
 278
 279       (* libfoo-1.2.3.so.123 (but NOT '*.so.N') *)
 280       else if Str.string_match p_lib123so123 file 0 then
 281         fprintf chan "%s/lib%s-*.so.%s.*\n" dir
 282           (Str.matched_group 1 file) (Str.matched_group 2 file)
 283
 284       (* libfoo.so.1.2.3 (but NOT '*.so.N') *)
 285       else if Str.string_match p_libso123 file 0 then
 286         fprintf chan "%s/lib%s.so.%s.*\n" dir
 287           (Str.matched_group 1 file) (Str.matched_group 2 file)
 288
 289       (* Anything else comes from the host. *)
 290       else
 291         fprintf chan "%s\n" path
 292   ) hostfiles;
 293   close_out chan;
 294
 295   (* Write base.img.
 296    *
 297    * We have to create directories and copy files to tmpdir/root
 298    * and then call out to cpio to construct the initrd.
 299    *)
 300   let rootdir = tmpdir // "root" in
 301   mkdir rootdir 0o755;
 302   List.iter (
 303     fun (path, { ft_dir = is_dir; ft_ghost = ghost; ft_config = config;
 304                  ft_mode = mode }, pkg) ->
 305       (* Always write directory names to both output files. *)
 306       if is_dir then (
 307         (* Directory permissions are fixed up below. *)
 308         if path <> "/" then mkdir (rootdir // path) 0o755
 309       )
 310
 311       (* Ghost files are just touched with the correct perms. *)
 312       else if ghost then (
 313         let chan = open_out (rootdir // path) in
 314         close_out chan;
 315         chmod (rootdir // path) (mode land 0o777 lor 0o400)
 316       )
 317
 318       (* For config files we can't rely on the host-installed copy
 319        * since the admin may have modified it.  We have to get the
 320        * original file from the package.
 321        *)
 322       else if config then (
 323         let outfile = ph.ph_get_file_from_package pkg path in
 324
 325         (* Note that the output config file might not be a regular file. *)
 326         let statbuf = lstat outfile in
 327
 328         let destfile = rootdir // path in
 329
 330         (* Depending on the file type, copy it to destination. *)
 331         match statbuf.st_kind with
 332         | S_REG ->
 333             (* Unreadable files (eg. /etc/gshadow).  Make readable. *)
 334             if statbuf.st_perm = 0 then chmod outfile 0o400;
 335             let cmd =
 336               sprintf "cp %s %s"
 337                 (Filename.quote outfile) (Filename.quote destfile) in
 338             run_command cmd;
 339             chmod destfile (mode land 0o777 lor 0o400)
 340         | S_LNK ->
 341             let link = readlink outfile in
 342             symlink link destfile
 343         | S_DIR -> assert false
 344         | S_CHR
 345         | S_BLK
 346         | S_FIFO
 347         | S_SOCK ->
 348             eprintf "febootstrap: error: %s: don't know how to handle this type of file\n" path;
 349             exit 1
 350       )
 351
 352       else
 353         assert false (* should not be reached *)
 354   ) baseimgfiles;
 355
 356   (* Fix up directory permissions, in reverse order.  Since we don't
 357    * want to have a read-only directory that we can't write into above.
 358    *)
 359   List.iter (
 360     fun (path, { ft_dir = is_dir; ft_mode = mode }, _) ->
 361       if is_dir then chmod (rootdir // path) (mode land 0o777 lor 0o700)
 362   ) (List.rev baseimgfiles);
 363
 364   (* Construct the 'base.img' initramfs.  Feed in the list of filenames
 365    * partly because we conveniently have them, and partly because
 366    * this results in a nice alphabetical ordering in the cpio file.
 367    *)
 368   (*let cmd = sprintf "ls -lR %s" rootdir in
 369   ignore (Sys.command cmd);*)
 370   let cmd =
 371     sprintf "(cd %s && cpio --quiet -o -0 -H newc) > %s"
 372       rootdir (tmpdir // "base.img") in
 373   let chan = open_process_out cmd in
 374   List.iter (fun (path, _, _) -> fprintf chan ".%s\000" path) baseimgfiles;
 375   let stat = close_process_out chan in
 376   (match stat with
 377    | WEXITED 0 -> ()
 378    | WEXITED i ->
 379        eprintf "febootstrap: command '%s' failed (returned %d), see earlier error messages\n" cmd i;
 380        exit i
 381    | WSIGNALED i ->
 382        eprintf "febootstrap: command '%s' killed by signal %d" cmd i;
 383        exit 1
 384    | WSTOPPED i ->
 385        eprintf "febootstrap: command '%s' stopped by signal %d" cmd i;
 386        exit 1
 387   );
 388
 389   (* Undo directory permissions, because rm -rf can't delete files in
 390    * unreadable directories.
 391    *)
 392   List.iter (
 393     fun (path, { ft_dir = is_dir; ft_mode = mode }, _) ->
 394       if is_dir then chmod (rootdir // path) 0o755
 395   ) (List.rev baseimgfiles);
 396
 397   (* Print warnings. *)
 398   if warnings then (
 399     (match !warn_unreadable with
 400      | [] -> ()
 401      | paths ->
 402          eprintf "febootstrap: warning: some host files are unreadable by non-root\n";
 403          eprintf "febootstrap: warning: get your distro to fix these files:\n";
 404          List.iter
 405            (fun path -> eprintf "\t%s\n%!" path)
 406            (List.sort compare paths)
 407     );
 408   );
 409
 410   (* Near-atomically copy files to the final output directory. *)
 411   debug "writing %s ..." (outputdir // "base.img");
 412   let cmd =
 413     sprintf "mv %s %s"
 414       (Filename.quote (tmpdir // "base.img"))
 415       (Filename.quote (outputdir // "base.img")) in
 416   run_command cmd;
 417   debug "writing %s ..." (outputdir // "hostfiles");
 418   let cmd =
 419     sprintf "mv %s %s"
 420       (Filename.quote (tmpdir // "hostfiles"))
 421       (Filename.quote (outputdir // "hostfiles")) in
 422   run_command cmd