Merge branch 'master' into core-updates

1 files changed, 273 insertions, 187 deletions

diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm
index 13aa8923cd..6c6680ab58 100644
--- a/guix/scripts/pack.scm
+++ b/guix/scripts/pack.scm
@@ -3,6 +3,7 @@
 ;;; Copyright © 2017, 2018 Ricardo Wurmus <rekado@elephly.net>
 ;;; Copyright © 2018 Konrad Hinsen <konrad.hinsen@fastmail.net>
 ;;; Copyright © 2018 Chris Marusich <cmmarusich@gmail.com>
+;;; Copyright © 2018 Efraim Flashner <efraim@flashner.co.il>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -38,7 +39,7 @@
   #:use-module ((guix self) #:select (make-config.scm))
   #:use-module (gnu packages)
   #:use-module (gnu packages bootstrap)
-  #:use-module (gnu packages compression)
+  #:use-module ((gnu packages compression) #:hide (zip))
   #:use-module (gnu packages guile)
   #:use-module (gnu packages base)
   #:autoload   (gnu packages package-management) (guix)
@@ -52,6 +53,9 @@
   #:export (compressor?
             lookup-compressor
             self-contained-tarball
+            docker-image
+            squashfs-image
+
             guix-pack))
 
 ;; Type of a compression tool.
@@ -103,8 +107,50 @@ found."
                       (package-transitive-propagated-inputs package)))
               (list guile-gcrypt guile-sqlite3)))
 
+(define (store-database items)
+  "Return a directory containing a store database where all of ITEMS and their
+dependencies are registered."
+  (define schema
+    (local-file (search-path %load-path
+                             "guix/store/schema.sql")))
+
+
+  (define labels
+    (map (lambda (n)
+           (string-append "closure" (number->string n)))
+         (iota (length items))))
+
+  (define build
+    (with-extensions gcrypt-sqlite3&co
+      ;; XXX: Adding (gnu build install) just to work around
+      ;; <https://bugs.gnu.org/15602>: that way, (guix build store-copy) is
+      ;; copied last and the 'store-info-XXX' macros are correctly expanded.
+      (with-imported-modules (source-module-closure
+                              '((guix build store-copy)
+                                (guix store database)
+                                (gnu build install)))
+        #~(begin
+            (use-modules (guix store database)
+                         (guix build store-copy)
+                         (srfi srfi-1))
+
+            (define (read-closure closure)
+              (call-with-input-file closure read-reference-graph))
+
+            (let ((items (append-map read-closure '#$labels)))
+              (register-items items
+                              #:state-directory #$output
+                              #:deduplicate? #f
+                              #:reset-timestamps? #f
+                              #:registration-time %epoch
+                              #:schema #$schema))))))
+
+  (computed-file "store-database" build
+                 #:options `(#:references-graphs ,(zip labels items))))
+
 (define* (self-contained-tarball name profile
                                  #:key target
+                                 (profile-name "guix-profile")
                                  deduplicate?
                                  (compressor (first %compressors))
                                  localstatedir?
@@ -117,125 +163,117 @@ with a properly initialized store database.
 
 SYMLINKS must be a list of (SOURCE -> TARGET) tuples denoting symlinks to be
 added to the pack."
-  (define libgcrypt
-    (module-ref (resolve-interface '(gnu packages gnupg))
-                'libgcrypt))
-
-  (define schema
+  (define database
     (and localstatedir?
-         (local-file (search-path %load-path
-                                  "guix/store/schema.sql"))))
+         (file-append (store-database (list profile))
+                      "/db/db.sqlite")))
 
   (define build
-    (with-imported-modules `(((guix config) => ,(make-config.scm))
-                             ,@(source-module-closure
-                                `((guix build utils)
-                                  (guix build union)
-                                  (guix build store-copy)
-                                  (gnu build install))
-                                #:select? not-config?))
-      (with-extensions gcrypt-sqlite3&co
-        #~(begin
-            (use-modules (guix build utils)
-                         ((guix build union) #:select (relative-file-name))
-                         (gnu build install)
-                         (srfi srfi-1)
-                         (srfi srfi-26)
-                         (ice-9 match))
-
-            (define %root "root")
-
-            (define symlink->directives
-              ;; Return "populate directives" to make the given symlink and its
-              ;; parent directories.
-              (match-lambda
-                ((source '-> target)
-                 (let ((target (string-append #$profile "/" target))
-                       (parent (dirname source)))
-                   ;; Never add a 'directory' directive for "/" so as to
-                   ;; preserve its ownnership when extracting the archive (see
-                   ;; below), and also because this would lead to adding the
-                   ;; same entries twice in the tarball.
-                   `(,@(if (string=? parent "/")
-                           '()
-                           `((directory ,parent)))
-                     (,source
-                      -> ,(relative-file-name parent target)))))))
-
-            (define directives
-              ;; Fully-qualified symlinks.
-              (append-map symlink->directives '#$symlinks))
-
-            ;; The --sort option was added to GNU tar in version 1.28, released
-            ;; 2014-07-28.  For testing, we use the bootstrap tar, which is
-            ;; older and doesn't support it.
-            (define tar-supports-sort?
-              (zero? (system* (string-append #+archiver "/bin/tar")
-                              "cf" "/dev/null" "--files-from=/dev/null"
-                              "--sort=name")))
-
-            ;; Add 'tar' to the search path.
-            (setenv "PATH" #+(file-append archiver "/bin"))
-
-            ;; Note: there is not much to gain here with deduplication and there
-            ;; is the overhead of the '.links' directory, so turn it off.
-            ;; Furthermore GNU tar < 1.30 sometimes fails to extract tarballs
-            ;; with hard links:
-            ;; <http://lists.gnu.org/archive/html/bug-tar/2017-11/msg00009.html>.
-            (populate-single-profile-directory %root
-                                               #:profile #$profile
-                                               #:closure "profile"
-                                               #:deduplicate? #f
-                                               #:register? #$localstatedir?
-                                               #:schema #$schema)
-
-            ;; Create SYMLINKS.
-            (for-each (cut evaluate-populate-directive <> %root)
-                      directives)
-
-            ;; Create the tarball.  Use GNU format so there's no file name
-            ;; length limitation.
-            (with-directory-excursion %root
-              (exit
-               (zero? (apply system* "tar"
-                             #+@(if (compressor-command compressor)
-                                    #~("-I"
-                                       (string-join
-                                        '#+(compressor-command compressor)))
-                                    #~())
-                             "--format=gnu"
-
-                             ;; Avoid non-determinism in the archive.  Use
-                             ;; mtime = 1, not zero, because that is what the
-                             ;; daemon does for files in the store (see the
-                             ;; 'mtimeStore' constant in local-store.cc.)
-                             (if tar-supports-sort? "--sort=name" "--mtime=@1")
-                             "--mtime=@1"         ;for files in /var/guix
-                             "--owner=root:0"
-                             "--group=root:0"
-
-                             "--check-links"
-                             "-cvf" #$output
-                             ;; Avoid adding / and /var to the tarball, so
-                             ;; that the ownership and permissions of those
-                             ;; directories will not be overwritten when
-                             ;; extracting the archive.  Do not include /root
-                             ;; because the root account might have a
-                             ;; different home directory.
-                             #$@(if localstatedir?
-                                    '("./var/guix")
-                                    '())
-
-                             (string-append "." (%store-directory))
-
-                             (delete-duplicates
-                              (filter-map (match-lambda
-                                            (('directory directory)
-                                             (string-append "." directory))
-                                            ((source '-> _)
-                                             (string-append "." source))
-                                            (_ #f))
-                                          directives))))))))))
+    (with-imported-modules (source-module-closure
+                            `((guix build utils)
+                              (guix build union)
+                              (gnu build install))
+                            #:select? not-config?)
+      #~(begin
+          (use-modules (guix build utils)
+                       ((guix build union) #:select (relative-file-name))
+                       (gnu build install)
+                       (srfi srfi-1)
+                       (srfi srfi-26)
+                       (ice-9 match))
+
+          (define %root "root")
+
+          (define symlink->directives
+            ;; Return "populate directives" to make the given symlink and its
+            ;; parent directories.
+            (match-lambda
+              ((source '-> target)
+               (let ((target (string-append #$profile "/" target))
+                     (parent (dirname source)))
+                 ;; Never add a 'directory' directive for "/" so as to
+                 ;; preserve its ownnership when extracting the archive (see
+                 ;; below), and also because this would lead to adding the
+                 ;; same entries twice in the tarball.
+                 `(,@(if (string=? parent "/")
+                         '()
+                         `((directory ,parent)))
+                   (,source
+                    -> ,(relative-file-name parent target)))))))
+
+          (define directives
+            ;; Fully-qualified symlinks.
+            (append-map symlink->directives '#$symlinks))
+
+          ;; The --sort option was added to GNU tar in version 1.28, released
+          ;; 2014-07-28.  For testing, we use the bootstrap tar, which is
+          ;; older and doesn't support it.
+          (define tar-supports-sort?
+            (zero? (system* (string-append #+archiver "/bin/tar")
+                            "cf" "/dev/null" "--files-from=/dev/null"
+                            "--sort=name")))
+
+          ;; Add 'tar' to the search path.
+          (setenv "PATH" #+(file-append archiver "/bin"))
+
+          ;; Note: there is not much to gain here with deduplication and there
+          ;; is the overhead of the '.links' directory, so turn it off.
+          ;; Furthermore GNU tar < 1.30 sometimes fails to extract tarballs
+          ;; with hard links:
+          ;; <http://lists.gnu.org/archive/html/bug-tar/2017-11/msg00009.html>.
+          (populate-single-profile-directory %root
+                                             #:profile #$profile
+                                             #:profile-name #$profile-name
+                                             #:closure "profile"
+                                             #:database #+database)
+
+          ;; Create SYMLINKS.
+          (for-each (cut evaluate-populate-directive <> %root)
+                    directives)
+
+          ;; Create the tarball.  Use GNU format so there's no file name
+          ;; length limitation.
+          (with-directory-excursion %root
+            (exit
+             (zero? (apply system* "tar"
+                           #+@(if (compressor-command compressor)
+                                  #~("-I"
+                                     (string-join
+                                      '#+(compressor-command compressor)))
+                                  #~())
+                           "--format=gnu"
+
+                           ;; Avoid non-determinism in the archive.  Use
+                           ;; mtime = 1, not zero, because that is what the
+                           ;; daemon does for files in the store (see the
+                           ;; 'mtimeStore' constant in local-store.cc.)
+                           (if tar-supports-sort? "--sort=name" "--mtime=@1")
+                           "--mtime=@1"           ;for files in /var/guix
+                           "--owner=root:0"
+                           "--group=root:0"
+
+                           "--check-links"
+                           "-cvf" #$output
+                           ;; Avoid adding / and /var to the tarball, so
+                           ;; that the ownership and permissions of those
+                           ;; directories will not be overwritten when
+                           ;; extracting the archive.  Do not include /root
+                           ;; because the root account might have a
+                           ;; different home directory.
+                           #$@(if localstatedir?
+                                  '("./var/guix")
+                                  '())
+
+                           (string-append "." (%store-directory))
+
+                           (delete-duplicates
+                            (filter-map (match-lambda
+                                          (('directory directory)
+                                           (string-append "." directory))
+                                          ((source '-> _)
+                                           (string-append "." source))
+                                          (_ #f))
+                                        directives)))))))))
 
   (gexp->derivation (string-append name ".tar"
                                    (compressor-extension compressor))
@@ -244,7 +282,7 @@ added to the pack."
 
 (define* (squashfs-image name profile
                          #:key target
-                         deduplicate?
+                         (profile-name "guix-profile")
                          (compressor (first %compressors))
                          localstatedir?
                          (symlinks '())
@@ -255,75 +293,85 @@ points for virtual file systems (like procfs), and optional symlinks.
 
 SYMLINKS must be a list of (SOURCE -> TARGET) tuples denoting symlinks to be
 added to the pack."
-  (define build
-    (with-imported-modules `(((guix config) => ,(make-config.scm))
-                             ,@(source-module-closure
-                                '((guix build utils)
-                                  (guix build store-copy)
-                                  (gnu build install))
-                                #:select? not-config?))
-      (with-extensions gcrypt-sqlite3&co
-        #~(begin
-            (use-modules (guix build utils)
-                         (gnu build install)
-                         (guix build store-copy)
-                         (srfi srfi-1)
-                         (srfi srfi-26)
-                         (ice-9 match))
+  (define database
+    (and localstatedir?
+         (file-append (store-database (list profile))
+                      "/db/db.sqlite")))
 
-            (setenv "PATH" (string-append #$archiver "/bin"))
+  (define build
+    (with-imported-modules (source-module-closure
+                            '((guix build utils)
+                              (guix build store-copy)
+                              (gnu build install))
+                            #:select? not-config?)
+      #~(begin
+          (use-modules (guix build utils)
+                       (guix build store-copy)
+                       (gnu build install)
+                       (srfi srfi-1)
+                       (srfi srfi-26)
+                       (ice-9 match))
 
-            ;; We need an empty file in order to have a valid file argument when
-            ;; we reparent the root file system.  Read on for why that's
-            ;; necessary.
-            (with-output-to-file ".empty" (lambda () (display "")))
-
-            ;; Create the squashfs image in several steps.
-            ;; Add all store items.  Unfortunately mksquashfs throws away all
-            ;; ancestor directories and only keeps the basename.  We fix this
-            ;; in the following invocations of mksquashfs.
-            (apply invoke "mksquashfs"
-                   `(,@(map store-info-item
-                            (call-with-input-file "profile"
-                              read-reference-graph))
-                     ,#$output
-
-                     ;; Do not perform duplicate checking because we
-                     ;; don't have any dupes.
-                     "-no-duplicates"
-                     "-comp"
-                     ,#+(compressor-name compressor)))
-
-            ;; Here we reparent the store items.  For each sub-directory of
-            ;; the store prefix we need one invocation of "mksquashfs".
-            (for-each (lambda (dir)
-                        (apply invoke "mksquashfs"
-                               `(".empty"
-                                 ,#$output
-                                 "-root-becomes" ,dir)))
-                      (reverse (string-tokenize (%store-directory)
-                                                (char-set-complement (char-set #\/)))))
-
-            ;; Add symlinks and mount points.
-            (apply invoke "mksquashfs"
-                   `(".empty"
-                     ,#$output
-                     ;; Create SYMLINKS via pseudo file definitions.
-                     ,@(append-map
-                        (match-lambda
-                          ((source '-> target)
-                           (list "-p"
-                                 (string-join
-                                  ;; name s mode uid gid symlink
-                                  (list source
-                                        "s" "777" "0" "0"
-                                        (string-append #$profile "/" target))))))
-                        '#$symlinks)
-
-                     ;; Create empty mount points.
-                     "-p" "/proc d 555 0 0"
-                     "-p" "/sys d 555 0 0"
-                     "-p" "/dev d 555 0 0"))))))
+          (define database #+database)
+
+          (setenv "PATH" (string-append #$archiver "/bin"))
+
+          ;; We need an empty file in order to have a valid file argument when
+          ;; we reparent the root file system.  Read on for why that's
+          ;; necessary.
+          (with-output-to-file ".empty" (lambda () (display "")))
+
+          ;; Create the squashfs image in several steps.
+          ;; Add all store items.  Unfortunately mksquashfs throws away all
+          ;; ancestor directories and only keeps the basename.  We fix this
+          ;; in the following invocations of mksquashfs.
+          (apply invoke "mksquashfs"
+                 `(,@(map store-info-item
+                          (call-with-input-file "profile"
+                            read-reference-graph))
+                   ,#$output
+
+                   ;; Do not perform duplicate checking because we
+                   ;; don't have any dupes.
+                   "-no-duplicates"
+                   "-comp"
+                   ,#+(compressor-name compressor)))
+
+          ;; Here we reparent the store items.  For each sub-directory of
+          ;; the store prefix we need one invocation of "mksquashfs".
+          (for-each (lambda (dir)
+                      (apply invoke "mksquashfs"
+                             `(".empty"
+                               ,#$output
+                               "-root-becomes" ,dir)))
+                    (reverse (string-tokenize (%store-directory)
+                                              (char-set-complement (char-set #\/)))))
+
+          ;; Add symlinks and mount points.
+          (apply invoke "mksquashfs"
+                 `(".empty"
+                   ,#$output
+                   ;; Create SYMLINKS via pseudo file definitions.
+                   ,@(append-map
+                      (match-lambda
+                        ((source '-> target)
+                         (list "-p"
+                               (string-join
+                                ;; name s mode uid gid symlink
+                                (list source
+                                      "s" "777" "0" "0"
+                                      (string-append #$profile "/" target))))))
+                      '#$symlinks)
+
+                   ;; Create empty mount points.
+                   "-p" "/proc d 555 0 0"
+                   "-p" "/sys d 555 0 0"
+                   "-p" "/dev d 555 0 0"))
+
+          (when database
+            ;; Initialize /var/guix.
+            (install-database-and-gc-roots "var-etc" database #$profile)
+            (invoke "mksquashfs" "var-etc" #$output)))))
 
   (gexp->derivation (string-append name
                                    (compressor-extension compressor)
@@ -333,7 +381,7 @@ added to the pack."
 
 (define* (docker-image name profile
                        #:key target
-                       deduplicate?
+                       (profile-name "guix-profile")
                        (compressor (first %compressors))
                        localstatedir?
                        (symlinks '())
@@ -343,6 +391,11 @@ image is a tarball conforming to the Docker Image Specification, compressed
 with COMPRESSOR.  It can be passed to 'docker load'.  If TARGET is true, it
 must a be a GNU triplet and it is used to derive the architecture metadata in
 the image."
+  (define database
+    (and localstatedir?
+         (file-append (store-database (list profile))
+                      "/db/db.sqlite")))
+
   (define defmod 'define-module)                  ;trick Geiser
 
   (define build
@@ -361,6 +414,7 @@ the image."
                                      (call-with-input-file "profile"
                                        read-reference-graph))
                                 #$profile
+                                #:database #+database
                                 #:system (or #$target (utsname:machine (uname)))
                                 #:symlinks '#$symlinks
                                 #:compressor '#$(compressor-command compressor)
@@ -538,6 +592,7 @@ please email '~a'~%")
 (define %default-options
   ;; Alist of default option values.
   `((format . tarball)
+    (profile-name . "guix-profile")
     (system . ,(%current-system))
     (substitutes? . #t)
     (build-hook? . #t)
@@ -555,6 +610,18 @@ please email '~a'~%")
     (squashfs . ,squashfs-image)
     (docker  . ,docker-image)))
 
+(define (show-formats)
+  ;; Print the supported pack formats.
+  (display (G_ "The supported formats for 'guix pack' are:"))
+  (newline)
+  (display (G_ "
+  tarball       Self-contained tarball, ready to run on another machine"))
+  (display (G_ "
+  squashfs      Squashfs image suitable for Singularity"))
+  (display (G_ "
+  docker        Tarball ready for 'docker load'"))
+  (newline))
+
 (define %options
   ;; Specifications of the command-line options.
   (cons* (option '(#\h "help") #f #f
@@ -571,6 +638,10 @@ please email '~a'~%")
          (option '(#\f "format") #t #f
                  (lambda (opt name arg result)
                    (alist-cons 'format (string->symbol arg) result)))
+         (option '("list-formats") #f #f
+                 (lambda args
+                   (show-formats)
+                   (exit 0)))
          (option '(#\R "relocatable") #f #f
                  (lambda (opt name arg result)
                    (alist-cons 'relocatable? #t result)))
@@ -609,6 +680,13 @@ please email '~a'~%")
          (option '("localstatedir") #f #f
                  (lambda (opt name arg result)
                    (alist-cons 'localstatedir? #t result)))
+         (option '("profile-name") #t #f
+                 (lambda (opt name arg result)
+                   (match arg
+                     ((or "guix-profile" "current-guix")
+                      (alist-cons 'profile-name arg result))
+                     (_
+                      (leave (G_ "~a: unsupported profile name~%") arg)))))
          (option '("bootstrap") #f #f
                  (lambda (opt name arg result)
                    (alist-cons 'bootstrap? #t result)))
@@ -626,6 +704,8 @@ Create a bundle of PACKAGE.\n"))
   (display (G_ "
   -f, --format=FORMAT    build a pack in the given FORMAT"))
   (display (G_ "
+      --list-formats     list the formats available"))
+  (display (G_ "
   -R, --relocatable      produce relocatable executables"))
   (display (G_ "
   -e, --expression=EXPR  consider the package EXPR evaluates to"))
@@ -642,6 +722,9 @@ Create a bundle of PACKAGE.\n"))
   (display (G_ "
       --localstatedir    include /var/guix in the resulting pack"))
   (display (G_ "
+      --profile-name=NAME
+                         populate /var/guix/profiles/.../NAME"))
+  (display (G_ "
       --bootstrap        use the bootstrap binaries to build the pack"))
   (newline)
   (display (G_ "
@@ -730,7 +813,8 @@ Create a bundle of PACKAGE.\n"))
                                 (#f
                                  (leave (G_ "~a: unknown pack format~%")
                                         pack-format))))
-                 (localstatedir? (assoc-ref opts 'localstatedir?)))
+                 (localstatedir? (assoc-ref opts 'localstatedir?))
+                 (profile-name   (assoc-ref opts 'profile-name)))
             (run-with-store store
               (mlet* %store-monad ((profile (profile-derivation
                                              manifest
@@ -749,6 +833,8 @@ Create a bundle of PACKAGE.\n"))
                                                      symlinks
                                                      #:localstatedir?
                                                      localstatedir?
+                                                     #:profile-name
+                                                     profile-name
                                                      #:archiver
                                                      archiver)))
                 (mbegin %store-monad