summaryrefslogtreecommitdiff
path: root/guix
diff options
context:
space:
mode:
Diffstat (limited to 'guix')
-rw-r--r--guix/build-system/go.scm132
-rw-r--r--guix/build/emacs-build-system.scm8
-rw-r--r--guix/build/go-build-system.scm217
-rw-r--r--guix/import/cpan.scm14
-rw-r--r--guix/import/pypi.scm1
-rw-r--r--guix/scripts/lint.scm78
-rw-r--r--guix/scripts/offload.scm61
-rwxr-xr-xguix/scripts/substitute.scm1
-rw-r--r--guix/tests/http.scm133
-rw-r--r--guix/ui.scm9
-rw-r--r--guix/zlib.scm39
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))