Merge branch 'master' into staging

30 files changed, 1185 insertions, 369 deletions

diff --git a/guix/base32.scm b/guix/base32.scm
index 7b2e2a671..49f191ba2 100644
--- a/guix/base32.scm
+++ b/guix/base32.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2012, 2015 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2012, 2015, 2017 Ludovic Courtès <ludo@gnu.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -28,6 +28,8 @@
             bytevector->nix-base32-string
             base32-string->bytevector
             nix-base32-string->bytevector
+            %nix-base32-charset
+            %rfc4648-base32-charset
             &invalid-base32-character
             invalid-base32-character?
             invalid-base32-character-value
@@ -152,11 +154,17 @@ the previous application or INIT."
     #\a #\b #\c #\d #\f #\g #\h #\i #\j #\k #\l #\m #\n
     #\p #\q #\r #\s #\v #\w #\x #\y #\z))
 
+(define %nix-base32-charset
+  (list->char-set (vector->list %nix-base32-chars)))
+
 (define %rfc4648-base32-chars
   #(#\a #\b #\c #\d #\e #\f #\g #\h #\i #\j #\k #\l #\m
     #\n #\o #\p #\q #\r #\s #\t #\u #\v #\w #\x #\y #\z
     #\2 #\3 #\4 #\5 #\6 #\7))
 
+(define %rfc4648-base32-charset
+  (list->char-set (vector->list %rfc4648-base32-chars)))
+
 (define bytevector->base32-string
   (make-bytevector->base32-string bytevector-quintet-fold
                                   %rfc4648-base32-chars))
diff --git a/guix/build-system/cmake.scm b/guix/build-system/cmake.scm
index 25ac262d5..ee116c5a4 100644
--- a/guix/build-system/cmake.scm
+++ b/guix/build-system/cmake.scm
@@ -1,6 +1,7 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2013, 2014, 2015 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2013 Cyril Roelandt <tipecaml@gmail.com>
+;;; Copyright © 2017 Ricardo Wurmus <rekado@elephly.net>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -56,24 +57,38 @@
                 #:rest arguments)
   "Return a bag for NAME."
   (define private-keywords
-    '(#:source #:target #:cmake #:inputs #:native-inputs))
+    `(#:source #:cmake #:inputs #:native-inputs #:outputs
+      ,@(if target '() '(#:target))))
 
-  (and (not target)                               ;XXX: no cross-compilation
-       (bag
-         (name name)
-         (system system)
-         (host-inputs `(,@(if source
-                              `(("source" ,source))
-                              '())
-                        ,@inputs
+  (bag
+    (name name)
+    (system system)
+    (target target)
+    (build-inputs `(,@(if source
+                          `(("source" ,source))
+                          '())
+                    ,@`(("cmake" ,cmake))
+                    ,@native-inputs
+                    ,@(if target
+                          ;; Use the standard cross inputs of
+                          ;; 'gnu-build-system'.
+                          (standard-cross-packages target 'host)
+                          '())
+                    ;; Keep the standard inputs of 'gnu-build-system'.
+                    ,@(standard-packages)))
+    (host-inputs inputs)
 
-                        ;; Keep the standard inputs of 'gnu-build-system'.
-                        ,@(standard-packages)))
-         (build-inputs `(("cmake" ,cmake)
-                         ,@native-inputs))
-         (outputs outputs)
-         (build cmake-build)
-         (arguments (strip-keyword-arguments private-keywords arguments)))))
+    ;; The cross-libc is really a target package, but for bootstrapping
+    ;; reasons, we can't put it in 'host-inputs'.  Namely, 'cross-gcc' is a
+    ;; native package, so it would end up using a "native" variant of
+    ;; 'cross-libc' (built with 'gnu-build'), whereas all the other packages
+    ;; would use a target variant (built with 'gnu-cross-build'.)
+    (target-inputs (if target
+                       (standard-cross-packages target 'target)
+                       '()))
+    (outputs outputs)
+    (build (if target cmake-cross-build cmake-build))
+    (arguments (strip-keyword-arguments private-keywords arguments))))
 
 (define* (cmake-build store name inputs
                       #:key (guile #f)
@@ -145,6 +160,115 @@ provides a 'CMakeLists.txt' file as its build system."
                                 #:outputs outputs
                                 #:guile-for-build guile-for-build))
 
+
+;;;
+;;; Cross-compilation.
+;;;
+
+(define* (cmake-cross-build store name
+                            #:key
+                            target native-drvs target-drvs
+                            (guile #f)
+                            (outputs '("out"))
+                            (configure-flags ''())
+                            (search-paths '())
+                            (native-search-paths '())
+                            (make-flags ''())
+                            (out-of-source? #t)
+                            (build-type "RelWithDebInfo")
+                            (tests? #f) ; nothing can be done
+                            (test-target "test")
+                            (parallel-build? #t) (parallel-tests? #f)
+                            (validate-runpath? #t)
+                            (patch-shebangs? #t)
+                            (strip-binaries? #t)
+                            (strip-flags ''("--strip-debug"
+                                            "--enable-deterministic-archives"))
+                            (strip-directories ''("lib" "lib64" "libexec"
+                                                  "bin" "sbin"))
+                            (phases '(@ (guix build cmake-build-system)
+                                        %standard-phases))
+                            (system (%current-system))
+                            (build (nix-system->gnu-triplet system))
+                            (imported-modules %cmake-build-system-modules)
+                            (modules '((guix build cmake-build-system)
+                                       (guix build utils))))
+  "Cross-build NAME using CMAKE for TARGET, where TARGET is a GNU triplet and
+with INPUTS.  This assumes that SOURCE provides a 'CMakeLists.txt' file as its
+build system."
+  (define builder
+    `(begin
+       (use-modules ,@modules)
+       (let ()
+         (define %build-host-inputs
+           ',(map (match-lambda
+                    ((name (? derivation? drv) sub ...)
+                     `(,name . ,(apply derivation->output-path drv sub)))
+                    ((name path)
+                     `(,name . ,path)))
+                  native-drvs))
+
+         (define %build-target-inputs
+           ',(map (match-lambda
+                    ((name (? derivation? drv) sub ...)
+                     `(,name . ,(apply derivation->output-path drv sub)))
+                    ((name (? package? pkg) sub ...)
+                     (let ((drv (package-cross-derivation store pkg
+                                                          target system)))
+                       `(,name . ,(apply derivation->output-path drv sub))))
+                    ((name path)
+                     `(,name . ,path)))
+                  target-drvs))
+
+         (cmake-build #:source ,(match (assoc-ref native-drvs "source")
+                                  (((? derivation? source))
+                                   (derivation->output-path source))
+                                  ((source)
+                                   source)
+                                  (source
+                                   source))
+                      #:system ,system
+                      #:build ,build
+                      #:target ,target
+                      #:outputs %outputs
+                      #:inputs %build-target-inputs
+                      #:native-inputs %build-host-inputs
+                      #:search-paths ',(map search-path-specification->sexp
+                                            search-paths)
+                      #:native-search-paths ',(map
+                                               search-path-specification->sexp
+                                               native-search-paths)
+                      #:phases ,phases
+                      #:configure-flags ,configure-flags
+                      #:make-flags ,make-flags
+                      #:out-of-source? ,out-of-source?
+                      #:build-type ,build-type
+                      #:tests? ,tests?
+                      #:test-target ,test-target
+                      #:parallel-build? ,parallel-build?
+                      #:parallel-tests? ,parallel-tests?
+                      #:validate-runpath? ,validate-runpath?
+                      #:patch-shebangs? ,patch-shebangs?
+                      #:strip-binaries? ,strip-binaries?
+                      #:strip-flags ,strip-flags
+                      #:strip-directories ,strip-directories))))
+
+  (define guile-for-build
+    (match guile
+      ((? package?)
+       (package-derivation store guile system #:graft? #f))
+      (#f                               ; the default
+       (let* ((distro (resolve-interface '(gnu packages commencement)))
+              (guile  (module-ref distro 'guile-final)))
+         (package-derivation store guile system #:graft? #f)))))
+
+  (build-expression->derivation store name builder
+                                #:system system
+                                #:inputs (append native-drvs target-drvs)
+                                #:outputs outputs
+                                #:modules imported-modules
+                                #:guile-for-build guile-for-build))
+
 (define cmake-build-system
   (build-system
     (name 'cmake)
diff --git a/guix/build-system/gnu.scm b/guix/build-system/gnu.scm
index 7cf0cafc0..047ace7e6 100644
--- a/guix/build-system/gnu.scm
+++ b/guix/build-system/gnu.scm
@@ -30,6 +30,7 @@
             gnu-build
             gnu-build-system
             standard-packages
+            standard-cross-packages
             package-with-explicit-inputs
             package-with-extra-configure-variable
             static-libgcc-package
diff --git a/guix/build-system/minify.scm b/guix/build-system/minify.scm
new file mode 100644
index 000000000..af90a32f5
--- /dev/null
+++ b/guix/build-system/minify.scm
@@ -0,0 +1,127 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2017 Ricardo Wurmus <rekado@elephly.net>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Guix is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (guix build-system minify)
+  #:use-module (guix store)
+  #:use-module (guix utils)
+  #:use-module (guix packages)
+  #:use-module (guix derivations)
+  #:use-module (guix search-paths)
+  #:use-module (guix build-system)
+  #:use-module (guix build-system gnu)
+  #:use-module (ice-9 match)
+  #:use-module (srfi srfi-26)
+  #:export (%minify-build-system-modules
+            minify-build
+            minify-build-system))
+
+;; Commentary:
+;;
+;; Standard minification procedure for JavaScript files.
+;;
+;; Code:
+
+(define %minify-build-system-modules
+  ;; Build-side modules imported by default.
+  `((guix build minify-build-system)
+    (ice-9 popen)
+    ,@%gnu-build-system-modules))
+
+(define (default-uglify-js)
+  "Return the default package to minify JavaScript source files."
+  ;; Lazily resolve the binding to avoid a circular dependency.
+  (let ((lisp-mod (resolve-interface '(gnu packages lisp))))
+    (module-ref lisp-mod 'uglify-js)))
+
+(define* (lower name
+                #:key source inputs native-inputs outputs system
+                (uglify-js (default-uglify-js))
+                #:allow-other-keys
+                #:rest arguments)
+  "Return a bag for NAME."
+  (define private-keywords
+    '(#:source #:target #:inputs #:native-inputs))
+
+  (bag
+    (name name)
+    (system system)
+    (host-inputs `(,@(if source
+                         `(("source" ,source))
+                         '())
+                   ,@inputs
+                   ,@(standard-packages)))
+    (build-inputs `(("uglify-js" ,uglify-js)
+                    ,@native-inputs))
+    (outputs outputs)
+    (build minify-build)
+    (arguments (strip-keyword-arguments private-keywords arguments))))
+
+(define* (minify-build store name inputs
+                       #:key
+                       (javascript-files #f)
+                       (phases '(@ (guix build minify-build-system)
+                                   %standard-phases))
+                       (outputs '("out"))
+                       (system (%current-system))
+                       search-paths
+                       (guile #f)
+                       (imported-modules %minify-build-system-modules)
+                       (modules '((guix build minify-build-system)
+                                  (guix build utils))))
+  "Build SOURCE with INPUTS."
+  (define builder
+    `(begin
+       (use-modules ,@modules)
+       (minify-build #:name ,name
+                     #:source ,(match (assoc-ref inputs "source")
+                                 (((? derivation? source))
+                                  (derivation->output-path source))
+                                 ((source)
+                                  source)
+                                 (source
+                                  source))
+                     #:javascript-files ,javascript-files
+                     #:phases ,phases
+                     #:outputs %outputs
+                     #:search-paths ',(map search-path-specification->sexp
+                                           search-paths)
+                     #:inputs %build-inputs)))
+
+  (define guile-for-build
+    (match guile
+      ((? package?)
+       (package-derivation store guile system #:graft? #f))
+      (#f                               ; the default
+       (let* ((distro (resolve-interface '(gnu packages commencement)))
+              (guile  (module-ref distro 'guile-final)))
+         (package-derivation store guile system #:graft? #f)))))
+
+  (build-expression->derivation store name builder
+                                #:inputs inputs
+                                #:system system
+                                #:modules imported-modules
+                                #:outputs outputs
+                                #:guile-for-build guile-for-build))
+
+(define minify-build-system
+  (build-system
+    (name 'minify)
+    (description "The trivial JavaScript minification build system")
+    (lower lower)))
+
+;;; minify.scm ends here
diff --git a/guix/build/cmake-build-system.scm b/guix/build/cmake-build-system.scm
index 27f2b5c87..128ab28fe 100644
--- a/guix/build/cmake-build-system.scm
+++ b/guix/build/cmake-build-system.scm
@@ -32,7 +32,7 @@
 ;; Code:
 
 (define* (configure #:key outputs (configure-flags '()) (out-of-source? #t)
-                    build-type
+                    build-type target
                     #:allow-other-keys)
   "Configure the given package."
   (let* ((out        (assoc-ref outputs "out"))
@@ -59,6 +59,15 @@
                   ,(string-append "-DCMAKE_INSTALL_RPATH=" out "/lib")
                   ;; enable verbose output from builds
                   "-DCMAKE_VERBOSE_MAKEFILE=ON"
+
+                  ;;  Cross-build
+                  ,@(if target
+                        (list (string-append "-DCMAKE_C_COMPILER="
+                                             target "-gcc")
+                              (if (string-contains target "mingw")
+                                  "-DCMAKE_SYSTEM_NAME=Windows"
+                                  "-DCMAKE_SYSTEM_NAME=Linux"))
+                        '())
                   ,@configure-flags)))
       (format #t "running 'cmake' with arguments ~s~%" args)
       (zero? (apply system* "cmake" args)))))
diff --git a/guix/build/gnu-build-system.scm b/guix/build/gnu-build-system.scm
index 1786e2e3c..e37b75140 100644
--- a/guix/build/gnu-build-system.scm
+++ b/guix/build/gnu-build-system.scm
@@ -39,6 +39,13 @@
 ;;
 ;; Code:
 
+(cond-expand
+  (guile-2.2
+   ;; Guile 2.2.2 has a bug whereby 'time-monotonic' objects have seconds and
+   ;; nanoseconds swapped (fixed in Guile commit 886ac3e).  Work around it.
+   (define time-monotonic time-tai))
+  (else #t))
+
 (define* (set-SOURCE-DATE-EPOCH #:rest _)
   "Set the 'SOURCE_DATE_EPOCH' environment variable.  This is used by tools
 that incorporate timestamps as a way to tell them to use a fixed timestamp.
@@ -521,6 +528,25 @@ DOCUMENTATION-COMPRESSOR-FLAGS."
     ;; Return #t if FILE has hard links.
     (> (stat:nlink (lstat file)) 1))
 
+  (define (points-to-symlink? symlink)
+    ;; Return #t if SYMLINK points to another symbolic link.
+    (let* ((target (readlink symlink))
+           (target-absolute (if (string-prefix? "/" target)
+                                target
+                                (string-append (dirname symlink)
+                                               "/" target))))
+      (catch 'system-error
+        (lambda ()
+          (symbolic-link? target-absolute))
+        (lambda args
+          (if (= ENOENT (system-error-errno args))
+              (begin
+                (format (current-error-port)
+                        "The symbolic link '~a' target is missing: '~a'\n"
+                        symlink target-absolute)
+                #f)
+              (apply throw args))))))
+
   (define (maybe-compress-directory directory regexp)
     (or (not (directory-exists? directory))
         (match (find-files directory regexp)
@@ -538,12 +564,17 @@ DOCUMENTATION-COMPRESSOR-FLAGS."
                ;; Compress the non-symlink files, and adjust symlinks to refer
                ;; to the compressed files.  Leave files that have hard links
                ;; unchanged ('gzip' would refuse to compress them anyway.)
-               (and (zero? (apply system* documentation-compressor
-                                  (append documentation-compressor-flags
-                                          (remove has-links? regular-files))))
-                    (every retarget-symlink
-                           (filter (cut string-match regexp <>)
-                                   symlinks)))))))))
+               ;; Also, do not retarget symbolic links pointing to other
+               ;; symbolic links, since these are not compressed.
+               (and (every retarget-symlink
+                           (filter (lambda (symlink)
+                                     (and (not (points-to-symlink? symlink))
+                                          (string-match regexp symlink)))
+                                   symlinks))
+                    (zero?
+                     (apply system* documentation-compressor
+                            (append documentation-compressor-flags
+                                    (remove has-links? regular-files)))))))))))
 
   (define (maybe-compress output)
     (and (maybe-compress-directory (string-append output "/share/man")
diff --git a/guix/build/graft.scm b/guix/build/graft.scm
index 16df169ec..3dce486ad 100644
--- a/guix/build/graft.scm
+++ b/guix/build/graft.scm
@@ -164,15 +164,19 @@ bytevectors to the same value."
                ;; not to unget bytes that have already been written, because
                ;; that would cause them to be written again from the next
                ;; buffer.  In practice, this case occurs when a replacement is
-               ;; made near the end of the buffer.
-               (let* ((unwritten   (- end written))
-                      (unget-size  (if (= end request-size)
-                                       (min hash-length unwritten)
-                                       0))
-                      (write-size  (- unwritten unget-size)))
-                 (put-bytevector output buffer written write-size)
-                 (unget-bytevector input buffer (+ written write-size)
-                                   unget-size)
+               ;; made near or beyond the end of the buffer.  When REPLACEMENT
+               ;; went beyond END, we consume the extra bytes from INPUT.
+               (begin
+                 (if (> written end)
+                     (get-bytevector-n! input buffer 0 (- written end))
+                     (let* ((unwritten  (- end written))
+                            (unget-size (if (= end request-size)
+                                            (min hash-length unwritten)
+                                            0))
+                            (write-size (- unwritten unget-size)))
+                       (put-bytevector output buffer written write-size)
+                       (unget-bytevector input buffer (+ written write-size)
+                                         unget-size)))
                  (loop)))))))))
 
 (define (rename-matching-files directory mapping)
diff --git a/guix/build/minify-build-system.scm b/guix/build/minify-build-system.scm
new file mode 100644
index 000000000..3580deda0
--- /dev/null
+++ b/guix/build/minify-build-system.scm
@@ -0,0 +1,73 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2016 Ricardo Wurmus <rekado@elephly.net>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Guix is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (guix build minify-build-system)
+  #:use-module ((guix build gnu-build-system) #:prefix gnu:)
+  #:use-module ((guix build minify-build-system) #:prefix minify:)
+  #:use-module (guix build utils)
+  #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-26)
+  #:use-module (ice-9 popen)
+  #:export (%standard-phases
+            minify-build
+            minify))
+
+;; Commentary:
+;;
+;; Builder-side code of the standard minification procedure for JavaScript
+;; files.
+;;
+;; Code:
+
+(define* (minify file #:key target (directory ""))
+  (format #t "minifying ~a\n" file)
+  (let* ((base (basename file ".js"))
+         (installed (or target (string-append directory base ".min.js")))
+         (minified (open-pipe* OPEN_READ "uglify-js" file)))
+    (call-with-output-file installed
+      (cut dump-port minified <>))
+    #t))
+
+(define* (build #:key javascript-files
+                #:allow-other-keys)
+  (let ((files (or javascript-files
+                   (find-files "src" "\\.js$"))))
+    (mkdir-p "guix/build")
+    (every (cut minify <> #:directory "guix/build/") files)))
+
+(define* (install #:key outputs #:allow-other-keys)
+  (let* ((out (assoc-ref outputs "out"))
+         (js  (string-append out "/share/javascript/")))
+    (mkdir-p js)
+    (for-each (cut install-file <> js)
+              (find-files "guix/build" "\\.min\\.js$")))
+  #t)
+
+(define %standard-phases
+  (modify-phases gnu:%standard-phases
+    (delete 'configure)
+    (replace 'build build)
+    (delete 'check)
+    (replace 'install install)))
+
+(define* (minify-build #:key inputs (phases %standard-phases)
+                       #:allow-other-keys #:rest args)
+  "Build the given JavaScript package, applying all of PHASES in order."
+  (apply gnu:gnu-build #:inputs inputs #:phases phases args))
+
+;;; minify-build-system.scm ends here
diff --git a/guix/build/syscalls.scm b/guix/build/syscalls.scm
index 33a23edaa..55b0df391 100644
--- a/guix/build/syscalls.scm
+++ b/guix/build/syscalls.scm
@@ -726,15 +726,19 @@ mounted at FILE."
 (cond-expand
   (guile-2.2
    (define %set-automatic-finalization-enabled?!
-     (let ((proc (pointer->procedure int
-                                     (dynamic-func
-                                      "scm_set_automatic_finalization_enabled"
-                                      (dynamic-link))
-                                     (list int))))
+     ;; When using a statically-linked Guile, for instance in the initrd, we
+     ;; cannot resolve this symbol, but most of the time we don't need it
+     ;; anyway.  Thus, delay it.
+     (let ((proc (delay
+                   (pointer->procedure int
+                                       (dynamic-func
+                                        "scm_set_automatic_finalization_enabled"
+                                        (dynamic-link))
+                                       (list int)))))
        (lambda (enabled?)
          "Switch on or off automatic finalization in a separate thread.
 Turning finalization off shuts down the finalization thread as a side effect."
-         (->bool (proc (if enabled? 1 0))))))
+         (->bool ((force proc) (if enabled? 1 0))))))
 
    (define-syntax-rule (without-automatic-finalization exp)
      "Turn off automatic finalization within the dynamic extent of EXP."
diff --git a/guix/build/utils.scm b/guix/build/utils.scm
index e8efb0653..7391307c8 100644
--- a/guix/build/utils.scm
+++ b/guix/build/utils.scm
@@ -32,7 +32,12 @@
   #:use-module (rnrs bytevectors)
   #:use-module (rnrs io ports)
   #:re-export (alist-cons
-               alist-delete)
+               alist-delete
+
+               ;; Note: Re-export 'delete' to allow for proper syntax matching
+               ;; in 'modify-phases' forms.  See
+               ;; <https://debbugs.gnu.org/cgi/bugreport.cgi?bug=26805#16>.
+               delete)
   #:export (%store-directory
             store-file-name?
             strip-store-file-name
@@ -79,6 +84,7 @@
             fold-port-matches
             remove-store-references
             wrap-program
+            invoke
 
             locale-category->string))
 
@@ -574,6 +580,15 @@ Where every <*-phase-name> is an expression evaluating to a symbol, and
     ((_ phases (add-after old-phase-name new-phase-name new-phase))
      (alist-cons-after old-phase-name new-phase-name new-phase phases))))
 
+(define (invoke program . args)
+  "Invoke PROGRAM with the given ARGS.  Raise an error if the exit
+code is non-zero; otherwise return #t."
+  (let ((status (apply system* program args)))
+    (unless (zero? status)
+      (error (format #f "program ~s exited with non-zero code" program)
+             status))
+    #t))
+
 
 ;;;
 ;;; Text substitution (aka. sed).
diff --git a/guix/download.scm b/guix/download.scm
index c1da51547..ae381ee7a 100644
--- a/guix/download.scm
+++ b/guix/download.scm
@@ -67,12 +67,13 @@
        ,@(map (cut string-append <> "/gcc") gnu-mirrors))
       (gnupg
        "http://gd.tuwien.ac.at/privacy/gnupg/"
+       "http://artfiles.org/gnupg.org"
+       "http://www.crysys.hu/"
+       "https://gnupg.org/ftp/gcrypt/"
        "ftp://mirrors.dotsrc.org/gcrypt/"
        "ftp://mirror.cict.fr/gnupg/"
-       "http://artfiles.org/gnupg.org"
        "ftp://ftp.franken.de/pub/crypt/mirror/ftp.gnupg.org/gcrypt/"
        "ftp://ftp.freenet.de/pub/ftp.gnupg.org/gcrypt/"
-       "http://www.crysys.hu/"
        "ftp://ftp.hi.is/pub/mirrors/gnupg/"
        "ftp://ftp.heanet.ie/mirrors/ftp.gnupg.org/gcrypt/"
        "ftp://ftp.bit.nl/mirror/gnupg/"
@@ -114,7 +115,7 @@
        "http://jaist.dl.sourceforge.net/project/"
        "http://kent.dl.sourceforge.net/project/"
        "http://liquidtelecom.dl.sourceforge.net/project/"
-       "http://nbtelecom.dl.sourceforge.net/project/"
+       ;; "http://nbtelecom.dl.sourceforge.net/project/"  ;never returns 404s
        "http://nchc.dl.sourceforge.net/project/"
        "http://ncu.dl.sourceforge.net/project/"
        "http://netcologne.dl.sourceforge.net/project/"
@@ -277,7 +278,56 @@
        "http://kde.mirrors.tds.net/pub/kde/"
        ;; Oceania
        "http://ftp.kddlabs.co.jp/pub/X11/kde/"
-       "http://kde.mirror.uber.com.au/"))))
+       "http://kde.mirror.uber.com.au/")
+      (openbsd
+       "https://ftp.openbsd.org/pub/OpenBSD/"
+       ;; Anycast CDN redirecting to your friendly local mirror.
+       "https://mirrors.evowise.com/pub/OpenBSD/"
+       ;; Other HTTPS mirrors from https://www.openbsd.org/ftp.html
+       "https://mirror.aarnet.edu.au/pub/OpenBSD/"
+       "https://ftp2.eu.openbsd.org/pub/OpenBSD/"
+       "https://openbsd.c3sl.ufpr.br/pub/OpenBSD/"
+       "https://openbsd.ipacct.com/pub/OpenBSD/"
+       "https://ftp.OpenBSD.org/pub/OpenBSD/"
+       "https://openbsd.cs.toronto.edu/pub/OpenBSD/"
+       "https://openbsd.delfic.org/pub/OpenBSD/"
+       "https://openbsd.mirror.netelligent.ca/pub/OpenBSD/"
+       "https://mirrors.ucr.ac.cr/pub/OpenBSD/"
+       "https://mirrors.dotsrc.org/pub/OpenBSD/"
+       "https://mirror.one.com/pub/OpenBSD/"
+       "https://ftp.fr.openbsd.org/pub/OpenBSD/"
+       "https://ftp2.fr.openbsd.org/pub/OpenBSD/"
+       "https://mirrors.ircam.fr/pub/OpenBSD/"
+       "https://ftp.spline.de/pub/OpenBSD/"
+       "https://mirror.hs-esslingen.de/pub/OpenBSD/"
+       "https://ftp.halifax.rwth-aachen.de/openbsd/"
+       "https://ftp.hostserver.de/pub/OpenBSD/"
+       "https://ftp.fau.de/pub/OpenBSD/"
+       "https://ftp.cc.uoc.gr/pub/OpenBSD/"
+       "https://openbsd.hk/pub/OpenBSD/"
+       "https://ftp.heanet.ie/pub/OpenBSD/"
+       "https://openbsd.mirror.garr.it/pub/OpenBSD/"
+       "https://mirror.litnet.lt/pub/OpenBSD/"
+       "https://mirror.meerval.net/pub/OpenBSD/"
+       "https://ftp.nluug.nl/pub/OpenBSD/"
+       "https://ftp.bit.nl/pub/OpenBSD/"
+       "https://mirrors.dalenys.com/pub/OpenBSD/"
+       "https://ftp.icm.edu.pl/pub/OpenBSD/"
+       "https://ftp.rnl.tecnico.ulisboa.pt/pub/OpenBSD/"
+       "https://mirrors.pidginhost.com/pub/OpenBSD/"
+       "https://mirror.yandex.ru/pub/OpenBSD/"
+       "https://ftp.eu.openbsd.org/pub/OpenBSD/"
+       "https://ftp.yzu.edu.tw/pub/OpenBSD/"
+       "https://www.mirrorservice.org/pub/OpenBSD/"
+       "https://anorien.csc.warwick.ac.uk/pub/OpenBSD/"
+       "https://mirror.bytemark.co.uk/pub/OpenBSD/"
+       "https://mirrors.sonic.net/pub/OpenBSD/"
+       "https://ftp3.usa.openbsd.org/pub/OpenBSD/"
+       "https://mirrors.syringanetworks.net/pub/OpenBSD/"
+       "https://openbsd.mirror.constant.com/pub/OpenBSD/"
+       "https://ftp4.usa.openbsd.org/pub/OpenBSD/"
+       "https://ftp5.usa.openbsd.org/pub/OpenBSD/"
+       "https://mirror.esc7.net/pub/OpenBSD/"))))
 
 (define %mirror-file
   ;; Copy of the list of mirrors to a file.  This allows us to keep a single
diff --git a/guix/gexp.scm b/guix/gexp.scm
index d9c4cb461..2622c5cb6 100644
--- a/guix/gexp.scm
+++ b/guix/gexp.scm
@@ -269,8 +269,9 @@ vicinity of DIRECTORY."
           (string-append directory "/" file))
          (else file))))
 
-(define-syntax-rule (local-file file rest ...)
-  "Return an object representing local file FILE to add to the store; this
+(define-syntax local-file
+  (lambda (s)
+    "Return an object representing local file FILE to add to the store; this
 object can be used in a gexp.  If FILE is a relative file name, it is looked
 up relative to the source file where this form appears.  FILE will be added to
 the store under NAME--by default the base name of FILE.
@@ -283,10 +284,23 @@ When RECURSIVE? is true, call (SELECT?  FILE STAT) for each directory entry,
 where FILE is the entry's absolute file name and STAT is the result of
 'lstat'; exclude entries for which SELECT? does not return true.
 
-This is the declarative counterpart of the 'interned-file' monadic procedure."
-  (%local-file file
-               (delay (absolute-file-name file (current-source-directory)))
-               rest ...))
+This is the declarative counterpart of the 'interned-file' monadic procedure.
+It is implemented as a macro to capture the current source directory where it
+appears."
+    (syntax-case s ()
+      ((_ file rest ...)
+       #'(%local-file file
+                      (delay (absolute-file-name file (current-source-directory)))
+                      rest ...))
+      ((_)
+       #'(syntax-error "missing file name"))
+      (id
+       (identifier? #'id)
+       ;; XXX: We could return #'(lambda (file . rest) ...).  However,
+       ;; (syntax-source #'id) is #f so (current-source-directory) would not
+       ;; work.  Thus, simply forbid this form.
+       #'(syntax-error
+          "'local-file' is a macro and cannot be used like this")))))
 
 (define (local-file-absolute-file-name file)
   "Return the absolute file name for FILE, a <local-file> instance.  A
@@ -706,15 +720,17 @@ references; otherwise, return only non-native references."
            (cons `(,thing ,output) result)
            result))
       (($ <gexp-input> (lst ...) output n?)
-       (if (eqv? native? n?)
-           (fold-right add-reference-inputs result
-                       ;; XXX: For now, automatically convert LST to a list of
-                       ;; gexp-inputs.
-                       (map (match-lambda
-                              ((? gexp-input? x) x)
-                              (x (%gexp-input x "out" (or n? native?))))
-                            lst))
-           result))
+       (fold-right add-reference-inputs result
+                   ;; XXX: For now, automatically convert LST to a list of
+                   ;; gexp-inputs.  Inherit N?.
+                   (map (match-lambda
+                          ((? gexp-input? x)
+                           (%gexp-input (gexp-input-thing x)
+                                        (gexp-input-output x)
+                                        n?))
+                          (x
+                           (%gexp-input x "out" n?)))
+                        lst)))
       (_
        ;; Ignore references to other kinds of objects.
        result)))
diff --git a/guix/git-download.scm b/guix/git-download.scm
index 316835502..7397cbe7f 100644
--- a/guix/git-download.scm
+++ b/guix/git-download.scm
@@ -1,6 +1,7 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2014, 2015, 2016 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2014, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2017 Mathieu Lirzin <mthl@gnu.org>
+;;; Copyright © 2017 Christopher Baines <mail@cbaines.net>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -28,6 +29,7 @@
   #:use-module (ice-9 match)
   #:use-module (ice-9 popen)
   #:use-module (ice-9 rdelim)
+  #:use-module (ice-9 vlist)
   #:use-module (srfi srfi-1)
   #:export (git-reference
             git-reference?
@@ -125,45 +127,89 @@ HASH-ALGO (a symbol).  Use NAME as the file name, or a generic name if #f."
   "Return the file-name for packages using git-download."
   (string-append name "-" version "-checkout"))
 
+
+;;;
+;;; 'git-predicate'.
+;;;
+
+(define (files->directory-tree files)
+  "Return a tree of vhashes representing the directory listed in FILES, a list
+like '(\"a/b\" \"b/c/d\")."
+  (fold (lambda (file result)
+          (let loop ((file (string-split file #\/))
+                     (result result))
+            (match file
+              ((_)
+               result)
+              ((directory children ...)
+               (match (vhash-assoc directory result)
+                 (#f
+                  (vhash-cons directory (loop children vlist-null)
+                              result))
+                 ((_ . previous)
+                  ;; XXX: 'vhash-delete' is O(n).
+                  (vhash-cons directory (loop children previous)
+                              (vhash-delete directory result)))))
+              (()
+               result))))
+        vlist-null
+        files))
+
+(define (directory-in-tree? tree directory)
+  "Return true if DIRECTORY, a string like \"a/b\", denotes a directory listed
+in TREE."
+  (let loop ((directory (string-split directory #\/))
+             (tree       tree))
+    (match directory
+      (()
+       #t)
+      ((head . tail)
+       (match (vhash-assoc head tree)
+         ((_ . sub-tree) (loop tail sub-tree))
+         (#f #f))))))
+
 (define (git-predicate directory)
   "Return a predicate that returns true if a file is part of the Git checkout
 living at DIRECTORY.  Upon Git failure, return #f instead of a predicate.
 
 The returned predicate takes two arguments FILE and STAT where FILE is an
 absolute file name and STAT is the result of 'lstat'."
-  (define (parent-directory? thing directory)
-    ;; Return #t if DIRECTORY is the parent of THING.
-    (or (string-suffix? thing directory)
-        (and (string-index thing #\/)
-             (parent-directory? (dirname thing) directory))))
+  (let* ((pipe           (with-directory-excursion directory
+                           (open-pipe* OPEN_READ "git" "ls-files")))
+         (files          (let loop ((lines '()))
+                           (match (read-line pipe)
+                             ((? eof-object?)
+                              (reverse lines))
+                             (line
+                              (loop (cons line lines))))))
+         (directory-tree (files->directory-tree files))
+         (inodes         (fold (lambda (file result)
+                                 (let ((stat
+                                        (lstat (string-append directory "/"
+                                                              file))))
+                                   (vhash-consv (stat:ino stat) (stat:dev stat)
+                                                result)))
+                               vlist-null
+                               files))
+
+         ;; Note: For this to work we must *not* call 'canonicalize-path' on
+         ;; DIRECTORY or we would get discrepancies of the returned lambda is
+         ;; called with a non-canonical file name.
+         (prefix-length  (+ 1 (string-length directory)))
 
-  (let* ((pipe        (with-directory-excursion directory
-                        (open-pipe* OPEN_READ "git" "ls-files")))
-         (files       (let loop ((lines '()))
-                        (match (read-line pipe)
-                          ((? eof-object?)
-                           (reverse lines))
-                          (line
-                           (loop (cons line lines))))))
-         (inodes      (map (lambda (file)
-                             (let ((stat (lstat
-                                          (string-append directory "/" file))))
-                               (cons (stat:dev stat) (stat:ino stat))))
-                           files))
-         (status      (close-pipe pipe)))
+         (status         (close-pipe pipe)))
     (and (zero? status)
          (lambda (file stat)
            (match (stat:type stat)
              ('directory
-              ;; 'git ls-files' does not list directories, only regular files,
-              ;; so we need this special trick.
-              (any (lambda (f) (parent-directory? f file))
-                   files))
+              (directory-in-tree? directory-tree
+                                  (string-drop file prefix-length)))
              ((or 'regular 'symlink)
               ;; Comparing file names is always tricky business so we rely on
               ;; inode numbers instead
-              (member (cons (stat:dev stat) (stat:ino stat))
-                      inodes))
+              (match (vhash-assv (stat:ino stat) inodes)
+                ((_ . dev) (= dev (stat:dev stat)))
+                (#f        #f)))
              (_
               #f))))))
 
diff --git a/guix/import/cpan.scm b/guix/import/cpan.scm
index a41f91804..9ee69e529 100644
--- a/guix/import/cpan.scm
+++ b/guix/import/cpan.scm
@@ -296,7 +296,7 @@ META."
        (upstream-source
         (package (package-name package))
         (version version)
-        (urls url))))))
+        (urls (list url)))))))
 
 (define %cpan-updater
   (upstream-updater
diff --git a/guix/licenses.scm b/guix/licenses.scm
index 1bed56af2..b7dadd975 100644
--- a/guix/licenses.scm
+++ b/guix/licenses.scm
@@ -12,6 +12,7 @@
 ;;; Copyright © 2017 Clément Lassieur <clement@lassieur.org>
 ;;; Copyright © 2017 Petter <petter@mykolab.ch>
 ;;; Copyright © 2017 Marius Bakke <mbakke@fastmail.com>
+;;; Copyright © 2017 Arun Isaac <arunisaac@systemreboot.net>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -67,6 +68,7 @@
             lppl1.3a lppl1.3a+
             lppl1.3b lppl1.3b+
             lppl1.3c lppl1.3c+
+            miros
             mpl1.0 mpl1.1 mpl2.0
             ms-pl
             ncsa
@@ -452,6 +454,11 @@ at URI, which may be a file:// URI pointing the package's tree."
            "https://www.latex-project.org/lppl/lppl-1-3c/"
            "LaTeX Project Public License 1.3c or later"))
 
+(define miros
+  (license "MirOS"
+           "https://www.mirbsd.org/MirOS-Licence.htm"
+           "MirOS License"))
+
 (define mpl1.0
   (license "MPL 1.0"
            "http://www.mozilla.org/MPL/1.0/"
diff --git a/guix/packages.scm b/guix/packages.scm
index f60303404..f619d9b37 100644
--- a/guix/packages.scm
+++ b/guix/packages.scm
@@ -414,6 +414,13 @@ derivations."
   (let ((distro (resolve-interface '(gnu packages commencement))))
     (module-ref distro 'guile-final)))
 
+(define (guile-2.0)
+  "Return Guile 2.0."
+  ;; FIXME: This is used as a workaround for <https://bugs.gnu.org/28211> when
+  ;; grafting packages.
+  (let ((distro (resolve-interface '(gnu packages guile))))
+    (module-ref distro 'guile-2.0)))
+
 (define* (default-guile-derivation #:optional (system (%current-system)))
   "Return the derivation for SYSTEM of the default Guile package used to run
 the build code of derivation."
@@ -581,7 +588,12 @@ specifies modules in scope when evaluating SNIPPET."
                                                     #:fail-on-error? #t)))))
                         (zero? (apply system*
                                       (string-append #+tar "/bin/tar")
-                                      "cvfa" #$output
+                                      "cvf" #$output
+                                      ;; The bootstrap xz does not support
+                                      ;; threaded compression (introduced in
+                                      ;; 5.2.0), but it ignores the extra flag.
+                                      (string-append "--use-compress-program="
+                                                     #+xz "/bin/xz --threads=0")
                                       ;; avoid non-determinism in the archive
                                       "--mtime=@0"
                                       "--owner=root:0"
@@ -1140,7 +1152,7 @@ This is an internal procedure."
                   (()
                    drv)
                   (grafts
-                   (let ((guile (package-derivation store (default-guile)
+                   (let ((guile (package-derivation store (guile-2.0)
                                                     system #:graft? #f)))
                      ;; TODO: As an optimization, we can simply graft the tip
                      ;; of the derivation graph since 'graft-derivation'
@@ -1166,7 +1178,7 @@ system identifying string)."
                    (graft-derivation store drv grafts
                                      #:system system
                                      #:guile
-                                     (package-derivation store (default-guile)
+                                     (package-derivation store (guile-2.0)
                                                          system #:graft? #f))))
                 drv))))
 
diff --git a/guix/profiles.scm b/guix/profiles.scm
index 85c1722d6..0eb99f40d 100644
--- a/guix/profiles.scm
+++ b/guix/profiles.scm
@@ -1095,9 +1095,11 @@ files for the fonts of the @var{manifest} entries."
                                 (unless (and (zero? (system* mkfontscale))
                                              (zero? (system* mkfontdir)))
                                   (exit #f))
-                                (when (empty-file? fonts-scale-file)
+                                (when (and (file-exists? fonts-scale-file)
+                                           (empty-file? fonts-scale-file))
                                   (delete-file fonts-scale-file))
-                                (when (empty-file? fonts-dir-file)
+                                (when (and (file-exists? fonts-dir-file)
+                                           (empty-file? fonts-dir-file))
                                   (delete-file fonts-dir-file))))
                             directories)))))))
 
@@ -1313,40 +1315,6 @@ are cross-built for TARGET."
 (define (generation-numbers profile)
   "Return the sorted list of generation numbers of PROFILE, or '(0) if no
 former profiles were found."
-  (define* (scandir name #:optional (select? (const #t))
-                    (entry<? (@ (ice-9 i18n) string-locale<?)))
-    ;; XXX: Bug-fix version introduced in Guile v2.0.6-62-g139ce19.
-    (define (enter? dir stat result)
-      (and stat (string=? dir name)))
-
-    (define (visit basename result)
-      (if (select? basename)
-          (cons basename result)
-          result))
-
-    (define (leaf name stat result)
-      (and result
-           (visit (basename name) result)))
-
-    (define (down name stat result)
-      (visit "." '()))
-
-    (define (up name stat result)
-      (visit ".." result))
-
-    (define (skip name stat result)
-      ;; All the sub-directories are skipped.
-      (visit (basename name) result))
-
-    (define (error name* stat errno result)
-      (if (string=? name name*)             ; top-level NAME is unreadable
-          result
-          (visit (basename name*) result)))
-
-    (and=> (file-system-fold enter? leaf down up skip error #f name lstat)
-           (lambda (files)
-             (sort files entry<?))))
-
   (match (scandir (dirname profile)
                   (cute regexp-exec (profile-regexp profile) <>))
     (#f                                         ; no profile directory
diff --git a/guix/scripts/download.scm b/guix/scripts/download.scm
index bb3dc7674..f40213be3 100644
--- a/guix/scripts/download.scm
+++ b/guix/scripts/download.scm
@@ -143,12 +143,15 @@ Supported formats: 'nix-base32' (default), 'base32', and 'base16'
            (arg   (or (assq-ref opts 'argument)
                       (leave (G_ "no download URI was specified~%"))))
            (uri   (or (string->uri arg)
+                      (false-if-exception
+                       (string->uri
+                        (string-append "file://" (canonicalize-path arg))))
                       (leave (G_ "~a: failed to parse URI~%")
                              arg)))
            (fetch (assq-ref opts 'download-proc))
            (path  (parameterize ((current-terminal-columns
                                   (terminal-columns)))
-                    (fetch arg
+                    (fetch (uri->string uri)
                            #:verify-certificate?
                            (assq-ref opts 'verify-certificate?))))
            (hash  (call-with-input-file
diff --git a/guix/scripts/lint.scm b/guix/scripts/lint.scm
index 04ab85299..aceafc674 100644
--- a/guix/scripts/lint.scm
+++ b/guix/scripts/lint.scm
@@ -878,24 +878,39 @@ move to the previous or next line")
                                    #:key (reporters %formatting-reporters))
   "Report white-space issues in FILE starting from STARTING-LINE, and report
 them for PACKAGE."
-  (define last-line
-    ;; Number of the presumed last line.
-    ;; XXX: Ideally we'd stop at the boundaries of the surrounding sexp, but
-    ;; for now just use this simple heuristic.
-    (+ starting-line 60))
+  (define (sexp-last-line port)
+    ;; Return the last line of the sexp read from PORT or an estimate thereof.
+    (define &failure (list 'failure))
+
+    (let ((start      (ftell port))
+          (start-line (port-line port))
+          (sexp       (catch 'read-error
+                        (lambda () (read port))
+                        (const &failure))))
+      (let ((line (port-line port)))
+        (seek port start SEEK_SET)
+        (set-port-line! port start-line)
+        (if (eq? sexp &failure)
+            (+ start-line 60)                     ;conservative estimate
+            line))))
 
   (call-with-input-file file
     (lambda (port)
-      (let loop ((line-number 1))
+      (let loop ((line-number 1)
+                 (last-line #f))
         (let ((line (read-line port)))
           (or (eof-object? line)
-              (> line-number last-line)
-              (begin
-                (unless (< line-number starting-line)
-                  (for-each (lambda (report)
-                              (report package line line-number))
-                            reporters))
-                (loop (+ 1 line-number)))))))))
+              (and last-line (> line-number last-line))
+              (if (and (= line-number starting-line)
+                       (not last-line))
+                  (loop (+ 1 line-number)
+                        (+ 1 (sexp-last-line port)))
+                  (begin
+                    (unless (< line-number starting-line)
+                      (for-each (lambda (report)
+                                  (report package line line-number))
+                                reporters))
+                    (loop (+ 1 line-number) last-line)))))))))
 
 (define (check-formatting package)
   "Check the formatting of the source code of PACKAGE."
diff --git a/guix/scripts/offload.scm b/guix/scripts/offload.scm
index 566d117b0..d3cb64d60 100644
--- a/guix/scripts/offload.scm
+++ b/guix/scripts/offload.scm
@@ -400,6 +400,7 @@ allowed on MACHINE.  Return +∞ if MACHINE is unreachable."
                                      "cat" "/proc/loadavg"))
             (line (read-line pipe)))
        (close-port pipe)
+       (disconnect! session)
 
        (if (eof-object? line)
            +inf.0 ;MACHINE does not respond, so assume it is infinitely loaded
@@ -427,13 +428,9 @@ allowed on MACHINE.  Return +∞ if MACHINE is unreachable."
   "Return the name of the file used as a lock when choosing a build machine."
   (string-append %state-directory "/offload/machine-choice.lock"))
 
-
-(define %slots
-  ;; List of acquired build slots (open ports).
-  '())
-
 (define (choose-build-machine machines)
-  "Return the best machine among MACHINES, or #f."
+  "Return two values: the best machine among MACHINES and its build
+slot (which must later be released with 'release-build-slot'), or #f and #f."
 
   ;; Proceed like this:
   ;;   1. Acquire the global machine-choice lock.
@@ -480,14 +477,15 @@ allowed on MACHINE.  Return +∞ if MACHINE is unreachable."
                 ;; Release slots from the uninteresting machines.
                 (for-each release-build-slot slots)
 
-                ;; Prevent SLOT from being GC'd.
-                (set! %slots (cons slot %slots))
-                best))
+                ;; The caller must keep SLOT to protect it from GC and to
+                ;; eventually release it.
+                (values best slot)))
              (begin
                ;; BEST is overloaded, so try the next one.
                (release-build-slot slot)
                (loop others))))
-        (() #f)))))
+        (()
+         (values #f #f))))))
 
 (define* (process-request wants-local? system drv features
                           #:key
@@ -505,19 +503,25 @@ allowed on MACHINE.  Return +∞ if MACHINE is unreachable."
        ;; We'll never be able to match REQS.
        (display "# decline\n"))
       ((x ...)
-       (let ((machine (choose-build-machine candidates)))
+       (let-values (((machine slot)
+                     (choose-build-machine candidates)))
          (if machine
-             (begin
-               ;; Offload DRV to MACHINE.
-               (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?)))
+             (dynamic-wind
+               (const #f)
+               (lambda ()
+                 ;; Offload DRV to MACHINE.
+                 (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?)))
+               (lambda ()
+                 (release-build-slot slot)))
 
              ;; Not now, all the machines are busy.
              (display "# postpone\n")))))))
diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm
index 1273c09f5..c269a1fef 100644
--- a/guix/scripts/pack.scm
+++ b/guix/scripts/pack.scm
@@ -1,6 +1,7 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2015, 2017 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2017 Efraim Flashner <efraim@flashner.co.il>
+;;; Copyright © 2017 Ricardo Wurmus <rekado@elephly.net>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -50,19 +51,20 @@
   (compressor name extension command)
   compressor?
   (name       compressor-name)      ;string (e.g., "gzip")
-  (extension  compressor-extension) ;string (e.g., "lz")
+  (extension  compressor-extension) ;string (e.g., ".lz")
   (command    compressor-command))  ;gexp (e.g., #~("/gnu/store/…/gzip" "-9n"))
 
 (define %compressors
   ;; Available compression tools.
-  (list (compressor "gzip"  "gz"
+  (list (compressor "gzip"  ".gz"
                     #~(#+(file-append gzip "/bin/gzip") "-9n"))
-        (compressor "lzip"  "lz"
+        (compressor "lzip"  ".lz"
                     #~(#+(file-append lzip "/bin/lzip") "-9"))
-        (compressor "xz"    "xz"
+        (compressor "xz"    ".xz"
                     #~(#+(file-append xz "/bin/xz") "-e -T0"))
-        (compressor "bzip2" "bz2"
-                    #~(#+(file-append bzip2 "/bin/bzip2") "-9"))))
+        (compressor "bzip2" ".bz2"
+                    #~(#+(file-append bzip2 "/bin/bzip2") "-9"))
+        (compressor "none" "" #f)))
 
 (define (lookup-compressor name)
   "Return the compressor object called NAME.  Error out if it could not be
@@ -180,7 +182,7 @@ added to the pack."
                                           (_ #f))
                                         directives)))))))))
 
-  (gexp->derivation (string-append name ".tar."
+  (gexp->derivation (string-append name ".tar"
                                    (compressor-extension compressor))
                     build
                     #:references-graphs `(("profile" ,profile))))
@@ -245,7 +247,7 @@ the image."
                               #:compressor '#$(compressor-command compressor)
                               #:creation-time (make-time time-utc 0 1)))))
 
-  (gexp->derivation (string-append name ".tar."
+  (gexp->derivation (string-append name ".tar"
                                    (compressor-extension compressor))
                     build
                     #:references-graphs `(("profile" ,profile))))
diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm
index 58da3113a..fa45bd48a 100644
--- a/guix/scripts/package.scm
+++ b/guix/scripts/package.scm
@@ -84,12 +84,16 @@
   "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>
-  (if (and %user-profile-directory
-           (string=? (canonicalize-path (dirname profile))
-                     (dirname %user-profile-directory))
-           (string=? (basename profile) (basename %user-profile-directory)))
-      %current-profile
-      profile))
+
+  ;; 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
@@ -482,6 +486,11 @@ Install, remove, or upgrade packages in a single transaction.\n"))
                              arg-handler))))
          (option '(#\u "upgrade") #f #t
                  (lambda (opt name arg result arg-handler)
+                   (when (and arg (string-prefix? "-" arg))
+                     (warning (G_ "upgrade regexp '~a' looks like a \
+command-line option~%")
+                              arg)
+                     (warning (G_ "is this intended?~%")))
                    (let arg-handler ((arg arg) (result result))
                      (values (alist-cons 'upgrade arg
                                          ;; Delete any prior "upgrade all"
@@ -709,9 +718,12 @@ processed, #f otherwise."
                (raise (condition (&profile-not-found-error
                                   (profile profile)))))
               ((string-null? pattern)
-               (list-generation display-profile-content
-                                (car (profile-generations profile)))
-               (diff-profiles profile (profile-generations profile)))
+               (match (profile-generations profile)
+                 (()
+                  #t)
+                 ((first rest ...)
+                  (list-generation display-profile-content first)
+                  (diff-profiles profile (cons first rest)))))
               ((matching-generations pattern profile)
                =>
                (lambda (numbers)
diff --git a/guix/scripts/publish.scm b/guix/scripts/publish.scm
index a7e3e6d62..ade3c49a5 100644
--- a/guix/scripts/publish.scm
+++ b/guix/scripts/publish.scm
@@ -385,6 +385,24 @@ at a time."
                     (string-suffix? ".narinfo" file)))
       '()))
 
+(define (nar-expiration-time ttl)
+  "Return the narinfo expiration time (in seconds since the Epoch).  The
+expiration time is +inf.0 when passed an item that is still in the store; in
+other cases, it is the last-access time of the item plus TTL.
+
+This policy allows us to keep cached nars that correspond to valid store
+items.  Failing that, we could eventually have to recompute them and return
+404 in the meantime."
+  (let ((expiration-time (file-expiration-time ttl)))
+    (lambda (file)
+      (let ((item (string-append (%store-prefix) "/"
+                                 (basename file ".narinfo"))))
+        ;; Note: We don't need to use 'valid-path?' here because FILE would
+        ;; not exist if ITEM were not valid in the first place.
+        (if (file-exists? item)
+            +inf.0
+            (expiration-time file))))))
+
 (define* (render-narinfo/cached store request hash
                                 #:key ttl (compression %no-compression)
                                 (nar-path "nar")
@@ -417,7 +435,8 @@ requested using POOL."
                      (display (call-with-input-file cached
                                 read-string)
                               port))))
-          ((valid-path? store item)
+          ((and (file-exists? item)        ;cheaper than the 'valid-path?' RPC
+                (valid-path? store item))
            ;; Nothing in cache: bake the narinfo and nar in the background and
            ;; return 404.
            (eventually pool
@@ -435,7 +454,7 @@ requested using POOL."
                  (maybe-remove-expired-cache-entries cache
                                                      narinfo-files
                                                      #:entry-expiration
-                                                     (file-expiration-time ttl)
+                                                     (nar-expiration-time ttl)
                                                      #:delete-entry delete-entry
                                                      #:cleanup-period ttl))))
            (not-found request
@@ -565,13 +584,13 @@ has the given HASH of type ALGO."
                                " speaking.  Welcome!")))
                          port)))))
 
-(define extract-narinfo-hash
-  (let ((regexp (make-regexp "^([a-df-np-sv-z0-9]{32}).narinfo$")))
-    (lambda (str)
-      "Return the hash within the narinfo resource string STR, or false if STR
+(define (extract-narinfo-hash str)
+  "Return the hash within the narinfo resource string STR, or false if STR
 is invalid."
-      (and=> (regexp-exec regexp str)
-             (cut match:substring <> 1)))))
+  (and (string-suffix? ".narinfo" str)
+       (let ((base (string-drop-right str 8)))
+         (and (string-every %nix-base32-charset base)
+              base))))
 
 (define (get-request? request)
   "Return #t if REQUEST uses the GET method."
diff --git a/guix/scripts/pull.scm b/guix/scripts/pull.scm
index 58b87d4df..a1deec804 100644
--- a/guix/scripts/pull.scm
+++ b/guix/scripts/pull.scm
@@ -27,6 +27,7 @@
   #:use-module (guix derivations)
   #:use-module (guix download)
   #:use-module (guix gexp)
+  #:use-module (guix grafts)
   #:use-module (guix monads)
   #:use-module (guix scripts build)
   #:use-module ((guix build utils)
@@ -41,6 +42,7 @@
   #:use-module (gnu packages compression)
   #:use-module (gnu packages gnupg)
   #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-11)
   #:use-module (srfi srfi-34)
   #:use-module (srfi srfi-35)
   #:use-module (srfi srfi-37)
@@ -48,23 +50,39 @@
   #:use-module (ice-9 match)
   #:export (guix-pull))
 
-(define %snapshot-url
-  ;; "http://hydra.gnu.org/job/guix/master/tarball/latest/download"
-  "https://git.savannah.gnu.org/cgit/guix.git/snapshot/master.tar.gz"
-  )
+(module-autoload! (resolve-module '(guix scripts pull))
+                  '(git) '(git-error? set-tls-certificate-locations!)
+                  '(guix git) '(latest-repository-commit))
 
-(define-syntax-rule (with-environment-variable variable value body ...)
-  (let ((original (getenv variable)))
-    (dynamic-wind
-      (lambda ()
-        (setenv variable value))
-      (lambda ()
-        body ...)
-      (lambda ()
-        (setenv variable original)))))
+(define (ensure-guile-git!)
+  ;; Previously Guile-Git was not a prerequisite.  Thus, someone running 'guix
+  ;; pull' on an old installation may be lacking Guile-Git.  To address this,
+  ;; we autoload things that depend on Guile-Git and check in the entry point
+  ;; whether Guile-Git is available.
+  ;;
+  ;; TODO: Remove this hack when Guile-Git is widespread or enforced.
 
-(define-syntax-rule (with-PATH value body ...)
-  (with-environment-variable "PATH" value body ...))
+  (unless (false-if-exception (resolve-interface '(git)))
+    (leave (G_ "Guile-Git is missing but it is now required by 'guix pull'.
+Install it by running:
+
+  guix package -i ~a
+  export GUILE_LOAD_PATH=$HOME/.guix-profile/share/guile/site/~a:$GUILE_LOAD_PATH
+  export GUILE_LOAD_COMPILED_PATH=$HOME/.guix-profile/lib/guile/~a/site-ccache:$GUILE_LOAD_COMPILED_PATH
+\n")
+           (match (effective-version)
+             ("2.0" "guile2.0-git")
+             (_     "guile-git"))
+           (effective-version)
+           (effective-version)))
+
+  ;; XXX: For unclear reasons this is needed for
+  ;; 'set-tls-certificate-locations!'.
+  (module-use! (resolve-module '(guix scripts pull))
+               (resolve-interface '(git))))
+
+(define %repository-url
+  "https://git.savannah.gnu.org/git/guix.git")
 
 
 ;;;
@@ -73,7 +91,8 @@
 
 (define %default-options
   ;; Alist of default option values.
-  `((tarball-url . ,%snapshot-url)
+  `((repository-url . ,%repository-url)
+    (ref . (branch . "origin/master"))
     (system . ,(%current-system))
     (substitutes? . #t)
     (graft? . #t)
@@ -86,7 +105,11 @@ Download and deploy the latest version of Guix.\n"))
   (display (G_ "
       --verbose          produce verbose output"))
   (display (G_ "
-      --url=URL          download the Guix tarball from URL"))
+      --url=URL          download from the Git repository at URL"))
+  (display (G_ "
+      --commit=COMMIT    download the specified COMMIT"))
+  (display (G_ "
+      --branch=BRANCH    download the tip of the specified BRANCH"))
   (display (G_ "
       --bootstrap        use the bootstrap Guile to build the new Guix"))
   (newline)
@@ -105,8 +128,15 @@ Download and deploy the latest version of Guix.\n"))
                    (alist-cons 'verbose? #t result)))
          (option '("url") #t #f
                  (lambda (opt name arg result)
-                   (alist-cons 'tarball-url arg
-                               (alist-delete 'tarball-url result))))
+                   (alist-cons 'repository-url arg
+                               (alist-delete 'repository-url result))))
+         (option '("commit") #t #f
+                 (lambda (opt name arg result)
+                   (alist-cons 'ref `(commit . ,arg) result)))
+         (option '("branch") #t #f
+                 (lambda (opt name arg result)
+                   (alist-cons 'ref `(branch . ,(string-append "origin/" arg))
+                               result)))
          (option '(#\n "dry-run") #f #f
                  (lambda (opt name arg result)
                    (alist-cons 'dry-run? #t (alist-cons 'graft? #f result))))
@@ -129,81 +159,30 @@ Download and deploy the latest version of Guix.\n"))
 (define indirect-root-added
   (store-lift add-indirect-root))
 
-(define (temporary-directory)
-  "Make a temporary directory and return its name."
-  (let ((name (tmpnam)))
-    (mkdir name)
-    (chmod name #o700)
-    name))
-
-(define (first-directory directory)
-  "Return a the name of the first file found under DIRECTORY."
-  (match (scandir directory
-                  (lambda (name)
-                    (and (not (member name '("." "..")))
-                         (file-is-directory? name))))
-    ((directory)
-     directory)
-    (x
-     (raise (condition
-             (&message
-              (message "tarball did not produce a single source directory")))))))
-
-(define (interned-then-deleted directory name)
-  "Add DIRECTORY to the store under NAME, and delete it.  Return the resulting
-store file name."
-  (mlet %store-monad ((result (interned-file directory name
-                                             #:recursive? #t)))
-    (delete-file-recursively directory)
-    (return result)))
-
-(define (unpack tarball)
-  "Return the name of the directory where TARBALL has been unpacked."
-  (mlet* %store-monad ((format -> (lift format %store-monad))
-                       (tar  (package->derivation tar))
-                       (gzip (package->derivation gzip)))
-    (mbegin %store-monad
-      (what-to-build (list tar gzip))
-      (built-derivations (list tar gzip))
-      (format #t (G_ "unpacking '~a'...~%") tarball)
-
-      (let ((source (temporary-directory)))
-        (with-directory-excursion source
-          (with-PATH (string-append (derivation->output-path gzip) "/bin")
-            (unless (zero? (system* (string-append (derivation->output-path tar)
-                                                   "/bin/tar")
-                                    "xf" tarball))
-              (raise (condition
-                      (&message (message "failed to unpack source code"))))))
-
-          (interned-then-deleted (string-append source "/"
-                                                (first-directory source))
-                                 "guix-source"))))))
-
 (define %self-build-file
   ;; The file containing code to build Guix.  This serves the same purpose as
   ;; a makefile, and, similarly, is intended to always keep this name.
   "build-aux/build-self.scm")
 
-(define* (build-from-source tarball #:key verbose?)
-  "Return a derivation to build Guix from TARBALL, using the self-build script
-contained therein."
+(define* (build-from-source source
+                            #:key verbose? commit)
+  "Return a derivation to build Guix from SOURCE, using the self-build script
+contained therein.  Use COMMIT as the version string."
   ;; Running the self-build script makes it easier to update the build
   ;; procedure: the self-build script of the Guix-to-be-installed contains the
   ;; right dependencies, build procedure, etc., which the Guix-in-use may not
   ;; be know.
-  (mlet* %store-monad ((source (unpack tarball))
-                       (script -> (string-append source "/"
-                                                 %self-build-file))
-                       (build -> (primitive-load script)))
+  (let* ((script (string-append source "/" %self-build-file))
+         (build  (primitive-load script)))
     ;; BUILD must be a monadic procedure of at least one argument: the source
     ;; tree.
-    (build source #:verbose? verbose?)))
+    (build source #:verbose? verbose? #:version commit)))
 
-(define* (build-and-install tarball config-dir
-                            #:key verbose?)
-  "Build the tool from TARBALL, and install it in CONFIG-DIR."
-  (mlet* %store-monad ((source        (build-from-source tarball
+(define* (build-and-install source config-dir
+                            #:key verbose? 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)))
@@ -227,44 +206,87 @@ contained therein."
                 (return #t))))
         (leave (G_ "failed to update Guix, check the build log~%")))))
 
+(define (honor-lets-encrypt-certificates! store)
+  "Tell Guile-Git to use the Let's Encrypt certificates."
+  (let* ((drv   (package-derivation store le-certs))
+         (certs (string-append (derivation->output-path drv)
+                               "/etc/ssl/certs")))
+    (build-derivations store (list drv))
+
+    ;; In the past Guile-Git would not provide this procedure.
+    (if (module-defined? (resolve-interface '(git))
+                         'set-tls-certificate-locations!)
+        (set-tls-certificate-locations! certs)
+        (begin
+          ;; In this case we end up using whichever certificates OpenSSL
+          ;; chooses to use: $SSL_CERT_FILE, $SSL_CERT_DIR, or /etc/ssl/certs.
+          (warning (G_ "cannot enforce use of the Let's Encrypt \
+certificates~%"))
+          (warning (G_ "please upgrade Guile-Git~%"))))))
+
+(define (report-git-error error)
+  "Report the given Guile-Git error."
+  ;; Prior to Guile-Git commit b6b2760c2fd6dfaa5c0fedb43eeaff06166b3134,
+  ;; errors would be represented by integers.
+  (match error
+    ((? integer? error)                           ;old Guile-Git
+     (leave (G_ "Git error ~a~%") error))
+    ((? git-error? error)                         ;new Guile-Git
+     (leave (G_ "Git error: ~a~%") (git-error-message error)))))
+
+(define-syntax-rule (with-git-error-handling body ...)
+  (catch 'git-error
+    (lambda ()
+      body ...)
+    (lambda (key err)
+      (report-git-error err))))
+
 
 (define (guix-pull . args)
   (define (use-le-certs? url)
     (string-prefix? "https://git.savannah.gnu.org/" url))
 
-  (define (fetch-tarball store url)
-    (download-to-store store url "guix-latest.tar.gz"))
-
   (with-error-handling
-    (let* ((opts  (parse-command-line args %options
-                                      (list %default-options)))
-           (url   (assoc-ref opts 'tarball-url)))
-      (unless (assoc-ref opts 'dry-run?)          ;XXX: not very useful
-        (with-store store
-          (set-build-options-from-command-line store opts)
-          (let ((tarball
-                 (if (use-le-certs? url)
-                     (let* ((drv (package-derivation store le-certs))
-                            (certs (string-append (derivation->output-path drv)
-                                                  "/etc/ssl/certs")))
-                       (build-derivations store (list drv))
-                       (parameterize ((%x509-certificate-directory certs))
-                         (fetch-tarball store url)))
-                     (fetch-tarball store url))))
-            (unless tarball
-              (leave (G_ "failed to download up-to-date source, exiting\n")))
-            (parameterize ((%guile-for-build
-                            (package-derivation store
-                                                (if (assoc-ref opts 'bootstrap?)
-                                                    %bootstrap-guile
-                                                    (canonical-package guile-2.0)))))
-              (run-with-store store
-                (build-and-install tarball (config-directory)
-                                   #:verbose? (assoc-ref opts 'verbose?))))))))))
+    (with-git-error-handling
+     (let* ((opts  (parse-command-line args %options
+                                       (list %default-options)))
+            (url   (assoc-ref opts 'repository-url))
+            (ref   (assoc-ref opts 'ref))
+            (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)))
 
-;; Local Variables:
-;; eval: (put 'with-PATH 'scheme-indent-function 1)
-;; eval: (put 'with-temporary-directory 'scheme-indent-function 1)
-;; End:
+               (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.0)))))
+                 (run-with-store store
+                   (build-and-install checkout (config-directory)
+                                      #:commit commit
+                                      #:verbose?
+                                      (assoc-ref opts 'verbose?))))))))))))
 
 ;;; pull.scm ends here
diff --git a/guix/scripts/substitute.scm b/guix/scripts/substitute.scm
index 934859919..0d36997bc 100755
--- a/guix/scripts/substitute.scm
+++ b/guix/scripts/substitute.scm
@@ -47,6 +47,7 @@
   #:use-module (ice-9 format)
   #:use-module (ice-9 ftw)
   #:use-module (ice-9 binary-ports)
+  #:use-module (ice-9 vlist)
   #:use-module (rnrs bytevectors)
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-9)
@@ -112,7 +113,7 @@
       (or (and=> (getenv "XDG_CACHE_HOME")
                  (cut string-append <> "/guix/substitute"))
           (string-append %state-directory "/substitute/cache"))
-      (string-append (cache-directory) "/substitute")))
+      (string-append (cache-directory #:ensure? #f) "/substitute")))
 
 (define %allow-unauthenticated-substitutes?
   ;; Whether to allow unchecked substitutes.  This is useful for testing
@@ -600,15 +601,27 @@ if file doesn't exist, and the narinfo otherwise."
 (define (fetch-narinfos url paths)
   "Retrieve all the narinfos for PATHS from the cache at URL and return them."
   (define update-progress!
-    (let ((done 0))
+    (let ((done 0)
+          (total (length paths)))
       (lambda ()
         (display #\cr (current-error-port))
         (force-output (current-error-port))
         (format (current-error-port)
                 (G_ "updating list of substitutes from '~a'... ~5,1f%")
-                url (* 100. (/ done (length paths))))
+                url (* 100. (/ done total)))
         (set! done (+ 1 done)))))
 
+  (define hash-part->path
+    (let ((mapping (fold (lambda (path result)
+                           (vhash-cons (store-path-hash-part path) path
+                                       result))
+                         vlist-null
+                         paths)))
+      (lambda (hash)
+        (match (vhash-assoc hash mapping)
+          (#f #f)
+          ((_ . path) path)))))
+
   (define (handle-narinfo-response request response port result)
     (let* ((code   (response-code response))
            (len    (response-content-length response))
@@ -627,9 +640,7 @@ if file doesn't exist, and the narinfo otherwise."
             (if len
                 (get-bytevector-n port len)
                 (read-to-eof port))
-            (cache-narinfo! url
-                            (find (cut string-contains <> hash-part) paths)
-                            #f
+            (cache-narinfo! url (hash-part->path hash-part) #f
                             (if (= 404 code)
                                 ttl
                                 %narinfo-transient-error-ttl))
diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm
index 65dd92e8b..8793c4092 100644
--- a/guix/scripts/system.scm
+++ b/guix/scripts/system.scm
@@ -150,7 +150,7 @@ TARGET, and register them."
 (define* (install-bootloader installer-drv
                              #:key
                              bootcfg bootcfg-file
-                             device target)
+                             target)
   "Call INSTALLER-DRV with error handling, in %STORE-MONAD."
   (with-monad %store-monad
     (let* ((gc-root      (string-append target %gc-roots-directory
@@ -169,7 +169,7 @@ TARGET, and register them."
                  (when install
                    (save-load-path-excursion (primitive-load install)))))
         (delete-file temp-gc-root)
-        (leave (G_ "failed to install bootloader on device ~a '~a'~%") install device))
+        (leave (G_ "failed to install bootloader ~a~%") install))
 
       ;; Register bootloader config file as a GC root so that its dependencies
       ;; (background image, font, etc.) are not reclaimed.
@@ -179,13 +179,12 @@ TARGET, and register them."
 (define* (install os-drv target
                   #:key (log-port (current-output-port))
                   bootloader-installer install-bootloader?
-                  bootcfg bootcfg-file
-                  device)
+                  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.
 
-When INSTALL-BOOTLOADER? is true, install bootloader on DEVICE, using BOOTCFG."
+When INSTALL-BOOTLOADER? is true, install bootloader using BOOTCFG."
   (define (maybe-copy to-copy)
     (with-monad %store-monad
       (if (string=? target "/")
@@ -227,7 +226,6 @@ the ownership of '~a' may be incorrect!~%")
         (install-bootloader bootloader-installer
                             #:bootcfg bootcfg
                             #:bootcfg-file bootcfg-file
-                            #:device device
                             #:target target)))))
 
 
@@ -431,8 +429,6 @@ generation as its default entry.  STORE is an open connection to the store."
   "Re-install bootloader for existing system profile generation NUMBER.
 STORE is an open connection to the store."
   (let* ((generation (generation-file-name %system-profile number))
-         (params (unless-file-not-found
-                  (read-boot-parameters-file generation)))
          ;; Detect the bootloader used in %system-profile.
          (bootloader (lookup-bootloader-by-name (system-bootloader-name)))
 
@@ -442,10 +438,12 @@ STORE is an open connection to the store."
                              (bootloader bootloader)))
 
          ;; Make the specified system generation the default entry.
-         (entries (profile-boot-parameters %system-profile (list number)))
+         (params (profile-boot-parameters %system-profile (list number)))
          (old-generations (delv number (generation-numbers %system-profile)))
-         (old-entries (profile-boot-parameters
-                       %system-profile old-generations)))
+         (old-params (profile-boot-parameters
+                       %system-profile old-generations))
+         (entries (map boot-parameters->menu-entry params))
+         (old-entries (map boot-parameters->menu-entry old-params)))
     (run-with-store store
       (mlet* %store-monad
           ((bootcfg ((bootloader-configuration-file-generator bootloader)
@@ -457,12 +455,11 @@ STORE is an open connection to the store."
         (mbegin %store-monad
           (show-what-to-build* drvs)
           (built-derivations drvs)
-          ;; Only install bootloader configuration file. Thus, no installer
-          ;; nor device is provided here.
+          ;; Only install bootloader configuration file. Thus, no installer is
+          ;; provided here.
           (install-bootloader #f
                               #:bootcfg bootcfg
                               #:bootcfg-file bootcfg-file
-                              #:device #f
                               #:target target))))))
 
 
@@ -579,8 +576,12 @@ PATTERN, a string.  When PATTERN is #f, display all the system generations."
                                                 (* 70 (expt 2 20)))
                                             #:mappings mappings))
     ((disk-image)
-     (system-disk-image os #:disk-image-size image-size
-                           #:file-system-type file-system-type))))
+     (system-disk-image os
+                        #:name (match file-system-type
+                                 ("iso9660" "image.iso")
+                                 (_         "disk-image"))
+                        #:disk-image-size image-size
+                        #:file-system-type file-system-type))))
 
 (define (maybe-suggest-running-guix-pull)
   "Suggest running 'guix pull' if this has never been done before."
@@ -611,17 +612,16 @@ and TARGET arguments."
 (define* (perform-action action os
                          #:key install-bootloader?
                          dry-run? derivations-only?
-                         use-substitutes? device target
+                         use-substitutes? bootloader-target target
                          image-size file-system-type full-boot?
                          (mappings '())
                          (gc-root #f))
   "Perform ACTION for OS.  INSTALL-BOOTLOADER? specifies whether to install
-bootloader; DEVICE is the target devices for bootloader; TARGET is the target
-root directory; IMAGE-SIZE is the size of the image to be built, for the
-'vm-image' and 'disk-image' actions.
-The root filesystem is created as a FILE-SYSTEM-TYPE filesystem.
-FULL-BOOT? is used for the 'vm' action;
-it determines whether to boot directly to the kernel or to the bootloader.
+bootloader; BOOTLOADER-TAGET is the target for the bootloader; TARGET is the
+target root directory; IMAGE-SIZE is the size of the image to be built, for
+the 'vm-image' and 'disk-image' actions.  The root filesystem is created as a
+FILE-SYSTEM-TYPE filesystem.  FULL-BOOT? is used for the 'vm' action; it
+determines whether to boot directly to the kernel or to the bootloader.
 
 When DERIVATIONS-ONLY? is true, print the derivation file name(s) without
 building anything.
@@ -653,14 +653,15 @@ output when building a system derivation, such as a disk image."
                       os
                       (if (eq? 'init action)
                           '()
-                          (profile-boot-parameters)))))
+                          (map boot-parameters->menu-entry
+                               (profile-boot-parameters))))))
        (bootcfg-file -> (bootloader-configuration-file bootloader))
        (bootloader-installer
         (let ((installer (bootloader-installer bootloader))
               (target    (or target "/")))
           (bootloader-installer-derivation installer
                                            bootloader-package
-                                           device target)))
+                                           bootloader-target target)))
 
        ;; For 'init' and 'reconfigure', always build BOOTCFG, even if
        ;; --no-bootloader is passed, because we then use it as a GC root.
@@ -692,7 +693,6 @@ output when building a system derivation, such as a disk image."
                  (install-bootloader bootloader-installer
                                      #:bootcfg bootcfg
                                      #:bootcfg-file bootcfg-file
-                                     #:device device
                                      #:target "/"))))
             ((init)
              (newline)
@@ -702,8 +702,7 @@ output when building a system derivation, such as a disk image."
                       #:install-bootloader? install-bootloader?
                       #:bootcfg bootcfg
                       #:bootcfg-file bootcfg-file
-                      #:bootloader-installer bootloader-installer
-                      #:device device))
+                      #:bootloader-installer bootloader-installer))
             (else
              ;; All we had to do was to build SYS and maybe register an
              ;; indirect GC root.
@@ -895,8 +894,9 @@ resulting from command-line parsing."
          (target      (match args
                         ((first second) second)
                         (_ #f)))
-         (device      (and bootloader?
-                           (bootloader-configuration-device
+         (bootloader-target
+                      (and bootloader?
+                           (bootloader-configuration-target
                             (operating-system-bootloader os)))))
 
     (with-store store
@@ -929,7 +929,8 @@ resulting from command-line parsing."
                                                       (_ #f))
                                                     opts)
                              #:install-bootloader? bootloader?
-                             #:target target #:device device
+                             #:target target
+                             #:bootloader-target bootloader-target
                              #:gc-root (assoc-ref opts 'gc-root)))))
         #:system system))))
 
diff --git a/guix/scripts/weather.scm b/guix/scripts/weather.scm
new file mode 100644
index 000000000..4c4dfac8f
--- /dev/null
+++ b/guix/scripts/weather.scm
@@ -0,0 +1,234 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2017 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2017 Ricardo Wurmus <rekado@elephly.net>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Guix is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (guix scripts weather)
+  #:use-module (guix ui)
+  #:use-module (guix scripts)
+  #:use-module (guix packages)
+  #:use-module (guix profiles)
+  #:use-module (guix derivations)
+  #:use-module (guix monads)
+  #:use-module (guix store)
+  #:use-module (guix grafts)
+  #:use-module (guix build syscalls)
+  #:use-module (guix scripts substitute)
+  #:use-module (gnu packages)
+  #:use-module (web uri)
+  #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-19)
+  #:use-module (srfi srfi-26)
+  #:use-module (srfi srfi-37)
+  #:use-module (ice-9 match)
+  #:use-module (ice-9 format)
+  #:export (guix-weather))
+
+(define (all-packages)
+  "Return the list of public packages we are going to query."
+  (fold-packages (lambda (package result)
+                   (match (package-replacement package)
+                     ((? package? replacement)
+                      (cons* replacement package result))
+                     (#f
+                      (cons package result))))
+                 '()))
+
+(define* (package-outputs packages
+                          #:optional (system (%current-system)))
+  "Return the list of outputs of all of PACKAGES for the given SYSTEM."
+  (let ((packages (filter (cut supported-package? <> system) packages)))
+
+    (define update-progress!
+      (let ((total (length packages))
+            (done  0)
+            (width (max 10 (- (terminal-columns) 10))))
+        (lambda ()
+          (set! done (+ 1 done))
+          (let* ((ratio (/ done total 1.))
+                 (done  (inexact->exact (round (* width ratio))))
+                 (left  (- width done)))
+            (format (current-error-port) "~5,1f% [~a~a]\r"
+                    (* ratio 100.)
+                    (make-string done #\#)
+                    (make-string left #\space))
+            (when (>= done total)
+              (newline (current-error-port)))
+            (force-output (current-error-port))))))
+
+    (format (current-error-port)
+            (G_ "computing ~h package derivations for ~a...~%")
+            (length packages) system)
+
+    (foldm %store-monad
+           (lambda (package result)
+             (mlet %store-monad ((drv (package->derivation package system
+                                                           #:graft? #f)))
+               (update-progress!)
+               (match (derivation->output-paths drv)
+                 (((names . items) ...)
+                  (return (append items result))))))
+           '()
+           packages)))
+
+(cond-expand
+  (guile-2.2
+   ;; Guile 2.2.2 has a bug whereby 'time-monotonic' objects have seconds and
+   ;; nanoseconds swapped (fixed in Guile commit 886ac3e).  Work around it.
+   (define time-monotonic time-tai))
+  (else #t))
+
+(define (call-with-time thunk kont)
+  "Call THUNK and pass KONT the elapsed time followed by THUNK's return
+values."
+  (let* ((start  (current-time time-monotonic))
+         (result (call-with-values thunk list))
+         (end    (current-time time-monotonic)))
+    (apply kont (time-difference end start) result)))
+
+(define-syntax-rule (let/time ((time result exp)) body ...)
+  (call-with-time (lambda () exp) (lambda (time result) body ...)))
+
+(define (report-server-coverage server items)
+  "Report the subset of ITEMS available as substitutes on SERVER."
+  (define MiB (* (expt 2 20) 1.))
+
+  (format #t (G_ "looking for ~h store items on ~a...~%")
+          (length items) server)
+
+  (let/time ((time narinfos (lookup-narinfos server items)))
+    (format #t "~a~%" server)
+    (let ((obtained  (length narinfos))
+          (requested (length items))
+          (sizes     (filter-map narinfo-file-size narinfos))
+          (time      (+ (time-second time)
+                        (/ (time-nanosecond time) 1e9))))
+      (format #t (G_ "  ~2,1f% substitutes available (~h out of ~h)~%")
+              (* 100. (/ obtained requested 1.))
+              obtained requested)
+      (let ((total (/ (reduce + 0 sizes) MiB)))
+        (match (length sizes)
+          ((? zero?)
+           (format #t (G_  "  unknown substitute sizes~%")))
+          (len
+           (if (= len obtained)
+               (format #t (G_ "  ~,1h MiB of nars (compressed)~%") total)
+               (format #t (G_ "  at least ~,1h MiB of nars (compressed)~%")
+                       total)))))
+      (format #t (G_ "  ~,1h MiB on disk (uncompressed)~%")
+              (/ (reduce + 0 (map narinfo-size narinfos)) MiB))
+      (format #t (G_ "  ~,3h seconds per request (~,1h seconds in total)~%")
+              (/ time requested 1.) time)
+      (format #t (G_ "  ~,1h requests per second~%")
+              (/ requested time 1.)))))
+
+
+;;;
+;;; Command-line options.
+;;;
+
+(define (show-help)
+  (display (G_ "Usage: guix weather [OPTIONS]
+Report the availability of substitutes.\n"))
+  (display (G_ "
+      --substitute-urls=URLS
+                         check for available substitutes at URLS"))
+  (display (G_ "
+  -m, --manifest=MANIFEST
+                         look up substitutes for packages specified in MANIFEST"))
+  (display (G_ "
+  -s, --system=SYSTEM    consider substitutes for SYSTEM--e.g., \"i686-linux\""))
+  (newline)
+  (display (G_ "
+  -h, --help             display this help and exit"))
+  (display (G_ "
+  -V, --version          display version information and exit"))
+  (newline)
+  (show-bug-report-information))
+
+(define %options
+  (list  (option '(#\h "help") #f #f
+                 (lambda args
+                   (show-help)
+                   (exit 0)))
+         (option '(#\V "version") #f #f
+                 (lambda args
+                   (show-version-and-exit "guix challenge")))
+
+         (option '("substitute-urls") #t #f
+                 (lambda (opt name arg result . rest)
+                   (let ((urls (string-tokenize arg)))
+                     (for-each (lambda (url)
+                                 (unless (string->uri url)
+                                   (leave (G_ "~a: invalid URL~%") url)))
+                               urls)
+                     (apply values
+                            (alist-cons 'substitute-urls urls
+                                        (alist-delete 'substitute-urls result))
+                            rest))))
+         (option '(#\m "manifest") #t #f
+                 (lambda (opt name arg result)
+                   (alist-cons 'manifest arg result)))
+         (option '(#\s "system") #t #f
+                 (lambda (opt name arg result)
+                   (alist-cons 'system arg result)))))
+
+(define %default-options
+  `((substitute-urls . ,%default-substitute-urls)))
+
+(define (load-manifest file)
+  "Load the manifest from FILE and return the list of packages it refers to."
+  (let* ((user-module (make-user-module '((guix profiles) (gnu))))
+         (manifest    (load* file user-module)))
+    (map manifest-entry-item
+         (manifest-transitive-entries manifest))))
+
+
+;;;
+;;; Entry point.
+;;;
+
+(define (guix-weather . args)
+  (with-error-handling
+    (let* ((opts     (parse-command-line args %options
+                                         (list %default-options)))
+           (urls     (assoc-ref opts 'substitute-urls))
+           (systems  (match (filter-map (match-lambda
+                                          (('system . system) system)
+                                          (_ #f))
+                                        opts)
+                       (() (list (%current-system)))
+                       (systems systems)))
+           (packages (let ((file (assoc-ref opts 'manifest)))
+                       (if file
+                           (load-manifest file)
+                           (all-packages))))
+           (items    (with-store store
+                       (parameterize ((%graft? #f))
+                         (concatenate
+                          (run-with-store store
+                            (mapm %store-monad
+                                  (lambda (system)
+                                    (package-outputs packages system))
+                                  systems)))))))
+      (for-each (lambda (server)
+                  (report-server-coverage server items))
+                urls))))
+
+;;; Local Variables:
+;;; eval: (put 'let/time 'scheme-indent-function 1)
+;;; End:
diff --git a/guix/store.scm b/guix/store.scm
index b15da5485..2563d26fa 100644
--- a/guix/store.scm
+++ b/guix/store.scm
@@ -1549,9 +1549,12 @@ valid inputs."
 (define (store-path-hash-part path)
   "Return the hash part of PATH as a base32 string, or #f if PATH is not a
 syntactically valid store path."
-  (let ((path-rx (store-regexp* (%store-prefix))))
-    (and=> (regexp-exec path-rx path)
-           (cut match:substring <> 1))))
+  (and (string-prefix? (%store-prefix) path)
+       (let ((base (string-drop path (+ 1 (string-length (%store-prefix))))))
+         (and (> (string-length base) 33)
+              (let ((hash (string-take base 32)))
+                (and (string-every %nix-base32-charset hash)
+                     hash))))))
 
 (define (log-file store file)
   "Return the build log file for FILE, or #f if none could be found.  FILE
diff --git a/guix/ui.scm b/guix/ui.scm
index 4bad00e8c..b0108d070 100644
--- a/guix/ui.scm
+++ b/guix/ui.scm
@@ -36,7 +36,6 @@
   #:use-module (guix combinators)
   #:use-module (guix build-system)
   #:use-module (guix serialization)
-  #:use-module ((guix build utils) #:select (mkdir-p))
   #:use-module ((guix licenses) #:select (license? license-name))
   #:use-module ((guix build syscalls)
                 #:select (free-disk-space terminal-columns))
@@ -79,7 +78,6 @@
             read/eval
             read/eval-package-expression
             location->string
-            config-directory
             fill-paragraph
             texi->plain-text
             package-description-string
@@ -856,25 +854,6 @@ replacement if PORT is not Unicode-capable."
     (($ <location> file line column)
      (format #f "~a:~a:~a" file line column))))
 
-(define* (config-directory #:key (ensure? #t))
-  "Return the name of the configuration directory, after making sure that it
-exists if ENSURE? is true.  Honor the XDG specs,
-<http://standards.freedesktop.org/basedir-spec/basedir-spec-latest.html>."
-  (let ((dir (and=> (or (getenv "XDG_CONFIG_HOME")
-                        (and=> (getenv "HOME")
-                               (cut string-append <> "/.config")))
-                    (cut string-append <> "/guix"))))
-    (catch 'system-error
-      (lambda ()
-        (when ensure?
-          (mkdir-p dir))
-        dir)
-      (lambda args
-        (let ((err (system-error-errno args)))
-          ;; ERR is necessarily different from EEXIST.
-          (leave (G_ "failed to create configuration directory `~a': ~a~%")
-                 dir (strerror err)))))))
-
 (define* (fill-paragraph str width #:optional (column 0))
   "Fill STR such that each line contains at most WIDTH characters, assuming
 that the first character is at COLUMN.
diff --git a/guix/utils.scm b/guix/utils.scm
index 9bf1cc893..ab43ed400 100644
--- a/guix/utils.scm
+++ b/guix/utils.scm
@@ -33,7 +33,7 @@
   #:autoload   (rnrs io ports) (make-custom-binary-input-port)
   #:use-module ((rnrs bytevectors) #:select (bytevector-u8-set!))
   #:use-module (guix memoization)
-  #:use-module ((guix build utils) #:select (dump-port))
+  #:use-module ((guix build utils) #:select (dump-port mkdir-p))
   #:use-module ((guix build syscalls) #:select (mkdtemp! fdatasync))
   #:use-module (ice-9 format)
   #:autoload   (ice-9 popen)  (open-pipe*)
@@ -81,7 +81,10 @@
             call-with-temporary-output-file
             call-with-temporary-directory
             with-atomic-file-output
+
+            config-directory
             cache-directory
+
             readlink*
             edit-expression
 
@@ -598,13 +601,26 @@ output port, and PROC's result is returned."
         (false-if-exception (delete-file template))
         (close-port out)))))
 
-(define (cache-directory)
-  "Return the cache directory for Guix, by default ~/.cache/guix."
-  (string-append (or (getenv "XDG_CACHE_HOME")
-                     (and=> (or (getenv "HOME")
-                                (passwd:dir (getpwuid (getuid))))
-                            (cut string-append <> "/.cache")))
-                 "/guix"))
+(define* (xdg-directory variable suffix #:key (ensure? #t))
+  "Return the name of the XDG directory that matches VARIABLE and SUFFIX,
+after making sure that it exists if ENSURE? is true.  VARIABLE is an
+environment variable name like \"XDG_CONFIG_HOME\"; SUFFIX is a suffix like
+\"/.config\".  Honor the XDG specs,
+<http://standards.freedesktop.org/basedir-spec/basedir-spec-latest.html>."
+  (let ((dir (and=> (or (getenv variable)
+                        (and=> (or (getenv "HOME")
+                                   (passwd:dir (getpwuid (getuid))))
+                               (cut string-append <> suffix)))
+                    (cut string-append <> "/guix"))))
+    (when ensure?
+      (mkdir-p dir))
+    dir))
+
+(define config-directory
+  (cut xdg-directory "XDG_CONFIG_HOME" "/.config" <...>))
+
+(define cache-directory
+  (cut xdg-directory "XDG_CACHE_HOME" "/.cache" <...>))
 
 (define (readlink* file)
   "Call 'readlink' until the result is not a symlink."