diff options
Diffstat (limited to 'guix')
| -rw-r--r-- | guix/build-system/go.scm | 132 | ||||
| -rw-r--r-- | guix/build/emacs-build-system.scm | 8 | ||||
| -rw-r--r-- | guix/build/go-build-system.scm | 217 | ||||
| -rw-r--r-- | guix/import/cpan.scm | 14 | ||||
| -rw-r--r-- | guix/import/pypi.scm | 1 | ||||
| -rw-r--r-- | guix/scripts/lint.scm | 78 | ||||
| -rw-r--r-- | guix/scripts/offload.scm | 61 | ||||
| -rwxr-xr-x | guix/scripts/substitute.scm | 1 | ||||
| -rw-r--r-- | guix/tests/http.scm | 133 | ||||
| -rw-r--r-- | guix/ui.scm | 9 | ||||
| -rw-r--r-- | guix/zlib.scm | 39 |
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)) |