Merge branch 'master' into core-updates

10 files changed, 499 insertions, 331 deletions

diff --git a/guix/scripts/gc.scm b/guix/scripts/gc.scm
index e4ed7227ff..6f37b767ff 100644
--- a/guix/scripts/gc.scm
+++ b/guix/scripts/gc.scm
@@ -199,10 +199,10 @@ Invoke the garbage collector.\n"))
     ;; Attempt to have at least SPACE bytes available in STORE.
     (let ((free (free-disk-space (%store-prefix))))
       (if (> free space)
-          (info (G_ "already ~h bytes available on ~a, nothing to do~%")
-                free (%store-prefix))
+          (info (G_ "already ~h MiBs available on ~a, nothing to do~%")
+                (/ free 1024. 1024.) (%store-prefix))
           (let ((to-free (- space free)))
-            (info (G_ "freeing ~h bytes~%") to-free)
+            (info (G_ "freeing ~h MiBs~%") (/ to-free 1024. 1024.))
             (collect-garbage store to-free)))))
 
   (with-error-handling
@@ -234,10 +234,10 @@ Invoke the garbage collector.\n"))
              (ensure-free-space store free-space))
             (min-freed
              (let-values (((paths freed) (collect-garbage store min-freed)))
-              (info (G_ "freed ~h bytes~%") freed)))
+              (info (G_ "freed ~h MiBs~%") (/ freed 1024. 1024.))))
             (else
              (let-values (((paths freed) (collect-garbage store)))
-              (info (G_ "freed ~h bytes~%") freed))))))
+              (info (G_ "freed ~h MiBs~%") (/ freed 1024. 1024.)))))))
         ((delete)
          (delete-paths store (map direct-store-path paths)))
         ((list-references)
diff --git a/guix/scripts/import/cran.scm b/guix/scripts/import/cran.scm
index d65c644c05..30ae6d4342 100644
--- a/guix/scripts/import/cran.scm
+++ b/guix/scripts/import/cran.scm
@@ -99,8 +99,10 @@ Import and convert the CRAN package for PACKAGE-NAME.\n"))
                    `(define-public ,(string->symbol name)
                       ,pkg))
                   (_ #f))
-                (reverse (stream->list (recursive-import package-name
-                                                         (or (assoc-ref opts 'repo) 'cran)))))
+                (reverse
+                 (stream->list
+                  (cran-recursive-import package-name
+                                         (or (assoc-ref opts 'repo) 'cran)))))
            ;; Single import
            (let ((sexp (cran->guix-package package-name
                                            (or (assoc-ref opts 'repo) 'cran))))
diff --git a/guix/scripts/import/elpa.scm b/guix/scripts/import/elpa.scm
index 34eb16485e..f1ed5016ba 100644
--- a/guix/scripts/import/elpa.scm
+++ b/guix/scripts/import/elpa.scm
@@ -1,5 +1,6 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2015 Federico Beffa <beffa@fbengineering.ch>
+;;; Copyright © 2018 Oleg Pykhalov <go.wigust@gmail.com>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -21,10 +22,12 @@
   #:use-module (guix utils)
   #:use-module (guix scripts)
   #:use-module (guix import elpa)
+  #:use-module (guix import utils)
   #:use-module (guix scripts import)
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-11)
   #:use-module (srfi srfi-37)
+  #:use-module (srfi srfi-41)
   #:use-module (ice-9 match)
   #:use-module (ice-9 format)
   #:export (guix-import-elpa))
@@ -45,6 +48,8 @@ Import the latest package named PACKAGE-NAME from an ELPA repository.\n"))
   (display (G_ "
   -h, --help                     display this help and exit"))
   (display (G_ "
+  -r, --recursive                generate package expressions for all Emacs packages that are not yet in Guix"))
+  (display (G_ "
   -V, --version                  display version information and exit"))
   (newline)
   (show-bug-report-information))
@@ -62,6 +67,9 @@ Import the latest package named PACKAGE-NAME from an ELPA repository.\n"))
                  (lambda (opt name arg result)
                    (alist-cons 'repo (string->symbol arg)
                                (alist-delete 'repo result))))
+         (option '(#\r "recursive") #f #f
+                 (lambda (opt name arg result)
+                   (alist-cons 'recursive #t result)))
          %standard-import-options))
 
 
@@ -87,10 +95,20 @@ Import the latest package named PACKAGE-NAME from an ELPA repository.\n"))
                            (reverse opts))))
     (match args
       ((package-name)
-       (let ((sexp (elpa->guix-package package-name (assoc-ref opts 'repo))))
-         (unless sexp
-           (leave (G_ "failed to download package '~a'~%") package-name))
-         sexp))
+       (if (assoc-ref opts 'recursive)
+           (map (match-lambda
+                  ((and ('package ('name name) . rest) pkg)
+                   `(define-public ,(string->symbol name)
+                      ,pkg))
+                  (_ #f))
+                (reverse
+                 (stream->list
+                  (elpa-recursive-import package-name
+                                         (or (assoc-ref opts 'repo) 'gnu)))))
+           (let ((sexp (elpa->guix-package package-name (assoc-ref opts 'repo))))
+             (unless sexp
+               (leave (G_ "failed to download package '~a'~%") package-name))
+             sexp)))
       (()
        (leave (G_ "too few arguments~%")))
       ((many ...)
diff --git a/guix/scripts/lint.scm b/guix/scripts/lint.scm
index cd802985dc..e477bf0ddc 100644
--- a/guix/scripts/lint.scm
+++ b/guix/scripts/lint.scm
@@ -1,7 +1,7 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2014 Cyril Roelandt <tipecaml@gmail.com>
 ;;; Copyright © 2014, 2015 Eric Bavier <bavier@member.fsf.org>
-;;; Copyright © 2013, 2014, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2015, 2016 Mathieu Lirzin <mthl@gnu.org>
 ;;; Copyright © 2016 Danny Milosavljevic <dannym+a@scratchpost.org>
 ;;; Copyright © 2016 Hartmut Goebel <h.goebel@crazy-compilers.com>
@@ -809,15 +809,6 @@ descriptions maintained upstream."
      (emit-warning package (G_ "invalid license field")
                    'license))))
 
-(define (patch-file-name patch)
-  "Return the basename of PATCH's file name, or #f if the file name could not
-be determined."
-  (match patch
-    ((? string?)
-     (basename patch))
-    ((? origin?)
-     (and=> (origin-actual-file-name patch) basename))))
-
 (define (call-with-networking-fail-safe message error-value proc)
   "Call PROC catching any network-related errors.  Upon a networking error,
 display a message including MESSAGE and return ERROR-VALUE."
@@ -878,20 +869,14 @@ the NIST server non-fatal."
       (()
        #t)
       ((vulnerabilities ...)
-       (let* ((patches   (filter-map patch-file-name
-                                     (or (and=> (package-source package)
-                                                origin-patches)
-                                         '())))
+       (let* ((patched    (package-patched-vulnerabilities package))
               (known-safe (or (assq-ref (package-properties package)
                                         'lint-hidden-cve)
                               '()))
               (unpatched (remove (lambda (vuln)
                                    (let ((id (vulnerability-id vuln)))
-                                     (or
-                                       (find (cute string-contains
-                                                   <> id)
-                                             patches)
-                                       (member id known-safe))))
+                                     (or (member id patched)
+                                         (member id known-safe))))
                                  vulnerabilities)))
          (unless (null? unpatched)
            (emit-warning package
diff --git a/guix/scripts/offload.scm b/guix/scripts/offload.scm
index 56d6de6308..ee5857e16b 100644
--- a/guix/scripts/offload.scm
+++ b/guix/scripts/offload.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2014, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2014, 2015, 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2017 Ricardo Wurmus <rekado@elephly.net>
 ;;;
 ;;; This file is part of GNU Guix.
@@ -124,7 +124,15 @@ determined."
       (save-module-excursion
        (lambda ()
          (set-current-module %user-module)
-         (primitive-load file))))
+         (match (primitive-load file)
+           (((? build-machine? machines) ...)
+            machines)
+           (_
+            ;; Instead of crashing, assume the empty list.
+            (warning (G_ "'~a' did not return a list of build machines; \
+ignoring it~%")
+                     file)
+            '())))))
     (lambda args
       (match args
         (('system-error . rest)
@@ -494,6 +502,30 @@ slot (which must later be released with 'release-build-slot'), or #f and #f."
         (()
          (values #f #f))))))
 
+(define (call-with-timeout timeout drv thunk)
+  "Call THUNK and leave after TIMEOUT seconds.  If TIMEOUT is #f, simply call
+THUNK.  Use DRV as an indication of what we were building when the timeout
+expired."
+  (if (number? timeout)
+      (dynamic-wind
+        (lambda ()
+          (sigaction SIGALRM
+            (lambda _
+              ;; The exit code here will be 1, which guix-daemon will
+              ;; interpret as a transient failure.
+              (leave (G_ "timeout expired while offloading '~a'~%")
+                     (derivation-file-name drv))))
+          (alarm timeout))
+        thunk
+        (lambda ()
+          (alarm 0)))
+      (thunk)))
+
+(define-syntax-rule (with-timeout timeout drv exp ...)
+  "Evaluate EXP... and leave after TIMEOUT seconds if EXP hasn't completed.
+If TIMEOUT is #f, simply evaluate EXP..."
+  (call-with-timeout timeout drv (lambda () exp ...)))
+
 (define* (process-request wants-local? system drv features
                           #:key
                           print-build-trace? (max-silent-time 3600)
@@ -520,13 +552,18 @@ slot (which must later be released with 'release-build-slot'), or #f and #f."
                  (display "# accept\n")
                  (let ((inputs  (string-tokenize (read-line)))
                        (outputs (string-tokenize (read-line))))
-                   (transfer-and-offload drv machine
-                                         #:inputs inputs
-                                         #:outputs outputs
-                                         #:max-silent-time max-silent-time
-                                         #:build-timeout build-timeout
-                                         #:print-build-trace?
-                                         print-build-trace?)))
+                   ;; Even if BUILD-TIMEOUT is honored by MACHINE, there can
+                   ;; be issues with the connection or deadlocks that could
+                   ;; lead the 'guix offload' process to remain stuck forever.
+                   ;; To avoid that, install a timeout here as well.
+                   (with-timeout build-timeout drv
+                     (transfer-and-offload drv machine
+                                           #:inputs inputs
+                                           #:outputs outputs
+                                           #:max-silent-time max-silent-time
+                                           #:build-timeout build-timeout
+                                           #:print-build-trace?
+                                           print-build-trace?))))
                (lambda ()
                  (release-build-slot slot)))
 
@@ -576,8 +613,8 @@ slot (which must later be released with 'release-build-slot'), or #f and #f."
          (leave (G_ "failed to talk to guix-daemon on '~a' (test returned ~s)~%")
                 name x))))
     (lambda (key . args)
-      (leave (G_ "remove evaluation on '~a' failed:~{ ~s~}~%")
-             args))))
+      (leave (G_ "remote evaluation on '~a' failed:~{ ~s~}~%")
+             name args))))
 
 (define %random-state
   (delay
@@ -755,6 +792,7 @@ This tool is meant to be used internally by 'guix-daemon'.\n"))
 ;;; eval: (put 'with-machine-lock 'scheme-indent-function 2)
 ;;; eval: (put 'with-file-lock 'scheme-indent-function 1)
 ;;; eval: (put 'with-error-to-port 'scheme-indent-function 1)
+;;; eval: (put 'with-timeout 'scheme-indent-function 2)
 ;;; End:
 
 ;;; offload.scm ends here
diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm
index 76729d8e10..7f087a3a3c 100644
--- a/guix/scripts/pack.scm
+++ b/guix/scripts/pack.scm
@@ -35,6 +35,7 @@
   #:use-module (guix search-paths)
   #:use-module (guix build-system gnu)
   #:use-module (guix scripts build)
+  #:use-module ((guix self) #:select (make-config.scm))
   #:use-module (gnu packages)
   #:use-module (gnu packages bootstrap)
   #:use-module (gnu packages compression)
@@ -87,6 +88,19 @@ found."
             %compressors)
       (leave (G_ "~a: compressor not found~%") name)))
 
+(define not-config?
+  ;; Select (guix …) and (gnu …) modules, except (guix config).
+  (match-lambda
+    (('guix 'config) #f)
+    (('guix _ ...) #t)
+    (('gnu _ ...) #t)
+    (_ #f)))
+
+(define guile-sqlite3&co
+  ;; Guile-SQLite3 and its propagated inputs.
+  (cons guile-sqlite3
+        (package-transitive-propagated-inputs guile-sqlite3)))
+
 (define* (self-contained-tarball name profile
                                  #:key target
                                  deduplicate?
@@ -101,113 +115,124 @@ with a properly initialized store database.
 
 SYMLINKS must be a list of (SOURCE -> TARGET) tuples denoting symlinks to be
 added to the pack."
-  (define build
-    (with-imported-modules (source-module-closure
-                            '((guix build utils)
-                              (guix build union)
-                              (guix build store-copy)
-                              (gnu build install)))
-      #~(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 libgcrypt
+    (module-ref (resolve-interface '(gnu packages gnupg))
+                'libgcrypt))
 
-          (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")))
-
-          ;; We need Guix here for 'guix-register'.
-          (setenv "PATH"
-                  (string-append #$(if localstatedir?
-                                       (file-append guix "/sbin:")
-                                       "")
-                                 #$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?)
-
-          ;; 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"
-                           "-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)))))))))
+  (define schema
+    (and localstatedir?
+         (local-file (search-path %load-path
+                                  "guix/store/schema.sql"))))
+
+  (define build
+    (with-imported-modules `(((guix config)
+                              => ,(make-config.scm
+                                   #:libgcrypt libgcrypt))
+                             ,@(source-module-closure
+                                `((guix build utils)
+                                  (guix build union)
+                                  (guix build store-copy)
+                                  (gnu build install))
+                                #:select? not-config?))
+      (with-extensions guile-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"
+                             "-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))
@@ -227,70 +252,83 @@ 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 libgcrypt
+    ;; XXX: Not strictly needed, but pulled by (guix store database).
+    (module-ref (resolve-interface '(gnu packages gnupg))
+                'libgcrypt))
+
+
   (define build
-    (with-imported-modules '((guix build utils)
-                             (guix build store-copy)
-                             (gnu build install))
-      #~(begin
-          (use-modules (guix build utils)
-                       (gnu build install)
-                       (guix build store-copy)
-                       (srfi srfi-1)
-                       (srfi srfi-26)
-                       (ice-9 match))
+    (with-imported-modules `(((guix config)
+                              => ,(make-config.scm
+                                   #:libgcrypt libgcrypt))
+                             ,@(source-module-closure
+                                '((guix build utils)
+                                  (guix build store-copy)
+                                  (gnu build install))
+                                #:select? not-config?))
+      (with-extensions guile-sqlite3&co
+        #~(begin
+            (use-modules (guix build utils)
+                         (gnu build install)
+                         (guix build store-copy)
+                         (srfi srfi-1)
+                         (srfi srfi-26)
+                         (ice-9 match))
+
+            (setenv "PATH" (string-append #$archiver "/bin"))
 
-          (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"
-                 `(,@(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")))))
+            ;; 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"))))))
 
   (gexp->derivation (string-append name
                                    (compressor-extension compressor)
@@ -310,14 +348,6 @@ 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."
-  ;; FIXME: Honor LOCALSTATEDIR?.
-  (define not-config?
-    (match-lambda
-      (('guix 'config) #f)
-      (('guix rest ...) #t)
-      (('gnu rest ...) #t)
-      (rest #f)))
-
   (define defmod 'define-module)                  ;trick Geiser
 
   (define config
@@ -342,9 +372,9 @@ the image."
   (define build
     ;; Guile-JSON is required by (guix docker).
     (with-extensions (list json)
-      (with-imported-modules `(,@(source-module-closure '((guix docker))
+      (with-imported-modules `(,@(source-module-closure '((guix docker)
+                                                          (guix build store-copy))
                                                         #:select? not-config?)
-                               (guix build store-copy)
                                ((guix config) => ,config))
         #~(begin
             (use-modules (guix docker) (srfi srfi-19) (guix build store-copy))
@@ -352,8 +382,9 @@ the image."
             (setenv "PATH" (string-append #$archiver "/bin"))
 
             (build-docker-image #$output
-                                (call-with-input-file "profile"
-                                  read-reference-graph)
+                                (map store-info-item
+                                     (call-with-input-file "profile"
+                                       read-reference-graph))
                                 #$profile
                                 #:system (or #$target (utsname:machine (uname)))
                                 #:symlinks '#$symlinks
diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm
index 4f519e6f33..29829f52c8 100644
--- a/guix/scripts/package.scm
+++ b/guix/scripts/package.scm
@@ -64,46 +64,6 @@
 ;;; Profiles.
 ;;;
 
-(define %user-profile-directory
-  (and=> (getenv "HOME")
-         (cut string-append <> "/.guix-profile")))
-
-(define %profile-directory
-  (string-append %state-directory "/profiles/"
-                 (or (and=> (or (getenv "USER")
-                                (getenv "LOGNAME"))
-                            (cut string-append "per-user/" <>))
-                     "default")))
-
-(define %current-profile
-  ;; Call it `guix-profile', not `profile', to allow Guix profiles to
-  ;; coexist with Nix profiles.
-  (string-append %profile-directory "/guix-profile"))
-
-(define (canonicalize-profile profile)
-  "If PROFILE is %USER-PROFILE-DIRECTORY, return %CURRENT-PROFILE.  Otherwise
-return PROFILE unchanged.  The goal is to treat '-p ~/.guix-profile' as if
-'-p' was omitted."                           ; see <http://bugs.gnu.org/17939>
-
-  ;; Trim trailing slashes so that the basename comparison below works as
-  ;; intended.
-  (let ((profile (string-trim-right profile #\/)))
-    (if (and %user-profile-directory
-             (string=? (canonicalize-path (dirname profile))
-                       (dirname %user-profile-directory))
-             (string=? (basename profile) (basename %user-profile-directory)))
-        %current-profile
-        profile)))
-
-(define (user-friendly-profile profile)
-  "Return either ~/.guix-profile if that's what PROFILE refers to, directly or
-indirectly, or PROFILE."
-  (if (and %user-profile-directory
-           (false-if-exception
-            (string=? (readlink %user-profile-directory) profile)))
-      %user-profile-directory
-      profile))
-
 (define (ensure-default-profile)
   "Ensure the default profile symlink and directory exist and are writable."
 
diff --git a/guix/scripts/pull.scm b/guix/scripts/pull.scm
index 64c2196e03..7202e3cc16 100644
--- a/guix/scripts/pull.scm
+++ b/guix/scripts/pull.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2013, 2014, 2015, 2017 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2013, 2014, 2015, 2017, 2018 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2017 Marius Bakke <mbakke@fastmail.com>
 ;;;
 ;;; This file is part of GNU Guix.
@@ -25,10 +25,15 @@
   #:use-module (guix config)
   #:use-module (guix packages)
   #:use-module (guix derivations)
+  #:use-module (guix profiles)
   #:use-module (guix gexp)
   #:use-module (guix grafts)
   #:use-module (guix monads)
   #:use-module (guix scripts build)
+  #:autoload   (guix self) (whole-package)
+  #:autoload   (gnu packages ssh) (guile-ssh)
+  #:autoload   (gnu packages tls) (gnutls)
+  #:use-module ((guix scripts package) #:select (build-and-use-profile))
   #:use-module ((guix build utils)
                 #:select (with-directory-excursion delete-file-recursively))
   #:use-module ((guix build download)
@@ -40,6 +45,7 @@
   #:use-module ((gnu packages certs) #:select (le-certs))
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-11)
+  #:use-module (srfi srfi-35)
   #:use-module (srfi srfi-37)
   #:use-module (ice-9 match)
   #:export (guix-pull))
@@ -105,6 +111,9 @@ Download and deploy the latest version of Guix.\n"))
   (display (G_ "
       --branch=BRANCH    download the tip of the specified BRANCH"))
   (display (G_ "
+  -l, --list-generations[=PATTERN]
+                         list generations matching PATTERN"))
+  (display (G_ "
       --bootstrap        use the bootstrap Guile to build the new Guix"))
   (newline)
   (show-build-options-help)
@@ -120,6 +129,10 @@ Download and deploy the latest version of Guix.\n"))
   (cons* (option '("verbose") #f #f
                  (lambda (opt name arg result)
                    (alist-cons 'verbose? #t result)))
+         (option '(#\l "list-generations") #f #t
+                 (lambda (opt name arg result)
+                   (cons `(query list-generations ,(or arg ""))
+                         result)))
          (option '("url") #t #f
                  (lambda (opt name arg result)
                    (alist-cons 'repository-url arg
@@ -158,6 +171,12 @@ Download and deploy the latest version of Guix.\n"))
   ;; a makefile, and, similarly, is intended to always keep this name.
   "build-aux/build-self.scm")
 
+(define %pull-version
+  ;; This is the version of the 'guix pull' protocol.  It specifies what's
+  ;; expected from %SELF-BUILD-FILE.  The initial version ("0") was when we'd
+  ;; place a set of compiled Guile modules in ~/.config/guix/latest.
+  1)
+
 (define* (build-from-source source
                             #:key verbose? commit)
   "Return a derivation to build Guix from SOURCE, using the self-build script
@@ -170,35 +189,62 @@ contained therein.  Use COMMIT as the version string."
          (build  (primitive-load script)))
     ;; BUILD must be a monadic procedure of at least one argument: the source
     ;; tree.
-    (build source #:verbose? verbose? #:version commit)))
+    ;;
+    ;; Note: BUILD can return #f if it does not support %PULL-VERSION.  In the
+    ;; future we'll fall back to a previous version of the protocol when that
+    ;; happens.
+    (build source #:verbose? verbose? #:version commit
+           #:pull-version %pull-version)))
+
+(define (whole-package-for-legacy name modules)
+  "Return a full-blown Guix package for MODULES, a derivation that builds Guix
+modules in the old ~/.config/guix/latest style."
+  (whole-package name modules
+
+                 ;; In the "old style", %SELF-BUILD-FILE would simply return a
+                 ;; derivation that builds modules.  We have to infer what the
+                 ;; dependencies of these modules were.
+                 (list guile-json guile-git guile-bytestructures
+                       guile-ssh gnutls)))
+
+(define* (derivation->manifest-entry drv
+                                     #:key url branch commit)
+  "Return a manifest entry for DRV, which represents Guix at COMMIT.  Record
+URL, BRANCH, and COMMIT as a property in the manifest entry."
+  (mbegin %store-monad
+    (what-to-build (list drv))
+    (built-derivations (list drv))
+    (let ((out (derivation->output-path drv)))
+      (return (manifest-entry
+                (name "guix")
+                (version (string-take commit 7))
+                (item (if (file-exists? (string-append out "/bin/guix"))
+                          drv
+                          (whole-package-for-legacy (string-append name "-"
+                                                                   version)
+                                                    drv)))
+                (properties
+                 `((source (repository
+                            (version 0)
+                            (url ,url)
+                            (branch ,branch)
+                            (commit ,commit))))))))))
 
 (define* (build-and-install source config-dir
-                            #:key verbose? commit)
+                            #:key verbose? url branch commit)
   "Build the tool from SOURCE, and install it in CONFIG-DIR."
-  (mlet* %store-monad ((source        (build-from-source source
-                                                         #:commit commit
-                                                         #:verbose? verbose?))
-                       (source-dir -> (derivation->output-path source))
-                       (to-do?        (what-to-build (list source)))
-                       (built?        (built-derivations (list source))))
-    ;; Always update the 'latest' symlink, regardless of whether SOURCE was
-    ;; already built or not.
-    (if built?
-        (mlet* %store-monad
-            ((latest -> (string-append config-dir "/latest"))
-             (done      (indirect-root-added latest)))
-          (if (and (file-exists? latest)
-                   (string=? (readlink latest) source-dir))
-              (begin
-                (display (G_ "Guix already up to date\n"))
-                (return #t))
-              (begin
-                (switch-symlinks latest source-dir)
-                (format #t
-                        (G_ "updated ~a successfully deployed under `~a'~%")
-                        %guix-package-name latest)
-                (return #t))))
-        (leave (G_ "failed to update Guix, check the build log~%")))))
+  (define update-profile
+    (store-lift build-and-use-profile))
+
+  (mlet* %store-monad ((drv   (build-from-source source
+                                                 #:commit commit
+                                                 #:verbose? verbose?))
+                       (entry (derivation->manifest-entry drv
+                                                          #:url url
+                                                          #:branch branch
+                                                          #:commit commit)))
+    (update-profile (string-append config-dir "/current")
+                    (manifest (list entry)))))
 
 (define (honor-lets-encrypt-certificates! store)
   "Tell Guile-Git to use the Let's Encrypt certificates."
@@ -236,6 +282,66 @@ certificates~%"))
       (report-git-error err))))
 
 
+;;;
+;;; Queries.
+;;;
+
+(define (display-profile-content profile number)
+  "Display the packages in PROFILE, generation NUMBER, in a human-readable
+way and displaying details about the channel's source code."
+  (for-each (lambda (entry)
+              (format #t "  ~a ~a~%"
+                      (manifest-entry-name entry)
+                      (manifest-entry-version entry))
+              (match (assq 'source (manifest-entry-properties entry))
+                (('source ('repository ('version 0)
+                                       ('url url)
+                                       ('branch branch)
+                                       ('commit commit)
+                                       _ ...))
+                 (format #t (G_ "    repository URL: ~a~%") url)
+                 (when branch
+                   (format #t (G_ "    branch: ~a~%") branch))
+                 (format #t (G_ "    commit: ~a~%") commit))
+                (_ #f)))
+
+            ;; Show most recently installed packages last.
+            (reverse
+             (manifest-entries
+              (profile-manifest (generation-file-name profile number))))))
+
+(define (process-query opts)
+  "Process any query specified by OPTS."
+  (define profile
+    (string-append (config-directory) "/current"))
+
+  (match (assoc-ref opts 'query)
+    (('list-generations pattern)
+     (define (list-generation display-function number)
+       (unless (zero? number)
+         (display-generation profile number)
+         (display-function profile number)
+         (newline)))
+
+     (leave-on-EPIPE
+      (cond ((not (file-exists? profile))         ; XXX: race condition
+             (raise (condition (&profile-not-found-error
+                                (profile profile)))))
+            ((string-null? pattern)
+             (for-each (lambda (generation)
+                         (list-generation display-profile-content generation))
+                       (profile-generations profile)))
+            ((matching-generations pattern profile)
+             =>
+             (match-lambda
+               (()
+                (exit 1))
+               ((numbers ...)
+                (for-each (lambda (generation)
+                            (list-generation display-profile-content generation))
+                          numbers)))))))))
+
+
 (define (guix-pull . args)
   (define (use-le-certs? url)
     (string-prefix? "https://git.savannah.gnu.org/" url))
@@ -249,38 +355,48 @@ certificates~%"))
             (cache (string-append (cache-directory) "/pull")))
        (ensure-guile-git!)
 
-       (unless (assoc-ref opts 'dry-run?)         ;XXX: not very useful
-         (with-store store
-           (parameterize ((%graft? (assoc-ref opts 'graft?)))
-             (set-build-options-from-command-line store opts)
-
-             ;; For reproducibility, always refer to the LE certificates when we
-             ;; know we're talking to Savannah.
-             (when (use-le-certs? url)
-               (honor-lets-encrypt-certificates! store))
-
-             (format (current-error-port)
-                     (G_ "Updating from Git repository at '~a'...~%")
-                     url)
-
-             (let-values (((checkout commit)
-                           (latest-repository-commit store url
-                                                     #:ref ref
-                                                     #:cache-directory cache)))
-
-               (format (current-error-port)
-                       (G_ "Building from Git commit ~a...~%")
-                       commit)
-               (parameterize ((%guile-for-build
-                               (package-derivation
-                                store
-                                (if (assoc-ref opts 'bootstrap?)
-                                    %bootstrap-guile
-                                    (canonical-package guile-2.2)))))
-                 (run-with-store store
-                   (build-and-install checkout (config-directory)
-                                      #:commit commit
-                                      #:verbose?
-                                      (assoc-ref opts 'verbose?))))))))))))
+       (cond ((assoc-ref opts 'query)
+              (process-query opts))
+             ((assoc-ref opts 'dry-run?)
+              #t)                                 ;XXX: not very useful
+             (else
+              (with-store store
+                (parameterize ((%graft? (assoc-ref opts 'graft?)))
+                  (set-build-options-from-command-line store opts)
+
+                  ;; For reproducibility, always refer to the LE certificates
+                  ;; when we know we're talking to Savannah.
+                  (when (use-le-certs? url)
+                    (honor-lets-encrypt-certificates! store))
+
+                  (format (current-error-port)
+                          (G_ "Updating from Git repository at '~a'...~%")
+                          url)
+
+                  (let-values (((checkout commit)
+                                (latest-repository-commit store url
+                                                          #:ref ref
+                                                          #:cache-directory
+                                                          cache)))
+
+                    (format (current-error-port)
+                            (G_ "Building from Git commit ~a...~%")
+                            commit)
+                    (parameterize ((%guile-for-build
+                                    (package-derivation
+                                     store
+                                     (if (assoc-ref opts 'bootstrap?)
+                                         %bootstrap-guile
+                                         (canonical-package guile-2.2)))))
+                      (run-with-store store
+                        (build-and-install checkout (config-directory)
+                                           #:url url
+                                           #:branch (match ref
+                                                      (('branch . branch)
+                                                       branch)
+                                                      (_ #f))
+                                           #:commit commit
+                                           #:verbose?
+                                           (assoc-ref opts 'verbose?)))))))))))))
 
 ;;; pull.scm ends here
diff --git a/guix/scripts/substitute.scm b/guix/scripts/substitute.scm
index 8e1119fb49..d0beacc8ea 100755
--- a/guix/scripts/substitute.scm
+++ b/guix/scripts/substitute.scm
@@ -613,10 +613,10 @@ if file doesn't exist, and the narinfo otherwise."
     (let ((done 0)
           (total (length paths)))
       (lambda ()
-        (display #\cr (current-error-port))
+        (display "\r\x1b[K" (current-error-port)) ;erase current line
         (force-output (current-error-port))
         (format (current-error-port)
-                (G_ "updating list of substitutes from '~a'... ~5,1f%")
+                (G_ "updating substitutes from '~a'... ~5,1f%")
                 url (* 100. (/ done total)))
         (set! done (+ 1 done)))))
 
diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm
index 766cab1aad..14aedceac1 100644
--- a/guix/scripts/system.scm
+++ b/guix/scripts/system.scm
@@ -3,6 +3,7 @@
 ;;; Copyright © 2016 Alex Kost <alezost@gmail.com>
 ;;; Copyright © 2016, 2017, 2018 Chris Marusich <cmmarusich@gmail.com>
 ;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com>
+;;; Copyright © 2018 Ricardo Wurmus <rekado@elephly.net>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -23,6 +24,7 @@
   #:use-module (guix config)
   #:use-module (guix ui)
   #:use-module (guix store)
+  #:autoload   (guix store database) (register-path)
   #:use-module (guix grafts)
   #:use-module (guix gexp)
   #:use-module (guix derivations)
@@ -197,7 +199,7 @@ TARGET, and register them."
                   bootcfg bootcfg-file)
   "Copy the closure of BOOTCFG, which includes the output of OS-DRV, to
 directory TARGET.  TARGET must be an absolute directory name since that's what
-'guix-register' expects.
+'register-path' expects.
 
 When INSTALL-BOOTLOADER? is true, install bootloader using BOOTCFG."
   (define (maybe-copy to-copy)
@@ -351,8 +353,8 @@ bring the system down."
                            #:optional (profile %system-profile))
   "Make a new generation of PROFILE pointing to the directory of OS, switch to
 it atomically, and then run OS's activation script."
-  (mlet* %store-monad ((drv    (operating-system-derivation os))
-                       (script (operating-system-activation-script os)))
+  (mlet* %store-monad ((drv (operating-system-derivation os))
+                       (script (lower-object (operating-system-activation-script os))))
     (let* ((system     (derivation->output-path drv))
            (number     (+ 1 (generation-number profile)))
            (generation (generation-file-name profile number)))
@@ -550,10 +552,26 @@ list of services."
       ;; TRANSLATORS: Please preserve the two-space indentation.
       (format #t (G_ "  label: ~a~%") label)
       (format #t (G_ "  bootloader: ~a~%") bootloader-name)
-      (format #t (G_ "  root device: ~a~%")
-              (if (uuid? root-device)
-                  (uuid->string root-device)
-                  root-device))
+
+      ;; TRANSLATORS: The '~[', '~;', and '~]' sequences in this string must
+      ;; be preserved.  They denote conditionals, such that the result will
+      ;; look like:
+      ;;   root device: UUID: 12345-678
+      ;; or:
+      ;;   root device: label: "my-root"
+      ;; or just:
+      ;;   root device: /dev/sda3
+      (format #t (G_ "  root device: ~[UUID: ~a~;label: ~s~;~a~]~%")
+              (cond ((uuid? root-device) 0)
+                    ((file-system-label? root-device) 1)
+                    (else 2))
+              (cond ((uuid? root-device)
+                     (uuid->string root-device))
+                    ((file-system-label? root-device)
+                     (file-system-label->string root-device))
+                    (else
+                     root-device)))
+
       (format #t (G_ "  kernel: ~a~%") kernel))))
 
 (define* (list-generations pattern #:optional (profile %system-profile))
@@ -740,7 +758,7 @@ checking this by themselves in their 'check' procedure."
   ;; <http://lists.gnu.org/archive/html/guix-devel/2014-08/msg00057.html> for
   ;; a discussion.
   (define latest
-    (string-append (config-directory) "/latest"))
+    (string-append (config-directory) "/current"))
 
   (unless (file-exists? latest)
     (warning (G_ "~a not found: 'guix pull' was never run~%") latest)