Merge branch 'master' into core-updates

18 files changed, 432 insertions, 186 deletions

diff --git a/guix/build/syscalls.scm b/guix/build/syscalls.scm
index 2e37846ff0..475fc96490 100644
--- a/guix/build/syscalls.scm
+++ b/guix/build/syscalls.scm
@@ -25,6 +25,7 @@
   #:use-module (srfi srfi-9)
   #:use-module (srfi srfi-9 gnu)
   #:use-module (srfi srfi-11)
+  #:use-module (srfi srfi-19)
   #:use-module (ice-9 rdelim)
   #:use-module (ice-9 regex)
   #:use-module (ice-9 match)
@@ -126,7 +127,22 @@
             window-size-x-pixels
             window-size-y-pixels
             terminal-window-size
-            terminal-columns))
+            terminal-columns
+
+            utmpx?
+            utmpx-login-type
+            utmpx-pid
+            utmpx-line
+            utmpx-id
+            utmpx-user
+            utmpx-host
+            utmpx-termination-status
+            utmpx-exit-status
+            utmpx-session-id
+            utmpx-time
+            utmpx-address
+            login-type
+            utmpx-entries))
 
 ;;; Commentary:
 ;;;
@@ -900,6 +916,15 @@ bytevector BV at INDEX."
   ;; The most terrible interface, live from Scheme.
   (syscall->procedure int "ioctl" (list int unsigned-long '*)))
 
+(define (bytes->string bytes)
+  "Read BYTES, a list of bytes, and return the null-terminated string decoded
+from there, or #f if that would be an empty string."
+  (match (take-while (negate zero?) bytes)
+    (()
+     #f)
+    (non-zero
+     (list->string (map integer->char non-zero)))))
+
 (define (bytevector->string-list bv stride len)
   "Return the null-terminated strings found in BV every STRIDE bytes.  Read at
 most LEN bytes from BV."
@@ -911,9 +936,7 @@ most LEN bytes from BV."
        (reverse result))
       (_
        (loop (drop bytes stride)
-             (cons (list->string (map integer->char
-                                      (take-while (negate zero?) bytes)))
-                   result))))))
+             (cons (bytes->string bytes) result))))))
 
 (define* (network-interface-names #:optional sock)
   "Return the names of existing network interfaces.  This is typically limited
@@ -1480,4 +1503,99 @@ always a positive integer."
             (fall-back)
             (apply throw args))))))
 
+
+;;;
+;;; utmpx.
+;;;
+
+(define-record-type <utmpx-entry>
+  (utmpx type pid line id user host termination exit
+         session time address)
+  utmpx?
+  (type           utmpx-login-type)               ;login-type
+  (pid            utmpx-pid)
+  (line           utmpx-line)                     ;device name
+  (id             utmpx-id)
+  (user           utmpx-user)                     ;user name
+  (host           utmpx-host)                     ;host name | #f
+  (termination    utmpx-termination-status)
+  (exit           utmpx-exit-status)
+  (session        utmpx-session-id)               ;session ID, for windowing
+  (time           utmpx-time)                     ;entry time
+  (address        utmpx-address))
+
+(define-c-struct %utmpx                           ;<utmpx.h>
+  sizeof-utmpx
+  (lambda (type pid line id user host termination exit session
+                seconds useconds address %reserved)
+    (utmpx type pid
+           (bytes->string line) id
+           (bytes->string user)
+           (bytes->string host) termination exit
+           session
+           (make-time time-utc (* 1000 useconds) seconds)
+           address))
+  read-utmpx
+  write-utmpx!
+  (type           short)
+  (pid            int)
+  (line           (array uint8 32))
+  (id             (array uint8 4))
+  (user           (array uint8 32))
+  (host           (array uint8 256))
+  (termination    short)
+  (exit           short)
+  (session        int32)
+  (time-seconds   int32)
+  (time-useconds  int32)
+  (address-v6     (array int32 4))
+  (%reserved      (array uint8 20)))
+
+(define-bits login-type
+  %unused-login-type->symbols
+  (define EMPTY 0)                      ;No valid user accounting information.
+  (define RUN_LVL 1)                    ;The system's runlevel.
+  (define BOOT_TIME 2)                  ;Time of system boot.
+  (define NEW_TIME 3)                   ;Time after system clock changed.
+  (define OLD_TIME 4)                   ;Time when system clock changed.
+
+  (define INIT_PROCESS 5)                ;Process spawned by the init process.
+  (define LOGIN_PROCESS 6)               ;Session leader of a logged in user.
+  (define USER_PROCESS 7)                ;Normal process.
+  (define DEAD_PROCESS 8)                ;Terminated process.
+
+  (define ACCOUNTING 9))                 ;System accounting.
+
+(define setutxent
+  (let ((proc (syscall->procedure void "setutxent" '())))
+    (lambda ()
+      "Open the user accounting database."
+      (proc))))
+
+(define endutxent
+  (let ((proc (syscall->procedure void "endutxent" '())))
+    (lambda ()
+      "Close the user accounting database."
+      (proc))))
+
+(define getutxent
+  (let ((proc (syscall->procedure '* "getutxent" '())))
+    (lambda ()
+      "Return the next entry from the user accounting database."
+      (let ((ptr (proc)))
+        (if (null-pointer? ptr)
+            #f
+            (read-utmpx (pointer->bytevector ptr sizeof-utmpx)))))))
+
+(define (utmpx-entries)
+  "Return the list of entries read from the user accounting database."
+  (setutxent)
+  (let loop ((entries '()))
+    (match (getutxent)
+      (#f
+       (endutxent)
+       (reverse entries))
+      ((? utmpx? entry)
+       (loop (cons entry entries))))))
+
 ;;; syscalls.scm ends here
diff --git a/guix/derivations.scm b/guix/derivations.scm
index d5e4b5730b..b712c508e5 100644
--- a/guix/derivations.scm
+++ b/guix/derivations.scm
@@ -1,5 +1,6 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2016, 2017 Mathieu Lirzin <mthl@gnu.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -120,7 +121,7 @@
 ;;; Nix derivations, as implemented in Nix's `derivations.cc'.
 ;;;
 
-(define-record-type <derivation>
+(define-immutable-record-type <derivation>
   (make-derivation outputs inputs sources system builder args env-vars
                    file-name)
   derivation?
@@ -817,14 +818,6 @@ output should not be used."
             e
             outputs)))
 
-  (define (set-file-name drv file)
-    ;; Set FILE as the 'file-name' field of DRV.
-    (match drv
-      (($ <derivation> outputs inputs sources system builder
-          args env-vars)
-       (make-derivation outputs inputs sources system builder
-                        args env-vars file))))
-
   (define input->derivation-input
     (match-lambda
       (((? derivation? drv))
@@ -872,9 +865,9 @@ output should not be used."
     (let* ((file (add-text-to-store store (string-append name ".drv")
                                     (derivation->string drv)
                                     (map derivation-input-path inputs)))
-           (drv  (set-file-name drv file)))
-      (hash-set! %derivation-cache file drv)
-      drv)))
+           (drv* (set-field drv (derivation-file-name) file)))
+      (hash-set! %derivation-cache file drv*)
+      drv*)))
 
 (define* (map-derivation store drv mapping
                          #:key (system (%current-system)))
diff --git a/guix/git-download.scm b/guix/git-download.scm
index fca44f552a..62e625c715 100644
--- a/guix/git-download.scm
+++ b/guix/git-download.scm
@@ -109,8 +109,7 @@ HASH-ALGO (a symbol).  Use NAME as the file name, or a generic name if #f."
                       #:hash-algo hash-algo
                       #:hash hash
                       #:recursive? #t
-                      #:guile-for-build guile
-                      #:local-build? #t)))
+                      #:guile-for-build guile)))
 
 (define (git-version version revision commit)
   "Return the version string for packages using git-download."
diff --git a/guix/grafts.scm b/guix/grafts.scm
index 2006d3908e..e14a40f8d1 100644
--- a/guix/grafts.scm
+++ b/guix/grafts.scm
@@ -221,9 +221,11 @@ available."
       ((_ . result)                               ;cache hit
        (return result))
       (#f                                         ;cache miss
-       (mlet %state-monad ((result (begin exp ...)))
-         (set-current-state (vhash-consq key result cache))
-         (return result))))))
+       (mlet %state-monad ((result (begin exp ...))
+                           (cache  (current-state)))
+         (mbegin %state-monad
+           (set-current-state (vhash-consq key result cache))
+           (return result)))))))
 
 (define* (cumulative-grafts store drv grafts
                             references
diff --git a/guix/http-client.scm b/guix/http-client.scm
index cc3acc9587..78d39a0208 100644
--- a/guix/http-client.scm
+++ b/guix/http-client.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2012, 2013, 2014, 2015, 2016 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2015 Mark H Weaver <mhw@netris.org>
 ;;; Copyright © 2012, 2015 Free Software Foundation, Inc.
 ;;;
@@ -223,13 +223,14 @@ or if EOF is reached."
                 'shutdown (const #f))
 
 (define* (http-fetch uri #:key port (text? #f) (buffered? #t)
-                     keep-alive? (verify-certificate? #t))
+                     keep-alive? (verify-certificate? #t)
+                     (headers '((user-agent . "GNU Guile"))))
   "Return an input port containing the data at URI, and the expected number of
 bytes available or #f.  If TEXT? is true, the data at URI is considered to be
 textual.  Follow any HTTP redirection.  When BUFFERED? is #f, return an
 unbuffered port, suitable for use in `filtered-port'.  When KEEP-ALIVE? is
 true, send a 'Connection: keep-alive' HTTP header, in which case PORT may be
-reused for future HTTP requests.
+reused for future HTTP requests.  HEADERS is an alist of extra HTTP headers.
 
 When VERIFY-CERTIFICATE? is true, verify HTTPS server certificates.
 
@@ -240,13 +241,14 @@ Raise an '&http-get-error' condition if downloading fails."
     (let ((port (or port (open-connection-for-uri uri
                                                   #:verify-certificate?
                                                   verify-certificate?)))
-          (auth-header (match (uri-userinfo uri)
-                         ((? string? str)
-                          (list (cons 'Authorization
-                                      (string-append "Basic "
-                                                     (base64-encode
-                                                      (string->utf8 str))))))
-                         (_ '()))))
+          (headers (match (uri-userinfo uri)
+                     ((? string? str)
+                      (cons (cons 'Authorization
+                                  (string-append "Basic "
+                                                 (base64-encode
+                                                  (string->utf8 str))))
+                            headers))
+                     (_ headers))))
       (unless (or buffered? (not (file-port? port)))
         (setvbuf port _IONBF))
       (let*-values (((resp data)
@@ -254,10 +256,10 @@ Raise an '&http-get-error' condition if downloading fails."
                      (if (guile-version>? "2.0.7")
                          (http-get uri #:streaming? #t #:port port
                                    #:keep-alive? #t
-                                   #:headers auth-header) ; 2.0.9+
+                                   #:headers headers)        ; 2.0.9+
                          (http-get* uri #:decode-body? text?        ; 2.0.7
                                     #:keep-alive? #t
-                                    #:port port #:headers auth-header)))
+                                    #:port port #:headers headers)))
                     ((code)
                      (response-code resp)))
         (case code
@@ -276,7 +278,12 @@ Raise an '&http-get-error' condition if downloading fails."
                               (code code)
                               (reason (response-reason-phrase resp)))
                              (&message
-                              (message "download failed"))))))))))
+                              (message
+                               (format
+                                #f
+                                (_ "~a: HTTP download failed: ~a (~s)")
+                                (uri->string uri) code
+                                (response-reason-phrase resp))))))))))))
 
 
 ;;;
diff --git a/guix/import/github.scm b/guix/import/github.scm
index 01452b12e3..1e0bb53d9a 100644
--- a/guix/import/github.scm
+++ b/guix/import/github.scm
@@ -19,16 +19,32 @@
 (define-module (guix import github)
   #:use-module (ice-9 match)
   #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-34)
   #:use-module (json)
   #:use-module (guix utils)
   #:use-module ((guix download) #:prefix download:)
   #:use-module (guix import utils)
-  #:use-module (guix import json)
   #:use-module (guix packages)
   #:use-module (guix upstream)
+  #:use-module (guix http-client)
   #:use-module (web uri)
   #:export (%github-updater))
 
+(define (json-fetch* url)
+  "Return a representation of the JSON resource URL (a list or hash table), or
+#f if URL returns 403 or 404."
+  (guard (c ((and (http-get-error? c)
+                  (let ((error (http-get-error-code c)))
+                    (or (= 403 error)
+                        (= 404 error))))
+             #f))     ;; "expected" if there is an authentification error (403),
+                      ;; or if package is unknown (404).
+    ;; Note: github.com returns 403 if we omit a 'User-Agent' header.
+    (let* ((port   (http-fetch url))
+           (result (json->scm port)))
+      (close-port port)
+      result)))
+
 (define (find-extension url)
   "Return the extension of the archive e.g. '.tar.gz' given a URL, or
 false if none is recognized"
@@ -125,7 +141,7 @@ the package e.g. 'bedtools2'.  Return #f if there is no releases"
                    "https://api.github.com/repos/"
                    (github-user-slash-repository url)
                    "/releases"))
-         (json (json-fetch
+         (json (json-fetch*
                 (if token
                     (string-append api-url "?access_token=" token)
                     api-url))))
diff --git a/guix/licenses.scm b/guix/licenses.scm
index 1e19300586..7b2ac2d311 100644
--- a/guix/licenses.scm
+++ b/guix/licenses.scm
@@ -8,7 +8,7 @@
 ;;; Copyright © 2016 Leo Famulari <leo@famulari.name>
 ;;; Copyright © 2016 Fabian Harfert <fhmgufs@web.de>
 ;;; Copyright © 2016 Rene Saavedra <rennes@openmailbox.org>
-;;; Copyright © 2016 ng0 <ngillmann@runbox.com>
+;;; Copyright © 2016, 2017 ng0 <ng0@libertad.pw>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -74,7 +74,8 @@
             x11 x11-style
             zpl2.1
             zlib
-            fsf-free))
+            fsf-free
+            wtfpl2))
 
 (define-record-type <license>
   (license name uri comment)
@@ -450,6 +451,11 @@ at URI, which may be a file:// URI pointing the package's tree."
            "https://unlicense.org/"
            "https://www.gnu.org/licenses/license-list.html#Unlicense"))
 
+(define wtfpl2
+  (license "WTFPL 2"
+           "http://www.wtfpl.net"
+           "http://www.wtfpl.net/about/"))
+
 (define x11
   (license "X11"
            "http://directory.fsf.org/wiki/License:X11"
diff --git a/guix/profiles.scm b/guix/profiles.scm
index e7707b6543..495a9e2e7c 100644
--- a/guix/profiles.scm
+++ b/guix/profiles.scm
@@ -92,6 +92,7 @@
             profile-manifest
             package->manifest-entry
             packages->manifest
+            ca-certificate-bundle
             %default-profile-hooks
             profile-derivation
 
diff --git a/guix/scripts/archive.scm b/guix/scripts/archive.scm
index 6eba9e0008..9e49c53635 100644
--- a/guix/scripts/archive.scm
+++ b/guix/scripts/archive.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2013, 2014, 2015, 2016 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2013, 2014, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2017 Ricardo Wurmus <rekado@elephly.net>
 ;;;
 ;;; This file is part of GNU Guix.
@@ -31,7 +31,6 @@
   #:use-module (guix ui)
   #:use-module (guix pki)
   #:use-module (guix pk-crypto)
-  #:use-module (guix docker)
   #:use-module (guix scripts)
   #:use-module (guix scripts build)
   #:use-module (gnu packages)
@@ -46,6 +45,11 @@
   #:export (guix-archive
             options->derivations+files))
 
+;; XXX: Use this hack instead of #:autoload to avoid compilation errors.
+;; See <http://bugs.gnu.org/12202>.
+(module-autoload! (current-module)
+                  '(guix docker) '(build-docker-image))
+
 
 ;;;
 ;;; Command-line options.
@@ -53,7 +57,8 @@
 
 (define %default-options
   ;; Alist of default option values.
-  `((system . ,(%current-system))
+  `((format . "nar")
+    (system . ,(%current-system))
     (substitutes? . #t)
     (graft? . #t)
     (max-silent-time . 3600)
@@ -253,8 +258,21 @@ resulting archive to the standard output port."
 
     (if (or (assoc-ref opts 'dry-run?)
             (build-derivations store drv))
-        (export-paths store files (current-output-port)
-                      #:recursive? (assoc-ref opts 'export-recursive?))
+        (match (assoc-ref opts 'format)
+          ("nar"
+           (export-paths store files (current-output-port)
+                         #:recursive? (assoc-ref opts 'export-recursive?)))
+          ("docker"
+           (match files
+             ((file)
+              (let ((system (assoc-ref opts 'system)))
+                (format #t "~a\n"
+                        (build-docker-image file #:system system))))
+             (_
+              ;; TODO: Remove this restriction.
+              (leave (_ "only a single item can be exported to Docker~%")))))
+          (format
+           (leave (_ "~a: unknown archive format~%") format)))
         (leave (_ "unable to export the given packages~%")))))
 
 (define (generate-key-pair parameters)
@@ -338,15 +356,7 @@ the input port."
                 (else
                  (with-store store
                    (cond ((assoc-ref opts 'export)
-                          (cond ((equal? (assoc-ref opts 'format) "docker")
-                                 (match (car opts)
-                                   (('argument . (? store-path? item))
-                                    (format #t "~a\n"
-                                            (build-docker-image
-                                             item
-                                             #:system (assoc-ref opts 'system))))
-                                   (_ (leave (_ "argument must be a direct store path~%")))))
-                                (_ (export-from-store store opts))))
+                          (export-from-store store opts))
                          ((assoc-ref opts 'import)
                           (import-paths store (current-input-port)))
                          ((assoc-ref opts 'missing)
diff --git a/guix/scripts/build.scm b/guix/scripts/build.scm
index ccb4c275fc..d7d71b7ab9 100644
--- a/guix/scripts/build.scm
+++ b/guix/scripts/build.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2012, 2013, 2014, 2015, 2016 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2013 Mark H Weaver <mhw@netris.org>
 ;;;
 ;;; This file is part of GNU Guix.
@@ -99,8 +99,10 @@ found.  Return #f if no build log was found."
 
 (define (register-root store paths root)
   "Register ROOT as an indirect GC root for all of PATHS."
-  (let* ((root (string-append (canonicalize-path (dirname root))
-                              "/" root)))
+  (let* ((root (if (string-prefix? "/" root)
+                   root
+                   (string-append (canonicalize-path (dirname root))
+                                  "/" root))))
     (catch 'system-error
       (lambda ()
         (match paths
@@ -344,8 +346,8 @@ options handled by 'set-build-options-from-command-line', and listed in
                      #:keep-failed? (assoc-ref opts 'keep-failed?)
                      #:keep-going? (assoc-ref opts 'keep-going?)
                      #:rounds (assoc-ref opts 'rounds)
-                     #:build-cores (or (assoc-ref opts 'cores) 0)
-                     #:max-build-jobs (or (assoc-ref opts 'max-jobs) 1)
+                     #:build-cores (assoc-ref opts 'cores)
+                     #:max-build-jobs (assoc-ref opts 'max-jobs)
                      #:fallback? (assoc-ref opts 'fallback?)
                      #:use-substitutes? (assoc-ref opts 'substitutes?)
                      #:substitute-urls (assoc-ref opts 'substitute-urls)
@@ -462,7 +464,6 @@ options handled by 'set-build-options-from-command-line', and listed in
     (substitutes? . #t)
     (build-hook? . #t)
     (print-build-trace? . #t)
-    (max-silent-time . 3600)
     (verbosity . 0)))
 
 (define (show-help)
@@ -487,6 +488,8 @@ Build the given PACKAGE-OR-DERIVATION and return their output paths.\n"))
   (display (_ "
       --check            rebuild items to check for non-determinism issues"))
   (display (_ "
+      --repair           repair the specified items"))
+  (display (_ "
   -r, --root=FILE        make FILE a symlink to the result, and register it
                          as a garbage collector root"))
   (display (_ "
@@ -536,6 +539,12 @@ must be one of 'package', 'all', or 'transitive'~%")
                           (alist-cons 'build-mode (build-mode check)
                                       result)
                           rest)))
+         (option '("repair") #f #f
+                 (lambda (opt name arg result . rest)
+                   (apply values
+                          (alist-cons 'build-mode (build-mode repair)
+                                      result)
+                          rest)))
          (option '(#\s "system") #t #f
                  (lambda (opt name arg result)
                    (alist-cons 'system arg
diff --git a/guix/scripts/challenge.scm b/guix/scripts/challenge.scm
index 590d8f1099..815bb789c3 100644
--- a/guix/scripts/challenge.scm
+++ b/guix/scripts/challenge.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2015, 2016 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -37,12 +37,17 @@
   #:use-module (ice-9 vlist)
   #:use-module (ice-9 format)
   #:use-module (web uri)
-  #:export (discrepancies
+  #:export (compare-contents
 
-            discrepancy?
-            discrepancy-item
-            discrepancy-local-sha256
-            discrepancy-narinfos
+            comparison-report?
+            comparison-report-item
+            comparison-report-result
+            comparison-report-local-sha256
+            comparison-report-narinfos
+
+            comparison-report-match?
+            comparison-report-mismatch?
+            comparison-report-inconclusive?
 
             guix-challenge))
 
@@ -61,13 +66,38 @@
 (define ensure-store-item                         ;XXX: move to (guix ui)?
   (@@ (guix scripts size) ensure-store-item))
 
-;; Representation of a hash mismatch for ITEM.
-(define-record-type <discrepancy>
-  (discrepancy item local-sha256 narinfos)
-  discrepancy?
-  (item         discrepancy-item)                   ;string, /gnu/store/… item
-  (local-sha256 discrepancy-local-sha256)           ;bytevector | #f
-  (narinfos     discrepancy-narinfos))              ;list of <narinfo>
+;; Representation of a comparison report for ITEM.
+(define-record-type <comparison-report>
+  (%comparison-report item result local-sha256 narinfos)
+  comparison-report?
+  (item         comparison-report-item)    ;string, /gnu/store/… item
+  (result       comparison-report-result)  ;'match | 'mismatch | 'inconclusive
+  (local-sha256 comparison-report-local-sha256)   ;bytevector | #f
+  (narinfos     comparison-report-narinfos))      ;list of <narinfo>
+
+(define-syntax comparison-report
+  ;; Some sort of a an enum to make sure 'result' is correct.
+  (syntax-rules (match mismatch inconclusive)
+    ((_ item 'match rest ...)
+     (%comparison-report item 'match rest ...))
+    ((_ item 'mismatch rest ...)
+     (%comparison-report item 'mismatch rest ...))
+    ((_ item 'inconclusive rest ...)
+     (%comparison-report item 'inconclusive rest ...))))
+
+(define (comparison-report-predicate result)
+  "Return a predicate that returns true when pass a REPORT that has RESULT."
+  (lambda (report)
+    (eq? (comparison-report-result report) result)))
+
+(define comparison-report-mismatch?
+  (comparison-report-predicate 'mismatch))
+
+(define comparison-report-match?
+  (comparison-report-predicate 'match))
+
+(define comparison-report-inconclusive?
+  (comparison-report-predicate 'inconclusive))
 
 (define (locally-built? store item)
   "Return true if ITEM was built locally."
@@ -88,10 +118,10 @@ Otherwise return #f."
 (define-syntax-rule (report args ...)
   (format (current-error-port) args ...))
 
-(define (discrepancies items servers)
+(define (compare-contents items servers)
   "Challenge the substitute servers whose URLs are listed in SERVERS by
 comparing the hash of the substitutes of ITEMS that they serve.  Return the
-list of discrepancies.
+list of <comparison-report> objects.
 
 This procedure does not authenticate narinfos from SERVERS, nor does it verify
 that they are signed by an authorized public keys.  The reason is that, by
@@ -100,11 +130,7 @@ taken since we do not import the archives."
   (define (compare item reference)
     ;; Return a procedure to compare the hash of ITEM with REFERENCE.
     (lambda (narinfo url)
-      (if (not narinfo)
-          (begin
-            (warning (_ "~a: no substitute at '~a'~%")
-                     item url)
-            #t)
+      (or (not narinfo)
           (let ((value (narinfo-hash->sha256 (narinfo-hash narinfo))))
             (bytevector=? reference value)))))
 
@@ -116,9 +142,7 @@ taken since we do not import the archives."
          ((url urls ...)
           (if (not first)
               (select-reference item narinfos urls)
-              (narinfo-hash->sha256 (narinfo-hash first))))))
-      (()
-       (leave (_ "no substitutes for '~a'~%") item))))
+              (narinfo-hash->sha256 (narinfo-hash first))))))))
 
   (mlet* %store-monad ((local     (mapm %store-monad
                                         query-locally-built-hash items))
@@ -130,42 +154,61 @@ taken since we do not import the archives."
                                                         vhash))
                                           vlist-null
                                           remote)))
-    (return (filter-map (lambda (item local)
-                          (let ((narinfos (vhash-fold* cons '() item narinfos)))
-                            (define reference
-                              (or local
-                                  (begin
-                                    (warning (_ "no local build for '~a'~%") item)
-                                    (select-reference item narinfos servers))))
-
-                            (if (every (compare item reference)
-                                       narinfos servers)
-                                #f
-                                (discrepancy item local narinfos))))
-                        items
-                        local))))
-
-(define* (summarize-discrepancy discrepancy
-                                #:key (hash->string
-                                       bytevector->nix-base32-string))
-  "Write to the current error port a summary of DISCREPANCY, a <discrepancy>
-object that denotes a hash mismatch."
-  (match discrepancy
-    (($ <discrepancy> item local (narinfos ...))
+    (return (map (lambda (item local)
+                   (match (vhash-fold* cons '() item narinfos)
+                     (()                          ;no substitutes
+                      (comparison-report item 'inconclusive local '()))
+                     ((narinfo)
+                      (if local
+                          (if ((compare item local) narinfo (first servers))
+                              (comparison-report item 'match
+                                                 local (list narinfo))
+                              (comparison-report item 'mismatch
+                                                 local (list narinfo)))
+                          (comparison-report item 'inconclusive
+                                             local (list narinfo))))
+                     ((narinfos ...)
+                      (let ((reference
+                             (or local (select-reference item narinfos
+                                                         servers))))
+                        (if (every (compare item reference) narinfos servers)
+                            (comparison-report item 'match
+                                               local narinfos)
+                            (comparison-report item 'mismatch
+                                               local narinfos))))))
+                 items
+                 local))))
+
+(define* (summarize-report comparison-report
+                           #:key
+                           (hash->string bytevector->nix-base32-string)
+                           verbose?)
+  "Write to the current error port a summary of REPORT, a <comparison-report>
+object.  When VERBOSE?, display matches in addition to mismatches and
+inconclusive reports."
+  (define (report-hashes item local narinfos)
+    (if local
+        (report (_ "  local hash: ~a~%") (hash->string local))
+        (report (_ "  no local build for '~a'~%") item))
+    (for-each (lambda (narinfo)
+                (report (_ "  ~50a: ~a~%")
+                        (uri->string (narinfo-uri narinfo))
+                        (hash->string
+                         (narinfo-hash->sha256 (narinfo-hash narinfo)))))
+              narinfos))
+
+  (match comparison-report
+    (($ <comparison-report> item 'mismatch local (narinfos ...))
      (report (_ "~a contents differ:~%") item)
-     (if local
-         (report (_ "  local hash: ~a~%") (hash->string local))
-         (warning (_ "no local build for '~a'~%") item))
-
-     (for-each (lambda (narinfo)
-                 (if narinfo
-                     (report (_ "  ~50a: ~a~%")
-                             (uri->string (narinfo-uri narinfo))
-                             (hash->string
-                              (narinfo-hash->sha256 (narinfo-hash narinfo))))
-                     (report (_ "  ~50a: unavailable~%")
-                             (uri->string (narinfo-uri narinfo)))))
-               narinfos))))
+     (report-hashes item local narinfos))
+    (($ <comparison-report> item 'inconclusive #f narinfos)
+     (warning (_ "could not challenge '~a': no local build~%") item))
+    (($ <comparison-report> item 'inconclusive locals ())
+     (warning (_ "could not challenge '~a': no substitutes~%") item))
+    (($ <comparison-report> item 'match local (narinfos ...))
+     (when verbose?
+       (report (_ "~a contents match:~%") item)
+       (report-hashes item local narinfos)))))
 
 
 ;;;
@@ -178,6 +221,8 @@ Challenge the substitutes for PACKAGE... provided by one or more servers.\n"))
   (display (_ "
       --substitute-urls=URLS
                          compare build results with those at URLS"))
+  (display (_ "
+      -v, --verbose      show details about successful comparisons"))
   (newline)
   (display (_ "
   -h, --help             display this help and exit"))
@@ -201,6 +246,11 @@ Challenge the substitutes for PACKAGE... provided by one or more servers.\n"))
                           (alist-cons 'substitute-urls
                                       (string-tokenize arg)
                                       (alist-delete 'substitute-urls result))
+                          rest)))
+         (option '("verbose" #\v) #f #f
+                 (lambda (opt name arg result . rest)
+                   (apply values
+                          (alist-cons 'verbose? #t result)
                           rest)))))
 
 (define %default-options
@@ -220,7 +270,8 @@ Challenge the substitutes for PACKAGE... provided by one or more servers.\n"))
                                    (_ #f))
                                  opts))
            (system   (assoc-ref opts 'system))
-           (urls     (assoc-ref opts 'substitute-urls)))
+           (urls     (assoc-ref opts 'substitute-urls))
+           (verbose? (assoc-ref opts 'verbose?)))
       (leave-on-EPIPE
        (with-store store
          ;; Disable grafts since substitute servers normally provide only
@@ -236,13 +287,15 @@ Challenge the substitutes for PACKAGE... provided by one or more servers.\n"))
                                 #:use-substitutes? #f)
 
              (run-with-store store
-               (mlet* %store-monad ((items  (mapm %store-monad
-                                                  ensure-store-item files))
-                                    (issues (discrepancies items urls)))
-                 (for-each summarize-discrepancy issues)
-                 (unless (null? issues)
-                   (exit 2))
-                 (return (null? issues)))
+               (mlet* %store-monad ((items   (mapm %store-monad
+                                                   ensure-store-item files))
+                                    (reports (compare-contents items urls)))
+                 (for-each (cut summarize-report <> #:verbose? verbose?)
+                           reports)
+
+                 (exit (cond ((any comparison-report-mismatch? reports) 2)
+                             ((every comparison-report-match? reports) 0)
+                             (else 1))))
                #:system system))))))))
 
 ;;; challenge.scm ends here
diff --git a/guix/scripts/environment.scm b/guix/scripts/environment.scm
index 1d3be6a84f..a08367d1b1 100644
--- a/guix/scripts/environment.scm
+++ b/guix/scripts/environment.scm
@@ -1,6 +1,6 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2014, 2015 David Thompson <davet@gnu.org>
-;;; Copyright © 2015, 2016 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -531,8 +531,10 @@ message if any test fails."
 
 (define (register-gc-root target root)
   "Make ROOT an indirect root to TARGET.  This is procedure is idempotent."
-  (let* ((root (string-append (canonicalize-path (dirname root))
-                              "/" root)))
+  (let* ((root (if (string-prefix? "/" root)
+                   root
+                   (string-append (canonicalize-path (dirname root))
+                                  "/" root))))
     (catch 'system-error
       (lambda ()
         (symlink target root)
diff --git a/guix/scripts/lint.scm b/guix/scripts/lint.scm
index 9b991786c3..afc1369ad1 100644
--- a/guix/scripts/lint.scm
+++ b/guix/scripts/lint.scm
@@ -1,7 +1,7 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2014 Cyril Roelandt <tipecaml@gmail.com>
 ;;; Copyright © 2014, 2015 Eric Bavier <bavier@member.fsf.org>
-;;; Copyright © 2013, 2014, 2015, 2016 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2013, 2014, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2015, 2016 Mathieu Lirzin <mthl@gnu.org>
 ;;; Copyright © 2016 Danny Milosavljevic <dannym+a@scratchpost.org>
 ;;; Copyright © 2016 Hartmut Goebel <h.goebel@crazy-compilers.com>
@@ -959,12 +959,12 @@ or a list thereof")
 
 (define* (run-checkers package #:optional (checkers %checkers))
   "Run the given CHECKERS on PACKAGE."
-  (let ((tty? (isatty? (current-error-port)))
-        (name (package-full-name package)))
+  (let ((tty? (isatty? (current-error-port))))
     (for-each (lambda (checker)
                 (when tty?
-                  (format (current-error-port) "checking ~a [~a]...\x1b[K\r"
-                          name (lint-checker-name checker))
+                  (format (current-error-port) "checking ~a@~a [~a]...\x1b[K\r"
+                          (package-name package) (package-version package)
+                          (lint-checker-name checker))
                   (force-output (current-error-port)))
                 ((lint-checker-check checker) package))
               checkers)
diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm
index 79622ac149..6be9d00aec 100644
--- a/guix/scripts/package.scm
+++ b/guix/scripts/package.scm
@@ -577,11 +577,12 @@ upgrading, #f otherwise."
 (define (store-item->manifest-entry item)
   "Return a manifest entry for ITEM, a \"/gnu/store/...\" file name."
   (let-values (((name version)
-                (package-name->name+version (store-path-package-name item))))
+                (package-name->name+version (store-path-package-name item)
+                                            #\-)))
     (manifest-entry
       (name name)
       (version version)
-      (output #f)
+      (output "out")                              ;XXX: wild guess
       (item item))))
 
 (define (options->installable opts manifest transaction)
diff --git a/guix/scripts/perform-download.scm b/guix/scripts/perform-download.scm
index 0d2e7089aa..59ade0a8c1 100644
--- a/guix/scripts/perform-download.scm
+++ b/guix/scripts/perform-download.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2016 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2016, 2017 Ludovic Courtès <ludo@gnu.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -19,7 +19,7 @@
 (define-module (guix scripts perform-download)
   #:use-module (guix ui)
   #:use-module (guix derivations)
-  #:use-module ((guix store) #:select (derivation-path?))
+  #:use-module ((guix store) #:select (derivation-path? store-path?))
   #:use-module (guix build download)
   #:use-module (ice-9 match)
   #:export (guix-perform-download))
@@ -41,17 +41,23 @@
     (module-use! module (resolve-interface '(guix base32)))
     module))
 
-(define (perform-download drv)
-  "Perform the download described by DRV, a fixed-output derivation."
+(define* (perform-download drv #:optional output)
+  "Perform the download described by DRV, a fixed-output derivation, to
+OUTPUT.
+
+Note: Unless OUTPUT is #f, we don't read the value of 'out' in DRV since the
+actual output is different from that when we're doing a 'bmCheck' or
+'bmRepair' build."
   (derivation-let drv ((url "url")
-                       (output "out")
+                       (output* "out")
                        (executable "executable")
                        (mirrors "mirrors")
                        (content-addressed-mirrors "content-addressed-mirrors"))
     (unless url
       (leave (_ "~a: missing URL~%") (derivation-file-name drv)))
 
-    (let* ((url        (call-with-input-string url read))
+    (let* ((output     (or output output*))
+           (url        (call-with-input-string url read))
            (drv-output (assoc-ref (derivation-outputs drv) "out"))
            (algo       (derivation-output-hash-algo drv-output))
            (hash       (derivation-output-hash drv-output)))
@@ -91,20 +97,25 @@ the daemon and not explicitly described as an input of the derivation.  This
 allows us to sidestep bootstrapping problems, such downloading the source code
 of GnuTLS over HTTPS, before we have built GnuTLS.  See
 <http://bugs.gnu.org/22774>."
+
+  ;; This program must be invoked by guix-daemon under an unprivileged UID to
+  ;; prevent things downloading from 'file:///etc/shadow' or arbitrary code
+  ;; execution via the content-addressed mirror procedures.  (That means we
+  ;; exclude users who did not pass '--build-users-group'.)
   (with-error-handling
     (match args
-      (((? derivation-path? drv))
-       ;; This program must be invoked by guix-daemon under an unprivileged
-       ;; UID to prevent things downloading from 'file:///etc/shadow' or
-       ;; arbitrary code execution via the content-addressed mirror
-       ;; procedures.  (That means we exclude users who did not pass
-       ;; '--build-users-group'.)
+      (((? derivation-path? drv) (? store-path? output))
+       (assert-low-privileges)
+       (perform-download (call-with-input-file drv read-derivation)
+                         output))
+      (((? derivation-path? drv))                 ;backward compatibility
        (assert-low-privileges)
        (perform-download (call-with-input-file drv read-derivation)))
       (("--version")
        (show-version-and-exit))
       (x
-       (leave (_ "fixed-output derivation name expected~%"))))))
+       (leave
+        (_ "fixed-output derivation and output file name expected~%"))))))
 
 ;; Local Variables:
 ;; eval: (put 'derivation-let 'scheme-indent-function 2)
diff --git a/guix/store.scm b/guix/store.scm
index 49549d0771..7152a5556a 100644
--- a/guix/store.scm
+++ b/guix/store.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2012, 2013, 2014, 2015, 2016 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -138,7 +138,7 @@
             direct-store-path
             log-file))
 
-(define %protocol-version #x10f)
+(define %protocol-version #x161)
 
 (define %worker-magic-1 #x6e697863)               ; "nixc"
 (define %worker-magic-2 #x6478696f)               ; "dxio"
@@ -537,14 +537,14 @@ encoding conversion errors."
                             #:key keep-failed? keep-going? fallback?
                             (verbosity 0)
                             rounds                ;number of build rounds
-                            (max-build-jobs 1)
+                            max-build-jobs
                             timeout
-                            (max-silent-time 3600)
+                            max-silent-time
                             (use-build-hook? #t)
                             (build-verbosity 0)
                             (log-type 0)
                             (print-build-trace #t)
-                            (build-cores (current-processor-count))
+                            build-cores
                             (use-substitutes? #t)
 
                             ;; Client-provided substitute URLs.  If it is #f,
@@ -570,21 +570,37 @@ encoding conversion errors."
                           ...)))))
     (write-int (operation-id set-options) socket)
     (send (boolean keep-failed?) (boolean keep-going?)
-          (boolean fallback?) (integer verbosity)
-          (integer max-build-jobs) (integer max-silent-time))
+          (boolean fallback?) (integer verbosity))
+    (when (< (nix-server-minor-version server) #x61)
+      (let ((max-build-jobs (or max-build-jobs 1))
+            (max-silent-time (or max-silent-time 3600)))
+        (send (integer max-build-jobs) (integer max-silent-time))))
     (when (>= (nix-server-minor-version server) 2)
       (send (boolean use-build-hook?)))
     (when (>= (nix-server-minor-version server) 4)
       (send (integer build-verbosity) (integer log-type)
             (boolean print-build-trace)))
-    (when (>= (nix-server-minor-version server) 6)
-      (send (integer build-cores)))
+    (when (and (>= (nix-server-minor-version server) 6)
+               (< (nix-server-minor-version server) #x61))
+      (let ((build-cores (or build-cores (current-processor-count))))
+        (send (integer build-cores))))
     (when (>= (nix-server-minor-version server) 10)
       (send (boolean use-substitutes?)))
     (when (>= (nix-server-minor-version server) 12)
       (let ((pairs `(,@(if timeout
                            `(("build-timeout" . ,(number->string timeout)))
                            '())
+                     ,@(if max-silent-time
+                           `(("build-max-silent-time"
+                              . ,(number->string max-silent-time)))
+                           '())
+                     ,@(if max-build-jobs
+                           `(("build-max-jobs"
+                              . ,(number->string max-build-jobs)))
+                           '())
+                     ,@(if build-cores
+                           `(("build-cores" . ,(number->string build-cores)))
+                           '())
                      ,@(if substitute-urls
                            `(("substitute-urls"
                               . ,(string-join substitute-urls)))
diff --git a/guix/ui.scm b/guix/ui.scm
index 7d4c437354..6247944068 100644
--- a/guix/ui.scm
+++ b/guix/ui.scm
@@ -332,39 +332,39 @@ Report bugs to: ~a.") %guix-bug-report-address)
 General help using GNU software: <http://www.gnu.org/gethelp/>"))
   (newline))
 
+(define (augmented-system-error-handler file)
+  "Return a 'system-error' handler that mentions FILE in its message."
+  (lambda (key proc fmt args errno)
+    ;; Augment the FMT and ARGS with information about TARGET (this
+    ;; information is missing as of Guile 2.0.11, making the exception
+    ;; uninformative.)
+    (apply throw key proc "~A: ~S"
+           (list (strerror (car errno)) file)
+           (list errno))))
+
+(define-syntax-rule (error-reporting-wrapper proc (args ...) file)
+  "Wrap PROC such that its 'system-error' exceptions are augmented to mention
+FILE."
+  (let ((real-proc (@ (guile) proc)))
+    (lambda (args ...)
+      (catch 'system-error
+        (lambda ()
+          (real-proc args ...))
+        (augmented-system-error-handler file)))))
+
 (set! symlink
   ;; We 'set!' the global binding because (gnu build ...) modules and similar
   ;; typically don't use (guix ui).
-  (let ((real-symlink (@ (guile) symlink)))
-    (lambda (target link)
-      "This is a 'symlink' replacement that provides proper error reporting."
-      (catch 'system-error
-        (lambda ()
-          (real-symlink target link))
-        (lambda (key proc fmt args errno)
-          ;; Augment the FMT and ARGS with information about LINK (this
-          ;; information is missing as of Guile 2.0.11, making the exception
-          ;; uninformative.)
-          (apply throw key proc "~A: ~S"
-                 (list (strerror (car errno)) link)
-                 (list errno)))))))
+  (error-reporting-wrapper symlink (source target) target))
 
 (set! copy-file
   ;; Note: here we use 'set!', not #:replace, because UIs typically use
   ;; 'copy-recursively', which doesn't use (guix ui).
-  (let ((real-copy-file (@ (guile) copy-file)))
-    (lambda (source target)
-      "This is a 'copy-file' replacement that provides proper error reporting."
-      (catch 'system-error
-        (lambda ()
-          (real-copy-file source target))
-        (lambda (key proc fmt args errno)
-          ;; Augment the FMT and ARGS with information about TARGET (this
-          ;; information is missing as of Guile 2.0.11, making the exception
-          ;; uninformative.)
-          (apply throw key proc "~A: ~S"
-                 (list (strerror (car errno)) target)
-                 (list errno)))))))
+  (error-reporting-wrapper copy-file (source target) target))
+
+(set! canonicalize-path
+  (error-reporting-wrapper canonicalize-path (file) file))
+
 
 (define (make-regexp* regexp . flags)
   "Like 'make-regexp' but error out if REGEXP is invalid, reporting the error
diff --git a/guix/utils.scm b/guix/utils.scm
index 06f49daca8..ee06e47fe9 100644
--- a/guix/utils.scm
+++ b/guix/utils.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2012, 2013, 2014, 2015, 2016 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2013, 2014, 2015 Mark H Weaver <mhw@netris.org>
 ;;; Copyright © 2014 Eric Bavier <bavier@member.fsf.org>
 ;;; Copyright © 2014 Ian Denhardt <ian@zenhack.net>
@@ -500,11 +500,13 @@ returned by `config.guess'."
   ;; cross-building to.
   (make-parameter #f))
 
-(define (package-name->name+version spec)
+(define* (package-name->name+version spec
+                                     #:optional (delimiter #\@))
   "Given SPEC, a package name like \"foo@0.9.1b\", return two values: \"foo\"
 and \"0.9.1b\".  When the version part is unavailable, SPEC and #f are
-returned.  Both parts must not contain any '@'."
-  (match (string-rindex spec #\@)
+returned.  Both parts must not contain any '@'.  Optionally, DELIMITER can be
+a character other than '@'."
+  (match (string-rindex spec delimiter)
     (#f  (values spec #f))
     (idx (values (substring spec 0 idx)
                  (substring spec (1+ idx))))))