From a6e22d84450450cacc6fc36445f6ae378a5b7ad0 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 10 Oct 2017 10:22:43 +0200 Subject: ui: Improve reporting of missing closing parentheses. Suggested by Ricardo Wurmus. Works around . * guix/ui.scm (report-load-error): Add case for 'read-error'. * tests/guix-system.sh: Test missing-closing-paren errors. --- guix/ui.scm | 9 +++++++++ 1 file changed, 9 insertions(+) (limited to 'guix') 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 @@ (define* (report-load-error file args #:optional frame) (('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~%") -- cgit v1.2.3 From b719ddbbbb08c8f22b1dd9d7b40951ca5f2b8356 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 10 Oct 2017 10:35:16 +0200 Subject: import: pypi: Remove unneeded import. * guix/import/pypi.scm: Remove unneeded import. --- guix/import/pypi.scm | 1 - 1 file changed, 1 deletion(-) (limited to 'guix') 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 @@ (define-module (guix import pypi) #: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)) -- cgit v1.2.3 From 90eaa9419ae65d0efc34393b9e1bde3a422ec723 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 10 Oct 2017 11:13:28 +0200 Subject: import: cpan: Load (gnu packages perl) lazily. * guix/import/cpan.scm: Remove dependency on (gnu packages perl). (perl-package): New procedure. (%corelist, core-module?): Use it instead of referring to 'perl'. --- guix/import/cpan.scm | 14 ++++++++++---- 1 file changed, 10 insertions(+), 4 deletions(-) (limited to 'guix') 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 @@ (define-module (guix import cpan) #: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 @@ (define (cpan-version meta) (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) -- cgit v1.2.3 From 85a2b58987bc32e33e63bea86c1a94496b796ae9 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 11 Oct 2017 15:14:16 +0200 Subject: zlib: Fix memory leak due to revealed ports not being GC'd. Fixes . This mostly reverts 81a0f1cdf12e7bcc34c1203f034a323fa8f52cf5, which introduced a regression: revealed ports are *never* GC'd (contrary to what Guile's manual suggests). In addition to the revert, 'close-procedure' now explicitly swallows EBADF errors when 'close-port' is called. * guix/zlib.scm (close-procedure): New procedure. (make-gzip-input-port)[gzfile]: Use 'fileno' instead of 'port->fdes'. Use 'close-procedure' instead of 'gzclose'. (make-gzip-output-port): Likewise. * tests/zlib.scm ("compression/decompression pipe"): Use 'port-closed?' to determine whether PARENT has been closed. --- guix/zlib.scm | 39 +++++++++++++++++++++++++++++---------- tests/zlib.scm | 11 +---------- 2 files changed, 30 insertions(+), 20 deletions(-) (limited to 'guix') 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 @@ (define %default-compression-level ;; 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 @@ (define* (make-gzip-input-port port #:key (buffer-size %default-buffer-size)) (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 @@ (define (read! bv start count) (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 @@ (define* (make-gzip-output-port port (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 @@ (define (write! bv start count) (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)) diff --git a/tests/zlib.scm b/tests/zlib.scm index f71609b7c5..5455240a71 100644 --- a/tests/zlib.scm +++ b/tests/zlib.scm @@ -57,16 +57,7 @@ (define-module (test-zlib) (match (waitpid pid) ((_ . status) (and (zero? status) - - ;; PORT itself isn't closed but its underlying file - ;; descriptor must have been closed by 'gzclose'. - (catch 'system-error - (lambda () - (seek (fileno parent) 0 SEEK_CUR) - #f) - (lambda args - (= EBADF (system-error-errno args)))) - + (port-closed? parent) (bytevector=? received data)))))))))))) (test-end) -- cgit v1.2.3 From abaee53c808fe6df02de2f403dd8904e42d5fede Mon Sep 17 00:00:00 2001 From: 宋文武 Date: Thu, 12 Oct 2017 22:27:04 +0800 Subject: substitute: Close the progress port after substitute finished. Fixes . * guix/scripts/substitute.scm (progress-substitution): Call '(close-port progress)'. --- guix/scripts/substitute.scm | 1 + 1 file changed, 1 insertion(+) (limited to 'guix') 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 @@ (define* (process-substitution store-item destination ;; 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. -- cgit v1.2.3 From d8e89b1c794141b21ae4a87244d2c181b4a8460c Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 12 Oct 2017 14:21:54 +0200 Subject: offload: Reduce the number of calls to 'machine-load'. Previously we would call 'machine-load' once per machine, which was very costly when there were many machines. Now we arrange to call it only once on average (when all the machines have the same 'speed' value). * guix/scripts/offload.scm (random-seed, shuffle): New procedures. (choose-build-machine)[machines+slots+loads]: Rename to... [machines+slots]: ... this. Remove load from the tuples therein. [undecorate]: Adjust accordingly. [machine-less-loaded-or-faster?]: Remove. [machine-faster?]: New procedure. Sort MACHINES+SLOTS according to 'machine-faster?'. Call 'machine-load?' as the last thing. --- guix/scripts/offload.scm | 61 +++++++++++++++++++++++++++++------------------- 1 file changed, 37 insertions(+), 24 deletions(-) (limited to 'guix') 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 @@ (define (machine-choice-lock-file) "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 @@ (define (choose-build-machine machines) ;; 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) -- cgit v1.2.3 From 6ea10db973d861cd8774938e40151c0f8b2d266f Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 12 Oct 2017 23:19:09 +0200 Subject: tests: Support multiple HTTP server instances. * guix/tests/http.scm (%http-server-socket): Turn into... (open-http-server-socket): ... this procedure. (http-server-can-listen?): New procedure. (http-write, %http-server-lock, %http-server-ready) (http-open, stub-http-server): Move to 'call-with-http-server' body. (call-with-http-server): Add #:headers parameter. (with-http-server): Add an additional pattern with headers. * tests/derivations.scm: Use (http-server-can-listen?) instead of (force %http-server-socket). * tests/lint.scm: Likewise. --- guix/tests/http.scm | 133 ++++++++++++++++++++++++++++---------------------- tests/derivations.scm | 8 +-- tests/lint.scm | 14 +++--- 3 files changed, 85 insertions(+), 70 deletions(-) (limited to 'guix') 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 +;;; Copyright © 2014, 2015, 2016, 2017 Ludovic Courtès ;;; ;;; This file is part of GNU Guix. ;;; @@ -25,7 +25,7 @@ (define-module (guix tests http) #: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 @@ (define %http-server-port ;; 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 @@ (define (handle request body) ;; 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/tests/derivations.scm b/tests/derivations.scm index f3aad1b906..36afd42d05 100644 --- a/tests/derivations.scm +++ b/tests/derivations.scm @@ -222,7 +222,7 @@ (define prefix-len (string-length dir)) (build-derivations %store (list drv)) #f))) -(unless (force %http-server-socket) +(unless (http-server-can-listen?) (test-skip 1)) (test-assert "'download' built-in builder" (let ((text (random-text))) @@ -238,7 +238,7 @@ (define prefix-len (string-length dir)) get-string-all) text)))))) -(unless (force %http-server-socket) +(unless (http-server-can-listen?) (test-skip 1)) (test-assert "'download' built-in builder, invalid hash" (with-http-server 200 "hello, world!" @@ -253,7 +253,7 @@ (define prefix-len (string-length dir)) (build-derivations %store (list drv)) #f)))) -(unless (force %http-server-socket) +(unless (http-server-can-listen?) (test-skip 1)) (test-assert "'download' built-in builder, not found" (with-http-server 404 "not found" @@ -279,7 +279,7 @@ (define prefix-len (string-length dir)) (build-derivations %store (list drv)) #f))) -(unless (force %http-server-socket) +(unless (http-server-can-listen?) (test-skip 1)) (test-assert "'download' built-in builder, check mode" ;; Make sure rebuilding the 'builtin:download' derivation in check mode diff --git a/tests/lint.scm b/tests/lint.scm index 7610a91fd3..d7254bc070 100644 --- a/tests/lint.scm +++ b/tests/lint.scm @@ -388,7 +388,7 @@ (define-syntax-rule (with-warnings body ...) (check-home-page pkg))) "domain not found"))) -(test-skip (if (force %http-server-socket) 0 1)) +(test-skip (if (http-server-can-listen?) 0 1)) (test-assert "home-page: Connection refused" (->bool (string-contains @@ -399,7 +399,7 @@ (define-syntax-rule (with-warnings body ...) (check-home-page pkg))) "Connection refused"))) -(test-skip (if (force %http-server-socket) 0 1)) +(test-skip (if (http-server-can-listen?) 0 1)) (test-equal "home-page: 200" "" (with-warnings @@ -409,7 +409,7 @@ (define-syntax-rule (with-warnings body ...) (home-page (%local-url))))) (check-home-page pkg))))) -(test-skip (if (force %http-server-socket) 0 1)) +(test-skip (if (http-server-can-listen?) 0 1)) (test-assert "home-page: 200 but short length" (->bool (string-contains @@ -421,7 +421,7 @@ (define-syntax-rule (with-warnings body ...) (check-home-page pkg)))) "suspiciously small"))) -(test-skip (if (force %http-server-socket) 0 1)) +(test-skip (if (http-server-can-listen?) 0 1)) (test-assert "home-page: 404" (->bool (string-contains @@ -510,7 +510,7 @@ (define-syntax-rule (with-warnings body ...) (check-source-file-name pkg))) "file name should contain the package name")))) -(test-skip (if (force %http-server-socket) 0 1)) +(test-skip (if (http-server-can-listen?) 0 1)) (test-equal "source: 200" "" (with-warnings @@ -523,7 +523,7 @@ (define-syntax-rule (with-warnings body ...) (sha256 %null-sha256)))))) (check-source pkg))))) -(test-skip (if (force %http-server-socket) 0 1)) +(test-skip (if (http-server-can-listen?) 0 1)) (test-assert "source: 200 but short length" (->bool (string-contains @@ -538,7 +538,7 @@ (define-syntax-rule (with-warnings body ...) (check-source pkg)))) "suspiciously small"))) -(test-skip (if (force %http-server-socket) 0 1)) +(test-skip (if (http-server-can-listen?) 0 1)) (test-assert "source: 404" (->bool (string-contains -- cgit v1.2.3 From 61f28fe7e96e022055d3568956ed23c7a48e3548 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 12 Oct 2017 23:26:50 +0200 Subject: lint: 'home-page' checker reports permanent redirects. * guix/scripts/lint.scm (probe-uri): Add special case for HTTP 301. (validate-uri): Likewise. * tests/lint.scm ("home-page: 301, invalid") ("home-page: 301 -> 200", "home-page: 301 -> 404") ("source: 301 -> 200", "source: 301 -> 404"): New tests. --- guix/scripts/lint.scm | 78 ++++++++++++++++++++++++++++++++--------------- tests/lint.scm | 83 +++++++++++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 137 insertions(+), 24 deletions(-) (limited to 'guix') 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 @@ (define response (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 @@ (define response (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 @@ (define (validate-uri uri package 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 @@ (define (validate-uri uri package field) ((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/tests/lint.scm b/tests/lint.scm index d7254bc070..1d0fc4708c 100644 --- a/tests/lint.scm +++ b/tests/lint.scm @@ -37,6 +37,7 @@ (define-module (test-lint) #:use-module (gnu packages glib) #:use-module (gnu packages pkg-config) #:use-module (gnu packages python) + #:use-module (web uri) #:use-module (web server) #:use-module (web server http) #:use-module (web response) @@ -433,6 +434,52 @@ (define-syntax-rule (with-warnings body ...) (check-home-page pkg)))) "not reachable: 404"))) +(test-skip (if (http-server-can-listen?) 0 1)) +(test-assert "home-page: 301, invalid" + (->bool + (string-contains + (with-warnings + (with-http-server 301 %long-string + (let ((pkg (package + (inherit (dummy-package "x")) + (home-page (%local-url))))) + (check-home-page pkg)))) + "invalid permanent redirect"))) + +(test-skip (if (http-server-can-listen?) 0 1)) +(test-assert "home-page: 301 -> 200" + (->bool + (string-contains + (with-warnings + (with-http-server 200 %long-string + (let ((initial-url (%local-url))) + (parameterize ((%http-server-port (+ 1 (%http-server-port)))) + (with-http-server (301 `((location + . ,(string->uri initial-url)))) + "" + (let ((pkg (package + (inherit (dummy-package "x")) + (home-page (%local-url))))) + (check-home-page pkg))))))) + "permanent redirect"))) + +(test-skip (if (http-server-can-listen?) 0 1)) +(test-assert "home-page: 301 -> 404" + (->bool + (string-contains + (with-warnings + (with-http-server 404 "booh!" + (let ((initial-url (%local-url))) + (parameterize ((%http-server-port (+ 1 (%http-server-port)))) + (with-http-server (301 `((location + . ,(string->uri initial-url)))) + "" + (let ((pkg (package + (inherit (dummy-package "x")) + (home-page (%local-url))))) + (check-home-page pkg))))))) + "not reachable: 404"))) + (test-assert "source-file-name" (->bool (string-contains @@ -553,6 +600,42 @@ (define-syntax-rule (with-warnings body ...) (check-source pkg)))) "not reachable: 404"))) +(test-skip (if (http-server-can-listen?) 0 1)) +(test-equal "source: 301 -> 200" + "" + (with-warnings + (with-http-server 200 %long-string + (let ((initial-url (%local-url))) + (parameterize ((%http-server-port (+ 1 (%http-server-port)))) + (with-http-server (301 `((location . ,(string->uri initial-url)))) + "" + (let ((pkg (package + (inherit (dummy-package "x")) + (source (origin + (method url-fetch) + (uri (%local-url)) + (sha256 %null-sha256)))))) + (check-source pkg)))))))) + +(test-skip (if (http-server-can-listen?) 0 1)) +(test-assert "source: 301 -> 404" + (->bool + (string-contains + (with-warnings + (with-http-server 404 "booh!" + (let ((initial-url (%local-url))) + (parameterize ((%http-server-port (+ 1 (%http-server-port)))) + (with-http-server (301 `((location . ,(string->uri initial-url)))) + "" + (let ((pkg (package + (inherit (dummy-package "x")) + (source (origin + (method url-fetch) + (uri (%local-url)) + (sha256 %null-sha256)))))) + (check-source pkg))))))) + "not reachable: 404"))) + (test-assert "mirror-url" (string-null? (with-warnings -- cgit v1.2.3 From 91525b486c23d2b3d5755a88d3b51f37ecba0597 Mon Sep 17 00:00:00 2001 From: Leo Famulari Date: Tue, 19 Sep 2017 21:08:42 -0400 Subject: build: Add the Go build system. * guix/build-system/go.scm, guix/build/go-build-system.scm: New files. * Makefile.am (MODULES): Add new files. * doc/guix.texi (Build Systems): Document the go-build-system. --- Makefile.am | 2 + doc/guix.texi | 18 ++++ guix/build-system/go.scm | 132 +++++++++++++++++++++++++ guix/build/go-build-system.scm | 217 +++++++++++++++++++++++++++++++++++++++++ 4 files changed, 369 insertions(+) create mode 100644 guix/build-system/go.scm create mode 100644 guix/build/go-build-system.scm (limited to 'guix') diff --git a/Makefile.am b/Makefile.am index d054f78791..efbd07a351 100644 --- a/Makefile.am +++ b/Makefile.am @@ -80,6 +80,7 @@ MODULES = \ guix/build-system/dub.scm \ guix/build-system/emacs.scm \ guix/build-system/font.scm \ + guix/build-system/go.scm \ guix/build-system/meson.scm \ guix/build-system/minify.scm \ guix/build-system/asdf.scm \ @@ -111,6 +112,7 @@ MODULES = \ guix/build/meson-build-system.scm \ guix/build/minify-build-system.scm \ guix/build/font-build-system.scm \ + guix/build/go-build-system.scm \ guix/build/asdf-build-system.scm \ guix/build/git.scm \ guix/build/hg.scm \ diff --git a/doc/guix.texi b/doc/guix.texi index 0940ea4e71..6018198567 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -3576,6 +3576,24 @@ debugging information''), which roughly means that code is compiled with @code{-O2 -g}, as is the case for Autoconf-based packages by default. @end defvr +@defvr {Scheme Variable} go-build-system +This variable is exported by @code{(guix build-system go)}. It +implements a build procedure for Go packages using the standard +@url{https://golang.org/cmd/go/#hdr-Compile_packages_and_dependencies, +Go build mechanisms}. + +The user is expected to provide a value for the key @code{#:import-path} +and, in some cases, @code{#:unpack-path}. The +@url{https://golang.org/doc/code.html#ImportPaths, import path} +corresponds to the filesystem path expected by the package's build +scripts and any referring packages, and provides a unique way to +refer to a Go package. It is typically based on a combination of the +package source code's remote URI and filesystem hierarchy structure. In +some cases, you will need to unpack the package's source code to a +different directory structure than the one indicated by the import path, +and @code{#:unpack-path} should be used in such cases. +@end defvr + @defvr {Scheme Variable} glib-or-gtk-build-system This variable is exported by @code{(guix build-system glib-or-gtk)}. It is intended for use with packages making use of GLib or GTK+. 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 +;;; Copyright © 2017 Leo Famulari +;;; +;;; 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 . + +(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/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 +;;; Copyright © 2017 Leo Famulari +;;; +;;; 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 . + +(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 +;; . Thus, the import path is +;; . [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 +;; . The Go IPv4 +;; library's import path is . 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 . 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 : +;; 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)) -- cgit v1.2.3 From dd2de2842344ede8e92459fe66c5a45ca3dc40ff Mon Sep 17 00:00:00 2001 From: Christopher Baines Date: Wed, 11 Oct 2017 11:59:20 +0100 Subject: emacs-build-system: Handle missing programs when patching. Previously the string-append here would error, which isn't useful as it doesn't tell you which command couldn't be found. To make the error actionable, catch it earlier, and explicitly error. * guix/build/emacs-build-system.scm (patch-el-files): Handle (which cmd) returning #f. --- guix/build/emacs-build-system.scm | 8 ++++++-- 1 file changed, 6 insertions(+), 2 deletions(-) (limited to 'guix') diff --git a/guix/build/emacs-build-system.scm b/guix/build/emacs-build-system.scm index 2404dbddb4..1474c80dd3 100644 --- a/guix/build/emacs-build-system.scm +++ b/guix/build/emacs-build-system.scm @@ -92,8 +92,12 @@ (define* (patch-el-files #:key outputs #:allow-other-keys) (el-dir (string-append out %install-suffix "/" elpa-name-ver)) (substitute-cmd (lambda () (substitute* (find-files "." "\\.el$") - (("\"/bin/([^.].*)\"" _ cmd) - (string-append "\"" (which cmd) "\"")))))) + (("\"/bin/([^.].*)\"" _ 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. -- cgit v1.2.3 From 4cb036d604941ff8d1d9e9b32565bac64884a9ea Mon Sep 17 00:00:00 2001 From: Christopher Baines Date: Wed, 11 Oct 2017 11:51:25 +0100 Subject: emacs-build-system: Change how patch-el-files substitutes commands. Previously the regex would match from /bin/ to a closing quote. However, this is greedy, so will match up until the last ". This causes problems when there are several quotes on the same line, for example: org-effectiveness.el: 196: (call-process "/bin/bash" nil t nil "-c" strplot) Therefore, change . to \S so that it doesn't include whitespace characters. Changing to a lazy quantifier would be an option, if that were supported. * guix/build/emacs-build-system.scm (patch-el-files): Change the regular expression used. --- guix/build/emacs-build-system.scm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/build/emacs-build-system.scm b/guix/build/emacs-build-system.scm index 1474c80dd3..bd0d2e0266 100644 --- a/guix/build/emacs-build-system.scm +++ b/guix/build/emacs-build-system.scm @@ -92,7 +92,7 @@ (define* (patch-el-files #:key outputs #:allow-other-keys) (el-dir (string-append out %install-suffix "/" elpa-name-ver)) (substitute-cmd (lambda () (substitute* (find-files "." "\\.el$") - (("\"/bin/([^.].*)\"" _ cmd-name) + (("\"/bin/([^.]\\S*)\"" _ cmd-name) (let ((cmd (which cmd-name))) (unless cmd (error -- cgit v1.2.3