Merge 'master' into core-updates

11 files changed, 569 insertions, 124 deletions

diff --git a/guix/build-system/go.scm b/guix/build-system/go.scm
new file mode 100644
index 0000000000..43599df6f4
--- /dev/null
+++ b/guix/build-system/go.scm
@@ -0,0 +1,132 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2016 Petter <petter@mykolab.ch>
+;;; Copyright © 2017 Leo Famulari <leo@famulari.name>
+;;;
+;;; 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 go)
+  #:use-module (guix utils)
+  #:use-module (guix derivations)
+  #:use-module (guix search-paths)
+  #:use-module (guix build-system)
+  #:use-module (guix build-system gnu)
+  #:use-module (guix packages)
+  #:use-module (ice-9 match)
+  #:export (%go-build-system-modules
+            go-build
+            go-build-system))
+
+;; Commentary:
+;;
+;; Standard build procedure for packages using the Go build system.  It is
+;; implemented as an extension of 'gnu-build-system'.
+;;
+;; Code:
+
+(define %go-build-system-modules
+  ;; Build-side modules imported and used by default.
+  `((guix build go-build-system)
+    ,@%gnu-build-system-modules))
+
+(define (default-go)
+  ;; Lazily resolve the binding to avoid a circular dependency.
+  (let ((go (resolve-interface '(gnu packages golang))))
+    (module-ref go 'go)))
+
+(define* (lower name
+                #:key source inputs native-inputs outputs system target
+                (go (default-go))
+                #:allow-other-keys
+                #:rest arguments)
+  "Return a bag for NAME."
+  (define private-keywords
+    '(#:source #:target #:go #:inputs #:native-inputs))
+
+  (and (not target)                               ;XXX: no cross-compilation
+       (bag
+         (name name)
+         (system system)
+         (host-inputs `(,@(if source
+                              `(("source" ,source))
+                              '())
+                        ,@inputs
+
+                        ;; Keep the standard inputs of 'gnu-build-system'.
+                        ,@(standard-packages)))
+         (build-inputs `(("go" ,go)
+                         ,@native-inputs))
+         (outputs outputs)
+         (build go-build)
+         (arguments (strip-keyword-arguments private-keywords arguments)))))
+
+(define* (go-build store name inputs
+                   #:key
+                   (phases '(@ (guix build go-build-system)
+                               %standard-phases))
+                   (outputs '("out"))
+                   (search-paths '())
+                   (import-path "")
+                   (unpack-path "")
+                   (tests? #t)
+                   (system (%current-system))
+                   (guile #f)
+                   (imported-modules %go-build-system-modules)
+                   (modules '((guix build go-build-system)
+                              (guix build utils))))
+  (define builder
+   `(begin
+      (use-modules ,@modules)
+      (go-build #:name ,name
+                #:source ,(match (assoc-ref inputs "source")
+                                 (((? derivation? source))
+                                  (derivation->output-path source))
+                                 ((source)
+                                  source)
+                                 (source
+                                  source))
+                #:system ,system
+                #:phases ,phases
+                #:outputs %outputs
+                #:search-paths ',(map search-path-specification->sexp
+                                      search-paths)
+                #:import-path ,import-path
+                #:unpack-path ,unpack-path
+                #:tests? ,tests?
+                #: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 go-build-system
+  (build-system
+    (name 'go)
+    (description
+     "Build system for Go programs")
+    (lower lower)))
diff --git a/guix/build/emacs-build-system.scm b/guix/build/emacs-build-system.scm
index 2404dbddb4..bd0d2e0266 100644
--- a/guix/build/emacs-build-system.scm
+++ b/guix/build/emacs-build-system.scm
@@ -92,8 +92,12 @@ store in '.el' files."
          (el-dir (string-append out %install-suffix "/" elpa-name-ver))
          (substitute-cmd (lambda ()
                            (substitute* (find-files "." "\\.el$")
-                             (("\"/bin/([^.].*)\"" _ cmd)
-                              (string-append "\"" (which cmd) "\""))))))
+                             (("\"/bin/([^.]\\S*)\"" _ cmd-name)
+                              (let ((cmd (which cmd-name)))
+                                (unless cmd
+                                  (error
+                                   "patch-el-files: unable to locate " cmd-name))
+                                (string-append "\"" cmd "\"")))))))
     (with-directory-excursion el-dir
       ;; Some old '.el' files (e.g., tex-buf.el in AUCTeX) are still encoded
       ;; with the "ISO-8859-1" locale.
diff --git a/guix/build/go-build-system.scm b/guix/build/go-build-system.scm
new file mode 100644
index 0000000000..7f04e3db8c
--- /dev/null
+++ b/guix/build/go-build-system.scm
@@ -0,0 +1,217 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2016 Petter <petter@mykolab.ch>
+;;; Copyright © 2017 Leo Famulari <leo@famulari.name>
+;;;
+;;; 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 go-build-system)
+  #:use-module ((guix build gnu-build-system) #:prefix gnu:)
+  #:use-module (guix build utils)
+  #:use-module (ice-9 match)
+  #:use-module (srfi srfi-1)
+  #:export (%standard-phases
+            go-build))
+
+;; Commentary:
+;;
+;; Build procedures for Go packages.  This is the builder-side code.
+;;
+;; Software written in Go is either a 'package' (i.e. library) or 'command'
+;; (i.e. executable).  Both types can be built with either the `go build` or `go
+;; install` commands.  However, `go build` discards the result of the build
+;; process for Go libraries, so we use `go install`, which preserves the
+;; results. [0]
+
+;; Go software is developed and built within a particular filesystem hierarchy
+;; structure called a 'workspace' [1].  This workspace is found by Go
+;; via the GOPATH environment variable.  Typically, all Go source code
+;; and compiled objects are kept in a single workspace, but it is
+;; possible for GOPATH to contain a list of directories, and that is
+;; what we do in this go-build-system. [2]
+;;
+;; Go software, whether a package or a command, is uniquely named using
+;; an 'import path'.  The import path is based on the URL of the
+;; software's source.  Since most source code is provided over the
+;; internet, the import path is typically a combination of the remote
+;; URL and the source repository's filesystem structure. For example,
+;; the Go port of the common `du` command is hosted on github.com, at
+;; <https://github.com/calmh/du>.  Thus, the import path is
+;; <github.com/calmh/du>. [3]
+;;
+;; It may be possible to programatically guess a package's import path
+;; based on the source URL, but we don't try that in this revision of
+;; the go-build-system.
+;;
+;; Modules of modular Go libraries are named uniquely with their
+;; filesystem paths.  For example, the supplemental but "standardized"
+;; libraries developed by the Go upstream developers are available at
+;; <https://golang.org/x/{net,text,crypto, et cetera}>.  The Go IPv4
+;; library's import path is <golang.org/x/net/ipv4>.  The source of
+;; such modular libraries must be unpacked at the top-level of the
+;; filesystem structure of the library.  So the IPv4 library should be
+;; unpacked to <golang.org/x/net>.  This is handled in the
+;; go-build-system with the optional #:unpack-path key.
+;;
+;; In general, Go software is built using a standardized build mechanism
+;; that does not require any build scripts like Makefiles.  This means
+;; that all modules of modular libraries cannot be built with a single
+;; command.  Each module must be built individually.  This complicates
+;; certain cases, and these issues are currently resolved by creating a
+;; filesystem union of the required modules of such libraries.  I think
+;; this could be improved in future revisions of the go-build-system.
+;;
+;; [0] `go build`:
+;; https://golang.org/cmd/go/#hdr-Compile_packages_and_dependencies
+;; `go install`:
+;; https://golang.org/cmd/go/#hdr-Compile_and_install_packages_and_dependencies
+;; [1] Go workspace example, from <https://golang.org/doc/code.html#Workspaces>:
+;; bin/
+;;     hello                          # command executable
+;;     outyet                         # command executable
+;; pkg/
+;;     linux_amd64/
+;;         github.com/golang/example/
+;;             stringutil.a           # package object
+;; src/
+;;     github.com/golang/example/
+;;         .git/                      # Git repository metadata
+;; 	   hello/
+;; 	       hello.go               # command source
+;; 	   outyet/
+;; 	        main.go               # command source
+;; 	        main_test.go          # test source
+;; 	   stringutil/
+;; 	       reverse.go             # package source
+;; 	       reverse_test.go        # test source
+;;         golang.org/x/image/
+;;             .git/                  # Git repository metadata
+;; 	       bmp/
+;; 	           reader.go          # package source
+;; 	           writer.go          # package source
+;;     ... (many more repositories and packages omitted) ...
+;;
+;; [2] https://golang.org/doc/code.html#GOPATH
+;; [3] https://golang.org/doc/code.html#ImportPaths
+;;
+;; Code:
+
+(define* (unpack #:key source import-path unpack-path #:allow-other-keys)
+  "Unpack SOURCE in the UNPACK-PATH, or the IMPORT-PATH is the UNPACK-PATH is
+unset.  When SOURCE is a directory, copy it instead of unpacking."
+  (if (string-null? import-path)
+      ((display "WARNING: The Go import path is unset.\n")))
+  (if (string-null? unpack-path)
+      (set! unpack-path import-path))
+  (mkdir "src")
+  (let ((dest (string-append "src/" unpack-path)))
+    (mkdir-p dest)
+    (if (file-is-directory? source)
+      (begin
+        (copy-recursively source dest #:keep-mtime? #t)
+        #t)
+      (if (string-suffix? ".zip" source)
+        (zero? (system* "unzip" "-d" dest source))
+        (zero? (system* "tar" "-C" dest "-xvf" source))))))
+
+(define* (install-source #:key outputs #:allow-other-keys)
+  "Install the source code to the output directory."
+  (let* ((out (assoc-ref outputs "out"))
+         (source "src")
+         (dest (string-append out "/" source)))
+    (copy-recursively source dest #:keep-mtime? #t)
+    #t))
+
+(define (go-package? name)
+  (string-prefix? "go-" name))
+
+(define (go-inputs inputs)
+  "Return the alist of INPUTS that are Go software."
+  ;; XXX This should not check the file name of the store item. Instead we
+  ;; should pass, from the host side, the list of inputs that are packages using
+  ;; the go-build-system.
+  (alist-delete "go" ; Exclude the Go compiler
+    (alist-delete "source" ; Exclude the source code of the package being built
+      (filter (match-lambda
+                ((label . directory)
+                 (go-package? ((compose package-name->name+version
+                                        strip-store-file-name)
+                               directory)))
+                (_ #f))
+              inputs))))
+
+(define* (setup-environment #:key inputs outputs #:allow-other-keys)
+  "Export the variables GOPATH and GOBIN, which are based on INPUTS and OUTPUTS,
+respectively."
+  (let ((out (assoc-ref outputs "out")))
+    ;; GOPATH is where Go looks for the source code of the build's dependencies.
+    (set-path-environment-variable "GOPATH"
+                                   ;; XXX Matching "." hints that we could do
+                                   ;; something simpler here...
+                                   (list ".")
+                                   (match (go-inputs inputs)
+                                     (((_ . dir) ...)
+                                      dir)))
+
+    ;; Add the source code of the package being built to GOPATH.
+    (if (getenv "GOPATH")
+      (setenv "GOPATH" (string-append (getcwd) ":" (getenv "GOPATH")))
+      (setenv "GOPATH" (getcwd)))
+    ;; Where to install compiled executable files ('commands' in Go parlance').
+    (setenv "GOBIN" out)
+    #t))
+
+(define* (build #:key import-path #:allow-other-keys)
+  "Build the package named by IMPORT-PATH."
+  (or
+    (zero? (system* "go" "install"
+                    "-v" ; print the name of packages as they are compiled
+                    "-x" ; print each command as it is invoked
+                    import-path))
+    (begin
+      (display (string-append "Building '" import-path "' failed.\n"
+                              "Here are the results of `go env`:\n"))
+      (system* "go" "env")
+      #f)))
+
+(define* (check #:key tests? import-path #:allow-other-keys)
+  "Run the tests for the package named by IMPORT-PATH."
+  (if tests?
+    (zero? (system* "go" "test" import-path))))
+
+(define* (install #:key outputs #:allow-other-keys)
+  "Install the compiled libraries. `go install` installs these files to
+$GOPATH/pkg, so we have to copy them into the output direcotry manually.
+Compiled executable files should have already been installed to the store based
+on $GOBIN in the build phase."
+  (when (file-exists? "pkg")
+    (copy-recursively "pkg" (string-append (assoc-ref outputs "out") "/pkg")))
+  #t)
+
+(define %standard-phases
+  (modify-phases gnu:%standard-phases
+    (delete 'configure)
+    (delete 'patch-generated-file-shebangs)
+    (replace 'unpack unpack)
+    (add-after 'unpack 'install-source install-source)
+    (add-before 'build 'setup-environment setup-environment)
+    (replace 'build build)
+    (replace 'check check)
+    (replace 'install install)))
+
+(define* (go-build #:key inputs (phases %standard-phases)
+                      #:allow-other-keys #:rest args)
+  "Build the given Go package, applying all of PHASES in order."
+  (apply gnu:gnu-build #:inputs inputs #:phases phases args))
diff --git a/guix/import/cpan.scm b/guix/import/cpan.scm
index 01acc6f36e..6261e3e924 100644
--- a/guix/import/cpan.scm
+++ b/guix/import/cpan.scm
@@ -38,7 +38,6 @@
   #:use-module (guix packages)
   #:use-module (guix upstream)
   #:use-module (guix derivations)
-  #:use-module (gnu packages perl)
   #:export (cpan->guix-package
             %cpan-updater))
 
@@ -133,21 +132,28 @@ or #f on failure.  MODULE should be e.g. \"Test::Script\""
      (number->string version))
     (version version)))
 
+(define (perl-package)
+  "Return the 'perl' package.  This is a lazy reference so that we don't
+depend on (gnu packages perl)."
+  (module-ref (resolve-interface '(gnu packages perl)) 'perl))
+
 (define %corelist
   (delay
     (let* ((perl (with-store store
                    (derivation->output-path
-                    (package-derivation store perl))))
+                    (package-derivation store (perl-package)))))
            (core (string-append perl "/bin/corelist")))
       (and (access? core X_OK)
            core))))
 
 (define core-module?
-  (let ((perl-version (package-version perl))
-        (rx (make-regexp
+  (let ((rx (make-regexp
              (string-append "released with perl v?([0-9\\.]*)"
                             "(.*and removed from v?([0-9\\.]*))?"))))
     (lambda (name)
+      (define perl-version
+        (package-version (perl-package)))
+
       (define (version-between? lower version upper)
         (and (version>=? version lower)
              (or (not upper)
diff --git a/guix/import/pypi.scm b/guix/import/pypi.scm
index 90dbe56128..bb0db1ba85 100644
--- a/guix/import/pypi.scm
+++ b/guix/import/pypi.scm
@@ -44,7 +44,6 @@
   #:use-module (guix upstream)
   #:use-module ((guix licenses) #:prefix license:)
   #:use-module (guix build-system python)
-  #:use-module (gnu packages python)
   #:export (guix-package->pypi-name
             pypi->guix-package
             %pypi-updater))
diff --git a/guix/scripts/lint.scm b/guix/scripts/lint.scm
index fc61f0b547..a26f92f49c 100644
--- a/guix/scripts/lint.scm
+++ b/guix/scripts/lint.scm
@@ -414,8 +414,7 @@ for connections to complete; when TIMEOUT is #f, wait as long as needed."
                    (close-connection port))))
 
              (case (response-code response)
-               ((301                    ; moved permanently
-                 302                    ; found (redirection)
+               ((302                    ; found (redirection)
                  303                    ; see other
                  307                    ; temporary redirection
                  308)                   ; permanent redirection
@@ -423,6 +422,22 @@ for connections to complete; when TIMEOUT is #f, wait as long as needed."
                   (if (or (not location) (member location visited))
                       (values 'http-response response)
                       (loop location (cons location visited))))) ;follow the redirect
+               ((301)                   ; moved permanently
+                (let ((location (response-location response)))
+                  ;; Return RESPONSE, unless the final response as we follow
+                  ;; redirects is not 200.
+                  (if location
+                      (let-values (((status response2)
+                                    (loop location (cons location visited))))
+                        (case status
+                          ((http-response)
+                           (values 'http-response
+                                   (if (= 200 (response-code response2))
+                                       response
+                                       response2)))
+                          (else
+                           (values status response2))))
+                      (values 'http-response response)))) ;invalid redirect
                (else
                 (values 'http-response response)))))
          (lambda (key . args)
@@ -474,31 +489,46 @@ warning for PACKAGE mentionning the FIELD."
                 (probe-uri uri #:timeout 3)))     ;wait at most 3 seconds
     (case status
       ((http-response)
-       (if (= 200 (response-code argument))
-           (match (response-content-length argument)
-             ((? number? length)
-              ;; As of July 2016, SourceForge returns 200 (instead of 404)
-              ;; with a small HTML page upon failure.  Attempt to detect such
-              ;; malicious behavior.
-              (or (> length 1000)
+       (cond ((= 200 (response-code argument))
+              (match (response-content-length argument)
+                ((? number? length)
+                 ;; As of July 2016, SourceForge returns 200 (instead of 404)
+                 ;; with a small HTML page upon failure.  Attempt to detect
+                 ;; such malicious behavior.
+                 (or (> length 1000)
+                     (begin
+                       (emit-warning package
+                                     (format #f
+                                             (G_ "URI ~a returned \
+suspiciously small file (~a bytes)")
+                                             (uri->string uri)
+                                             length))
+                       #f)))
+                (_ #t)))
+             ((= 301 (response-code argument))
+              (if (response-location argument)
                   (begin
                     (emit-warning package
-                                  (format #f
-                                          (G_ "URI ~a returned \
-suspiciously small file (~a bytes)")
+                                  (format #f (G_ "permanent redirect from ~a to ~a")
                                           (uri->string uri)
-                                          length))
+                                          (uri->string
+                                           (response-location argument))))
+                    #t)
+                  (begin
+                    (emit-warning package
+                                  (format #f (G_ "invalid permanent redirect \
+from ~a")
+                                          (uri->string uri)))
                     #f)))
-             (_ #t))
-           (begin
-             (emit-warning package
-                           (format #f
-                                   (G_ "URI ~a not reachable: ~a (~s)")
-                                   (uri->string uri)
-                                   (response-code argument)
-                                   (response-reason-phrase argument))
-                           field)
-             #f)))
+             (else
+              (emit-warning package
+                            (format #f
+                                    (G_ "URI ~a not reachable: ~a (~s)")
+                                    (uri->string uri)
+                                    (response-code argument)
+                                    (response-reason-phrase argument))
+                            field)
+              #f)))
       ((ftp-response)
        (match argument
          (('ok) #t)
@@ -534,7 +564,7 @@ suspiciously small file (~a bytes)")
       ((invalid-http-response gnutls-error)
        ;; Probably a misbehaving server; ignore.
        #f)
-      ((unknown-protocol)                             ;nothing we can do
+      ((unknown-protocol)                         ;nothing we can do
        #f)
       (else
        (error "internal linter error" status)))))
diff --git a/guix/scripts/offload.scm b/guix/scripts/offload.scm
index d3cb64d604..6a2485a007 100644
--- a/guix/scripts/offload.scm
+++ b/guix/scripts/offload.scm
@@ -428,6 +428,23 @@ 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 (random-seed)
+  (logxor (getpid) (car (gettimeofday))))
+
+(define shuffle
+  (let ((state (seed->random-state (random-seed))))
+    (lambda (lst)
+      "Return LST shuffled (using the Fisher-Yates algorithm.)"
+      (define vec (list->vector lst))
+      (let loop ((result '())
+                 (i (vector-length vec)))
+        (if (zero? i)
+            result
+            (let* ((j (random i state))
+                   (val (vector-ref vec j)))
+              (vector-set! vec j (vector-ref vec (- i 1)))
+              (loop (cons val result) (- i 1))))))))
+
 (define (choose-build-machine machines)
   "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."
@@ -441,39 +458,35 @@ slot (which must later be released with 'release-build-slot'), or #f and #f."
   ;;   5. Release the global machine-choice lock.
 
   (with-file-lock (machine-choice-lock-file)
-    (define machines+slots+loads
+    (define machines+slots
       (filter-map (lambda (machine)
-                    ;; Call 'machine-load' from here to make sure it is called
-                    ;; only once per machine (it is expensive).
                     (let ((slot (acquire-build-slot machine)))
-                      (and slot
-                           (list machine slot (machine-load machine)))))
-                  machines))
+                      (and slot (list machine slot))))
+                  (shuffle machines)))
 
     (define (undecorate pred)
       (lambda (a b)
         (match a
-          ((machine1 slot1 load1)
+          ((machine1 slot1)
            (match b
-             ((machine2 slot2 load2)
-              (pred machine1 load1 machine2 load2)))))))
-
-    (define (machine-less-loaded-or-faster? m1 l1 m2 l2)
-      ;; Return #t if M1 is either less loaded or faster than M2, with L1
-      ;; being the load of M1 and L2 the load of M2.  (This relation defines a
-      ;; total order on machines.)
-      (> (/ (build-machine-speed m1) (+ 1 l1))
-         (/ (build-machine-speed m2) (+ 1 l2))))
-
-    (let loop ((machines+slots+loads
-                (sort machines+slots+loads
-                      (undecorate machine-less-loaded-or-faster?))))
-      (match machines+slots+loads
-        (((best slot load) others ...)
+             ((machine2 slot2)
+              (pred machine1 machine2)))))))
+
+    (define (machine-faster? m1 m2)
+      ;; Return #t if M1 is faster than M2.
+      (> (build-machine-speed m1)
+         (build-machine-speed m2)))
+
+    (let loop ((machines+slots
+                (sort machines+slots (undecorate machine-faster?))))
+      (match machines+slots
+        (((best slot) others ...)
          ;; Return the best machine unless it's already overloaded.
-         (if (< load 2.)
+         ;; Note: We call 'machine-load' only as a last resort because it is
+         ;; too costly to call it once for every machine.
+         (if (< (machine-load best) 2.)
              (match others
-               (((machines slots loads) ...)
+               (((machines slots) ...)
                 ;; Release slots from the uninteresting machines.
                 (for-each release-build-slot slots)
 
diff --git a/guix/scripts/substitute.scm b/guix/scripts/substitute.scm
index 3dcf42d0d1..921a7c6790 100755
--- a/guix/scripts/substitute.scm
+++ b/guix/scripts/substitute.scm
@@ -962,6 +962,7 @@ DESTINATION as a nar file.  Verify the substitute against ACL."
       ;; Unpack the Nar at INPUT into DESTINATION.
       (restore-file input destination)
       (close-port input)
+      (close-port progress)
 
       ;; Skip a line after what 'progress-reporter/file' printed, and another
       ;; one to visually separate substitutions.
diff --git a/guix/tests/http.scm b/guix/tests/http.scm
index fe1e120c5d..a56d6f213d 100644
--- a/guix/tests/http.scm
+++ b/guix/tests/http.scm
@@ -1,5 +1,5 @@
 ;;; 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>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -25,7 +25,7 @@
   #:export (with-http-server
             call-with-http-server
             %http-server-port
-            %http-server-socket
+            http-server-can-listen?
             %local-url))
 
 ;;; Commentary:
@@ -38,75 +38,85 @@
   ;; TCP port to use for the stub HTTP server.
   (make-parameter 9999))
 
+(define (open-http-server-socket)
+  "Return a listening socket for the web server.  It is useful to export it so
+that tests can check whether we succeeded opening the socket and tests skip if
+needed."
+  (catch 'system-error
+    (lambda ()
+      (let ((sock (socket PF_INET SOCK_STREAM 0)))
+        (setsockopt sock SOL_SOCKET SO_REUSEADDR 1)
+        (bind sock
+              (make-socket-address AF_INET INADDR_LOOPBACK
+                                   (%http-server-port)))
+        sock))
+    (lambda args
+      (let ((err (system-error-errno args)))
+        (format (current-error-port)
+                "warning: cannot run Web server for tests: ~a~%"
+                (strerror err))
+        #f))))
+
+(define (http-server-can-listen?)
+  "Return #t if we managed to open a listening socket."
+  (and=> (open-http-server-socket)
+         (lambda (socket)
+           (close-port socket)
+           #t)))
+
 (define (%local-url)
   ;; URL to use for 'home-page' tests.
   (string-append "http://localhost:" (number->string (%http-server-port))
                  "/foo/bar"))
 
-(define %http-server-socket
-  ;; Listening socket for the web server.  It is useful to export it so that
-  ;; tests can check whether we succeeded opening the socket and tests skip if
-  ;; needed.
-  (delay
-    (catch 'system-error
-      (lambda ()
-        (let ((sock (socket PF_INET SOCK_STREAM 0)))
-          (setsockopt sock SOL_SOCKET SO_REUSEADDR 1)
-          (bind sock
-                (make-socket-address AF_INET INADDR_LOOPBACK
-                                     (%http-server-port)))
-          sock))
-      (lambda args
-        (let ((err (system-error-errno args)))
-          (format (current-error-port)
-                  "warning: cannot run Web server for tests: ~a~%"
-                  (strerror err))
-          #f)))))
-
-(define (http-write server client response body)
-  "Write RESPONSE."
-  (let* ((response (write-response response client))
-         (port     (response-port response)))
-    (cond
-     ((not body))                                 ;pass
-     (else
-      (write-response-body response body)))
-    (close-port port)
-    (quit #t)                                     ;exit the server thread
-    (values)))
+(define* (call-with-http-server code data thunk
+                                #:key (headers '()))
+  "Call THUNK with an HTTP server running and returning CODE and DATA (a
+string) on HTTP requests."
+  (define (http-write server client response body)
+    "Write RESPONSE."
+    (let* ((response (write-response response client))
+           (port     (response-port response)))
+      (cond
+       ((not body))                               ;pass
+       (else
+        (write-response-body response body)))
+      (close-port port)
+      (quit #t)                                   ;exit the server thread
+      (values)))
 
-;; Mutex and condition variable to synchronize with the HTTP server.
-(define %http-server-lock (make-mutex))
-(define %http-server-ready (make-condition-variable))
+  ;; Mutex and condition variable to synchronize with the HTTP server.
+  (define %http-server-lock (make-mutex))
+  (define %http-server-ready (make-condition-variable))
 
-(define (http-open . args)
-  "Start listening for HTTP requests and signal %HTTP-SERVER-READY."
-  (with-mutex %http-server-lock
-    (let ((result (apply (@@ (web server http) http-open) args)))
-      (signal-condition-variable %http-server-ready)
-      result)))
+  (define (http-open . args)
+    "Start listening for HTTP requests and signal %HTTP-SERVER-READY."
+    (with-mutex %http-server-lock
+      (let ((result (apply (@@ (web server http) http-open) args)))
+        (signal-condition-variable %http-server-ready)
+        result)))
 
-(define-server-impl stub-http-server
-  ;; Stripped-down version of Guile's built-in HTTP server.
-  http-open
-  (@@ (web server http) http-read)
-  http-write
-  (@@ (web server http) http-close))
+  (define-server-impl stub-http-server
+    ;; Stripped-down version of Guile's built-in HTTP server.
+    http-open
+    (@@ (web server http) http-read)
+    http-write
+    (@@ (web server http) http-close))
 
-(define (call-with-http-server code data thunk)
-  "Call THUNK with an HTTP server running and returning CODE and DATA (a
-string) on HTTP requests."
   (define (server-body)
     (define (handle request body)
       (values (build-response #:code code
-                              #:reason-phrase "Such is life")
+                              #:reason-phrase "Such is life"
+                              #:headers headers)
               data))
 
-    (catch 'quit
-      (lambda ()
-        (run-server handle stub-http-server
-                    `(#:socket ,(force %http-server-socket))))
-      (const #t)))
+    (let ((socket (open-http-server-socket)))
+      (catch 'quit
+        (lambda ()
+          (run-server handle stub-http-server
+                      `(#:socket ,socket)))
+        (lambda _
+          (close-port socket)))))
 
   (with-mutex %http-server-lock
     (let ((server (make-thread server-body)))
@@ -114,7 +124,12 @@ string) on HTTP requests."
       ;; Normally SERVER exits automatically once it has received a request.
       (thunk))))
 
-(define-syntax-rule (with-http-server code data body ...)
-  (call-with-http-server code data (lambda () body ...)))
+(define-syntax with-http-server
+  (syntax-rules ()
+    ((_ (code headers) data body ...)
+     (call-with-http-server code data (lambda () body ...)
+                            #:headers headers))
+    ((_ code data body ...)
+     (call-with-http-server code data (lambda () body ...)))))
 
 ;;; http.scm ends here
diff --git a/guix/ui.scm b/guix/ui.scm
index 6dfc8c7a5b..3c8734a7d5 100644
--- a/guix/ui.scm
+++ b/guix/ui.scm
@@ -257,6 +257,15 @@ ARGS is the list of arguments received by the 'throw' handler."
     (('system-error . rest)
      (let ((err (system-error-errno args)))
        (report-error (G_ "failed to load '~a': ~a~%") file (strerror err))))
+    (('read-error "scm_i_lreadparen" message _ ...)
+     ;; Guile's missing-paren messages are obscure so we make them more
+     ;; intelligible here.
+     (if (string-suffix? "end of file" message)
+         (let ((location (string-drop-right message
+                                            (string-length "end of file"))))
+           (format (current-error-port) (G_ "~amissing closing parenthesis~%")
+                   location))
+         (apply throw args)))
     (('syntax-error proc message properties form . rest)
      (let ((loc (source-properties->location properties)))
        (format (current-error-port) (G_ "~a: error: ~a~%")
diff --git a/guix/zlib.scm b/guix/zlib.scm
index 3d830ef84e..955589ab48 100644
--- a/guix/zlib.scm
+++ b/guix/zlib.scm
@@ -149,6 +149,31 @@ the number of uncompressed bytes written, a strictly positive integer."
   ;; Z_DEFAULT_COMPRESSION.
   -1)
 
+(define (close-procedure gzfile port)
+  "Return a procedure that closes GZFILE, ensuring its underlying PORT is
+closed even if closing GZFILE triggers an exception."
+  (let-syntax ((ignore-EBADF
+                (syntax-rules ()
+                  ((_ exp)
+                   (catch 'system-error
+                     (lambda ()
+                       exp)
+                     (lambda args
+                       (unless (= EBADF (system-error-errno args))
+                         (apply throw args))))))))
+
+    (lambda ()
+      (catch 'zlib-error
+        (lambda ()
+          ;; 'gzclose' closes the underlying file descriptor.  'close-port'
+          ;; calls close(2) and gets EBADF, which we swallow.
+          (gzclose gzfile)
+          (ignore-EBADF (close-port port)))
+        (lambda args
+          ;; Make sure PORT is closed despite the zlib error.
+          (ignore-EBADF (close-port port))
+          (apply throw args))))))
+
 (define* (make-gzip-input-port port #:key (buffer-size %default-buffer-size))
   "Return an input port that decompresses data read from PORT, a file port.
 PORT is automatically closed when the resulting port is closed.  BUFFER-SIZE
@@ -158,11 +183,7 @@ buffered input, which would be lost (and is lost anyway)."
   (define gzfile
     (match (drain-input port)
       (""                                         ;PORT's buffer is empty
-       ;; Since 'gzclose' will eventually close the file descriptor beneath
-       ;; PORT, we increase PORT's revealed count and never call 'close-port'
-       ;; on PORT since we would get EBADF if 'gzclose' already closed it (on
-       ;; 2.0 EBADF is swallowed by 'fport_close' but on 2.2 it is raised).
-       (gzdopen (port->fdes port) "r"))
+       (gzdopen (fileno port) "r"))
       (_
        ;; This is unrecoverable but it's better than having the buffered input
        ;; be lost, leading to unclear end-of-file or corrupt-data errors down
@@ -177,8 +198,7 @@ buffered input, which would be lost (and is lost anyway)."
     (gzbuffer! gzfile buffer-size))
 
   (make-custom-binary-input-port "gzip-input" read! #f #f
-                                 (lambda ()
-                                   (gzclose gzfile))))
+                                 (close-procedure gzfile port)))
 
 (define* (make-gzip-output-port port
                                 #:key
@@ -190,7 +210,7 @@ port is closed."
   (define gzfile
     (begin
       (force-output port)                         ;empty PORT's buffer
-      (gzdopen (port->fdes port)
+      (gzdopen (fileno port)
                (string-append "w" (number->string level)))))
 
   (define (write! bv start count)
@@ -200,8 +220,7 @@ port is closed."
     (gzbuffer! gzfile buffer-size))
 
   (make-custom-binary-output-port "gzip-output" write! #f #f
-                                  (lambda ()
-                                    (gzclose gzfile))))
+                                  (close-procedure gzfile port)))
 
 (define* (call-with-gzip-input-port port proc
                                     #:key (buffer-size %default-buffer-size))