From 4ac3e010c9cbd9c09d41dbf472e45d57505a73ce Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 22 Mar 2021 17:07:12 +0100 Subject: lint: archival: Gracefully handle packages with a #f hash value. Fixes . Reported by Luis Felipe. * guix/lint.scm (check-archival): Check whether 'content-hash-value' returns true. --- guix/lint.scm | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/lint.scm b/guix/lint.scm index 311bc94cc3..be524b2b56 100644 --- a/guix/lint.scm +++ b/guix/lint.scm @@ -1264,7 +1264,8 @@ (define commit ((? origin? origin) ;; Since "save" origins are not supported for non-VCS source, all ;; we can do is tell whether a given tarball is available or not. - (if (origin-hash origin) ;XXX: for ungoogled-chromium + (if (and=> (origin-hash origin) ;XXX: for ungoogled-chromium + content-hash-value) ;& icecat (let ((hash (origin-hash origin))) (match (lookup-content (content-hash-value hash) (symbol->string -- cgit v1.2.3 From 96aa98b6ca78ffb798e309acac3c3e5068422f30 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 25 Mar 2021 22:41:05 +0100 Subject: import: print: Improve origin method name guesswork. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Fixes . Reported by Léo Le Bouter . * guix/import/print.scm (package->code): For METHOD, use 'variable-name' preferably, and call 'procedure-name' as a last resort. --- guix/import/print.scm | 11 ++++++++++- 1 file changed, 10 insertions(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/import/print.scm b/guix/import/print.scm index a2ab810a5c..dcc38abc70 100644 --- a/guix/import/print.scm +++ b/guix/import/print.scm @@ -79,7 +79,16 @@ (define (source->code source version) (file-name (origin-file-name source)) (patches (origin-patches source))) `(origin - (method ,(procedure-name method)) + ;; Since 'procedure-name' returns the procedure name within the + ;; module where it's defined, not its public name. Thus, try hard to + ;; find its public name and use 'procedure-name' as a last resort. + (method ,(or (any (lambda (module) + (variable-name method module)) + '((guix download) + (guix git-download) + (guix hg-download) + (guix svn-download))) + (procedure-name method))) (uri (string-append ,@(match (factorize-uri uri version) ((? string? uri) (list uri)) (factorized factorized)))) -- cgit v1.2.3 From 45fce38fb0b6c6796906149ade145b8d3594c1c6 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sat, 27 Mar 2021 18:39:28 +0100 Subject: http-client: 'http-multiple-get' is tail-recursive again. Fixes . Commit 205833b72c5517915a47a50dbe28e7024dc74e57 made 'http-multiple-get' non-tail-recursive. Each recursive call would install an exception handler. As the number of iterations grows beyond 1,000, quadratic complexity of 'raise-exception' would show and we'd spend most of our time there. * guix/http-client.scm (false-if-networking-error): New macro. (http-multiple-get): Use it around 'write-request' and 'put-bytevector' calls, and around 'read-response' call, in lieu of the inline 'catch' forms. --- guix/http-client.scm | 109 +++++++++++++++++++++++++-------------------------- 1 file changed, 53 insertions(+), 56 deletions(-) (limited to 'guix') diff --git a/guix/http-client.scm b/guix/http-client.scm index 4b4c14ed0b..99bbccafd6 100644 --- a/guix/http-client.scm +++ b/guix/http-client.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2020 Ludovic Courtès +;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2020, 2021 Ludovic Courtès ;;; Copyright © 2015 Mark H Weaver ;;; Copyright © 2012, 2015 Free Software Foundation, Inc. ;;; Copyright © 2017 Tobias Geerinckx-Rice @@ -147,6 +147,28 @@ (define* (http-fetch uri #:key port (text? #f) (buffered? #t) (uri->string uri) code (response-reason-phrase resp)))))))))))) +(define-syntax-rule (false-if-networking-error exp) + "Return #f if EXP triggers a network related exception as can occur when +reusing stale cached connections." + ;; FIXME: Duplicated from 'with-cached-connection'. + (catch #t + (lambda () + exp) + (lambda (key . args) + ;; If PORT was cached and the server closed the connection in the + ;; meantime, we get EPIPE. In that case, open a fresh connection and + ;; retry. We might also get 'bad-response or a similar exception from + ;; (web response) later on, once we've sent the request, or a + ;; ERROR/INVALID-SESSION from GnuTLS. + (if (or (and (eq? key 'system-error) + (= EPIPE (system-error-errno `(,key ,@args)))) + (and (eq? key 'gnutls-error) + (eq? (first args) error/invalid-session)) + (memq key + '(bad-response bad-header bad-header-component))) + #f + (apply throw key args))))) + (define* (http-multiple-get base-uri proc seed requests #:key port (verify-certificate? #t) (open-connection guix:open-connection-for-uri) @@ -185,25 +207,15 @@ (define batch ;; Inherit the HTTP proxying property from P. (set-http-proxy-port?! buffer (http-proxy-port? p)) - (catch #t - (lambda () - (for-each (cut write-request <> buffer) - batch) - (put-bytevector p (get)) - (force-output p)) - (lambda (key . args) - ;; If PORT becomes unusable, open a fresh connection and - ;; retry. - (if (or (and (eq? key 'system-error) - (= EPIPE (system-error-errno `(,key ,@args)))) - (and (eq? key 'gnutls-error) - (eq? (first args) error/invalid-session))) - (begin - (close-port p) ; close the broken port - (connect #f - requests - result)) - (apply throw key args))))) + (unless (false-if-networking-error + (begin + (for-each (cut write-request <> buffer) batch) + (put-bytevector p (get)) + (force-output p) + #t)) + ;; If PORT becomes unusable, open a fresh connection and retry. + (close-port p) ; close the broken port + (connect #f requests result))) ;; Now start processing responses. (let loop ((sent batch) @@ -219,42 +231,27 @@ (define batch (remainder (connect p remainder result)))) ((head tail ...) - (catch #t - (lambda () - (let* ((resp (read-response p)) - (body (response-body-port resp)) - (result (proc head resp body result))) - ;; The server can choose to stop responding at any time, - ;; in which case we have to try again. Check whether - ;; that is the case. Note that even upon "Connection: - ;; close", we can read from BODY. - (match (assq 'connection (response-headers resp)) - (('connection 'close) - (close-port p) - (connect #f ;try again - (drop requests (+ 1 processed)) - result)) - (_ - (loop tail (+ 1 processed) result))))) ;keep going - (lambda (key . args) - ;; If PORT was cached and the server closed the connection - ;; in the meantime, we get EPIPE. In that case, open a - ;; fresh connection and retry. We might also get - ;; 'bad-response or a similar exception from (web response) - ;; later on, once we've sent the request, or a - ;; ERROR/INVALID-SESSION from GnuTLS. - (if (or (and (eq? key 'system-error) - (= EPIPE (system-error-errno `(,key ,@args)))) - (and (eq? key 'gnutls-error) - (eq? (first args) error/invalid-session)) - (memq key - '(bad-response bad-header bad-header-component))) - (begin - (close-port p) - (connect #f ; try again - (drop requests (+ 1 processed)) - result)) - (apply throw key args)))))))))) + (match (false-if-networking-error (read-response p)) + ((? response? resp) + (let* ((body (response-body-port resp)) + (result (proc head resp body result))) + ;; The server can choose to stop responding at any time, + ;; in which case we have to try again. Check whether + ;; that is the case. Note that even upon "Connection: + ;; close", we can read from BODY. + (match (assq 'connection (response-headers resp)) + (('connection 'close) + (close-port p) + (connect #f ;try again + (drop requests (+ 1 processed)) + result)) + (_ + (loop tail (+ 1 processed) result))))) + (#f + (close-port p) + (connect #f ; try again + (drop requests (+ 1 processed)) + result))))))))) ;;; -- cgit v1.2.3 From 673e5276f6b4dda4bfa9dd5bb70220fc8b17abd2 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sun, 28 Mar 2021 22:04:01 +0200 Subject: http-client: Don't drop failed query when reconnecting. Reported by Christopher Baines . * guix/http-client.scm (http-multiple-get): Change 2nd argument to 'drop' to PROCESSED when (false-if-networking-error ...) returns #f. --- guix/http-client.scm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/http-client.scm b/guix/http-client.scm index 99bbccafd6..a2e11a1b73 100644 --- a/guix/http-client.scm +++ b/guix/http-client.scm @@ -250,7 +250,7 @@ (define batch (#f (close-port p) (connect #f ; try again - (drop requests (+ 1 processed)) + (drop requests processed) result))))))))) -- cgit v1.2.3 From 74a625ebadc5f0cb8ec4b2028e50f04c448b9f69 Mon Sep 17 00:00:00 2001 From: Felix Gruber Date: Sun, 28 Mar 2021 10:40:20 +0200 Subject: licenses: Add Free Art License 1.3. * guix/licenses.scm (lal1.3): New variable. * guix/import/utils.scm (spdx-string->license): Add LAL-1.3. Signed-off-by: Guillaume Le Vaillant --- guix/import/utils.scm | 1 + guix/licenses.scm | 7 +++++++ 2 files changed, 8 insertions(+) (limited to 'guix') diff --git a/guix/import/utils.scm b/guix/import/utils.scm index 64d1385164..6b85b3aa1d 100644 --- a/guix/import/utils.scm +++ b/guix/import/utils.scm @@ -169,6 +169,7 @@ (define (spdx-string->license str) ("Imlib2" 'license:imlib2) ("IPA" 'license:ipa) ("IPL-1.0" 'license:ibmpl1.0) + ("LAL-1.3" 'license:lal1.3) ("LGPL-2.0" 'license:lgpl2.0) ("LGPL-2.0+" 'license:lgpl2.0+) ("LGPL-2.1" 'license:lgpl2.1) diff --git a/guix/licenses.scm b/guix/licenses.scm index 0a36067387..4718ccf83f 100644 --- a/guix/licenses.scm +++ b/guix/licenses.scm @@ -16,6 +16,7 @@ ;;; Copyright © 2017 Rutger Helling ;;; Copyright © 2020 André Batista ;;; Copyright © 2020 Helio Machado <0x2b3bfa0+guix@googlemail.com> +;;; Copyright © 2021 Felix Gruber ;;; ;;; This file is part of GNU Guix. ;;; @@ -68,6 +69,7 @@ (define-module (guix licenses) imlib2 ipa knuth + lal1.3 lgpl2.0 lgpl2.0+ lgpl2.1 lgpl2.1+ lgpl3 lgpl3+ llgpl lppl lppl1.0+ lppl1.1+ lppl1.2 lppl1.2+ lppl1.3 lppl1.3+ @@ -411,6 +413,11 @@ (define knuth "http://www.ctan.org/license/knuth" "Modification are only permitted under a different name.")) +(define lal1.3 + (license "Free Art License 1.3" + "http://artlibre.org/licence/lal/en/" + "https://www.gnu.org/licenses/license-list#FreeArt")) + (define lgpl2.0 (license "LGPL 2.0" "https://www.gnu.org/licenses/old-licenses/lgpl-2.0.html" -- cgit v1.2.3 From 9f7b5990378c4bf609c327bfc767fee6071c9ee2 Mon Sep 17 00:00:00 2001 From: zimoun Date: Thu, 25 Mar 2021 02:04:49 +0100 Subject: build-system/julia: Turn on deprecation warnings. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit * guix/build/julia-build-system.scm (check): Set option '--depwarn=yes'. Signed-off-by: Ludovic Courtès --- guix/build/julia-build-system.scm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/build/julia-build-system.scm b/guix/build/julia-build-system.scm index 8f57045a8c..d74acf2a05 100644 --- a/guix/build/julia-build-system.scm +++ b/guix/build/julia-build-system.scm @@ -101,7 +101,7 @@ (define* (check #:key tests? source inputs outputs julia-package-name (or (getenv "JULIA_LOAD_PATH") ""))) (setenv "HOME" "/tmp") - (invoke "julia" + (invoke "julia" "--depwarn=yes" (string-append builddir "packages/" package "/test/runtests.jl")))) #t) -- cgit v1.2.3 From 3a5fbced6fa1b1dd5bad45b6fccceb84f0470c8d Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 24 Mar 2021 22:38:39 +0100 Subject: gexp: 'imported+compiled-modules' fully honors #:guile. * guix/gexp.scm (imported+compiled-modules): Pass #:guile to 'imported-modules'. --- guix/gexp.scm | 1 + 1 file changed, 1 insertion(+) (limited to 'guix') diff --git a/guix/gexp.scm b/guix/gexp.scm index b9a2483773..b01c78b267 100644 --- a/guix/gexp.scm +++ b/guix/gexp.scm @@ -936,6 +936,7 @@ (define* (imported+compiled-modules modules system (mcached equal? (mlet %store-monad ((modules (if (pair? modules) (imported-modules modules + #:guile guile #:system system #:module-path module-path) (return #f))) -- cgit v1.2.3 From 58210fbea2dbc66ee0947eba7d5def2e593797a4 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 24 Mar 2021 22:40:31 +0100 Subject: gexp: Add #:guile parameter to 'load-path-expression'. * guix/gexp.scm (load-path-expression): Add #:guile parameter and honor it. --- guix/gexp.scm | 25 +++++++++++++++---------- 1 file changed, 15 insertions(+), 10 deletions(-) (limited to 'guix') diff --git a/guix/gexp.scm b/guix/gexp.scm index b01c78b267..654ac0f4d7 100644 --- a/guix/gexp.scm +++ b/guix/gexp.scm @@ -1735,21 +1735,26 @@ (define (default-guile) 'guile-3.0)) (define* (load-path-expression modules #:optional (path %load-path) - #:key (extensions '()) system target) + #:key (extensions '()) system target + (guile (default-guile))) "Return as a monadic value a gexp that sets '%load-path' and '%load-compiled-path' to point to MODULES, a list of module names. MODULES -are searched for in PATH. Return #f when MODULES and EXTENSIONS are empty." +are searched for in PATH. Return #f when MODULES and EXTENSIONS are empty. +Assume MODULES are compiled with GUILE." (if (and (null? modules) (null? extensions)) (with-monad %store-monad (return #f)) - (mlet %store-monad ((modules (imported-modules modules - #:module-path path - #:system system)) - (compiled (compiled-modules modules - #:extensions extensions - #:module-path path - #:system system - #:target target))) + (mlet* %store-monad ((guile (lower-object guile system #:target #f)) + (compiled (compiled-modules modules + #:guile guile + #:extensions extensions + #:module-path path + #:system system + #:target target)) + (modules (imported-modules modules + #:guile guile + #:module-path path + #:system system))) (return (gexp (eval-when (expand load eval) ;; Augment the load paths and delete duplicates. Do that -- cgit v1.2.3 From 19c6ea9ca4d66e7c7c979a17ad92779ea44c5e9e Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 24 Mar 2021 22:42:00 +0100 Subject: gexp: 'gexp->script' uses #:guile also as the guile-for-build. Previously 'gexp->script' would unconditionally use the default #:guile-for-build value of 'gexp->derivation'. * guix/gexp.scm (gexp->script): Pass #:guile to 'load-path-expression'. Pass #:guile-for-build to 'gexp->derivation'. --- guix/gexp.scm | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/gexp.scm b/guix/gexp.scm index 654ac0f4d7..afb935761e 100644 --- a/guix/gexp.scm +++ b/guix/gexp.scm @@ -1800,10 +1800,13 @@ (define* (gexp->script name exp (set-load-path (load-path-expression (gexp-modules exp) module-path + #:guile guile #:extensions (gexp-extensions exp) #:system system - #:target target))) + #:target target)) + (guile-for-build + (lower-object guile system #:target #f))) (gexp->derivation name (gexp (call-with-output-file (ungexp output) @@ -1826,6 +1829,7 @@ (define* (gexp->script name exp #:system system #:target target #:module-path module-path + #:guile-for-build guile-for-build ;; These derivations are not worth offloading or ;; substituting. -- cgit v1.2.3 From e733f66b5ba33d9971085076411c2ecb08884d26 Mon Sep 17 00:00:00 2001 From: Mathieu Othacehe Date: Mon, 29 Mar 2021 16:55:58 +0200 Subject: Fix substitutes server discovery. This is a follow-up of bc3896db25c788c181c7bcd65754e7cd378e9d9f. * guix/scripts/substitute.scm (%local-substitute-urls): Test for "true" instead of "yes". --- guix/scripts/substitute.scm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/scripts/substitute.scm b/guix/scripts/substitute.scm index 46323c7216..ccdc4137e8 100755 --- a/guix/scripts/substitute.scm +++ b/guix/scripts/substitute.scm @@ -655,7 +655,7 @@ (define %local-substitute-urls ;; If the following option is passed to the daemon, use the substitutes list ;; provided by "guix discover" process. (let* ((option (find-daemon-option "discover")) - (discover? (and option (string=? option "yes")))) + (discover? (and option (string=? option "true")))) (if discover? (randomize-substitute-urls (read-substitute-urls)) '()))) -- cgit v1.2.3 From 55c25ee4c5cee0707c94f773eb7d1686f79cff75 Mon Sep 17 00:00:00 2001 From: zimoun Date: Mon, 29 Mar 2021 15:11:17 +0200 Subject: scripts: import: cran: Add missing help for 'style' option. * guix/scripts/import/cran.scm (show-help): Add help message for 'style' option. Signed-off-by: Christopher Baines --- guix/scripts/import/cran.scm | 2 ++ 1 file changed, 2 insertions(+) (limited to 'guix') diff --git a/guix/scripts/import/cran.scm b/guix/scripts/import/cran.scm index 4767bc082d..aa3ef324e0 100644 --- a/guix/scripts/import/cran.scm +++ b/guix/scripts/import/cran.scm @@ -50,6 +50,8 @@ (define (show-help) (display (G_ " -r, --recursive import packages recursively")) (display (G_ " + -s, --style=STYLE choose output style, either specification or variable")) + (display (G_ " -V, --version display version information and exit")) (newline) (show-bug-report-information)) -- cgit v1.2.3 From 1575da60628cf2594cd7b1ab0812ec4c50ac5092 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 29 Mar 2021 17:28:34 +0200 Subject: gnu-maintenance: Recognize "-source" tarball suffix. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Fixes . Reported by Léo Le Bouter . * guix/gnu-maintenance.scm (%tarball-rx): Add "-[Ss]ource" suffix. * tests/gnu-maintenance.scm ("release-file?"): Add exiv2 example. --- guix/gnu-maintenance.scm | 2 +- tests/gnu-maintenance.scm | 3 ++- 2 files changed, 3 insertions(+), 2 deletions(-) (limited to 'guix') diff --git a/guix/gnu-maintenance.scm b/guix/gnu-maintenance.scm index 031a899a6c..4078e1f922 100644 --- a/guix/gnu-maintenance.scm +++ b/guix/gnu-maintenance.scm @@ -242,7 +242,7 @@ (define %tarball-rx ;; The "-src" pattern is for "TeXmacs-1.0.7.9-src.tar.gz". ;; The "-gnu[0-9]" pattern is for "icecat-38.4.0-gnu1.tar.bz2". ;; Accept underscores as in "PKG_1.2.tar.gz" for some non-GNU packages. - (make-regexp "^([^.]+)[-_]([0-9]|[^-])+(-(src|gnu[0-9]))?\\.(tar\\.|zip$)")) + (make-regexp "^([^.]+)[-_]([0-9]|[^-])+(-(src|[sS]ource|gnu[0-9]))?\\.(tar\\.|zip$)")) (define %alpha-tarball-rx (make-regexp "^.*-.*[0-9](-|~)?(alpha|beta|rc|RC|cvs|svn|git)-?[0-9\\.]*\\.tar\\.")) diff --git a/tests/gnu-maintenance.scm b/tests/gnu-maintenance.scm index a3e48a0933..59e79905c5 100644 --- a/tests/gnu-maintenance.scm +++ b/tests/gnu-maintenance.scm @@ -30,7 +30,8 @@ (define-module (test-gnu-maintenance) ("texmacs" "TeXmacs-1.0.7.9-src.tar.gz") ("icecat" "icecat-38.4.0-gnu1.tar.bz2") ("mit-scheme" "mit-scheme-9.2.tar.gz") - ("mediainfo" "mediainfo_20.09.tar.xz"))) + ("mediainfo" "mediainfo_20.09.tar.xz") + ("exiv2" "exiv2-0.27.3-Source.tar.gz"))) (every (lambda (project+file) (not (apply release-file? project+file))) '(("guile" "guile-www-1.1.1.tar.gz") -- cgit v1.2.3 From 1fa4aff1fbb46bbb9df8486ca12bfcfe6144458a Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sun, 21 Mar 2021 17:20:10 +0100 Subject: substitute: Emit a single newline upon completion. The immediate effect is that, with '--verbosity=1', only two lines are displayed for each substitute, instead of two lines followed by an empty line. * guix/scripts/substitute.scm (process-substitution): Emit a single newline upon completion when PRINT-BUILD-TRACE? is true. --- guix/scripts/substitute.scm | 7 +++++-- 1 file changed, 5 insertions(+), 2 deletions(-) (limited to 'guix') diff --git a/guix/scripts/substitute.scm b/guix/scripts/substitute.scm index ccdc4137e8..79eaabd8fd 100755 --- a/guix/scripts/substitute.scm +++ b/guix/scripts/substitute.scm @@ -555,8 +555,11 @@ (define cpu-usage (every (compose zero? cdr waitpid) pids) ;; Skip a line after what 'progress-reporter/file' printed, and another - ;; one to visually separate substitutions. - (display "\n\n" (current-error-port)) + ;; one to visually separate substitutions. When PRINT-BUILD-TRACE? is + ;; true, leave it up to (guix status) to prettify things. + (newline (current-error-port)) + (unless print-build-trace? + (newline (current-error-port))) ;; Check whether we got the data announced in NARINFO. (let ((actual (get-hash))) -- cgit v1.2.3 From e45ef9a648c155c35b51e6b15049a1bd5416f0a1 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sun, 21 Mar 2021 17:23:40 +0100 Subject: status: Don't display download URLs for '--verbosity=1'. With this change, each substitute occupies a single line of output (instead of two) when using '-v1', the default for 'guix package' & co. * guix/status.scm (print-build-event): Add #:print-urls? and honor it. (print-build-event/quiet): Pass #:print-urls? #f. (print-build-event/quiet-with-urls): New procedure. (logger-for-level): Add case for LEVEL 2. * doc/guix.texi (Common Build Options): Adjust '--verbosity' documentation. --- doc/guix.texi | 7 ++++--- guix/status.scm | 23 +++++++++++++++++++---- 2 files changed, 23 insertions(+), 7 deletions(-) (limited to 'guix') diff --git a/doc/guix.texi b/doc/guix.texi index 642d886ce0..af8a5149d8 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -10264,9 +10264,10 @@ guix-daemon, @option{--timeout}}). @cindex build logs, verbosity @item -v @var{level} @itemx --verbosity=@var{level} -Use the given verbosity @var{level}, an integer. Choosing 0 means that no -output is produced, 1 is for quiet output, and 2 shows all the build log -output on standard error. +Use the given verbosity @var{level}, an integer. Choosing 0 means that +no output is produced, 1 is for quiet output; 2 is similar to 1 but it +additionally displays download URLs; 3 shows all the build log output on +standard error. @item --cores=@var{n} @itemx -c @var{n} diff --git a/guix/status.scm b/guix/status.scm index d47bf1700c..362ae2882c 100644 --- a/guix/status.scm +++ b/guix/status.scm @@ -403,10 +403,12 @@ (define* (print-build-event event old-status status #:optional (port (current-error-port)) #:key (colorize? (color-output? port)) + (print-urls? #t) (print-log? #t)) "Print information about EVENT and STATUS to PORT. When COLORIZE? is true, produce colorful output. When PRINT-LOG? is true, display the build log in -addition to build events." +addition to build events. When PRINT-URLS? is true, display the URL of +substitutes being downloaded." (define info (if colorize? (cute colorize-string <> (color BOLD)) @@ -526,9 +528,10 @@ (define erase-current-line* (format port (info (G_ "substituting ~a...")) item) (newline port))) (('download-started item uri _ ...) - (erase-current-line*) - (format port (info (G_ "downloading from ~a ...")) uri) - (newline port)) + (when print-urls? + (erase-current-line*) + (format port (info (G_ "downloading from ~a ...")) uri) + (newline port))) (('download-progress item uri (= string->number size) (= string->number transferred)) @@ -602,6 +605,17 @@ (define* (print-build-event/quiet event old-status status (colorize? (color-output? port))) (print-build-event event old-status status port #:colorize? colorize? + #:print-urls? #f + #:print-log? #f)) + +(define* (print-build-event/quiet-with-urls event old-status status + #:optional + (port (current-error-port)) + #:key + (colorize? (color-output? port))) + (print-build-event event old-status status port + #:colorize? colorize? + #:print-urls? #t ;show download URLs #:print-log? #f)) (define* (build-status-updater #:optional (on-change (const #t))) @@ -787,6 +801,7 @@ (define (logger-for-level level) "Return the logging procedure that corresponds to LEVEL." (cond ((<= level 0) (const #t)) ((= level 1) print-build-event/quiet) + ((= level 2) print-build-event/quiet-with-urls) (else print-build-event))) (define (call-with-status-verbosity level thunk) -- cgit v1.2.3 From 8f9052d5434a3a11e7b4ff14d6b0090256e08aa4 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 31 Mar 2021 16:08:05 +0200 Subject: scripts: Scripts that defaulted to -v2 now default to -v3. This is a followup to e45ef9a648c155c35b51e6b15049a1bd5416f0a1. * guix/scripts/archive.scm (%default-options): Change 'verbosity' to 3. * guix/scripts/build.scm (%default-options): Likewise. * guix/scripts/copy.scm (%default-options): Likewise. --- guix/scripts/archive.scm | 4 ++-- guix/scripts/build.scm | 2 +- guix/scripts/copy.scm | 4 ++-- 3 files changed, 5 insertions(+), 5 deletions(-) (limited to 'guix') diff --git a/guix/scripts/archive.scm b/guix/scripts/archive.scm index 91be1b02e1..ceac640432 100644 --- a/guix/scripts/archive.scm +++ b/guix/scripts/archive.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2019, 2020 Ludovic Courtès +;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2019, 2020, 2021 Ludovic Courtès ;;; Copyright © 2020 Tobias Geerinckx-Rice ;;; ;;; This file is part of GNU Guix. @@ -63,7 +63,7 @@ (define %default-options (print-build-trace? . #t) (print-extended-build-trace? . #t) (multiplexed-build-output? . #t) - (verbosity . 2) + (verbosity . 3) (debug . 0))) (define (show-help) diff --git a/guix/scripts/build.scm b/guix/scripts/build.scm index fa1bbf867d..2decdb45ed 100644 --- a/guix/scripts/build.scm +++ b/guix/scripts/build.scm @@ -333,7 +333,7 @@ (define %default-options (print-build-trace? . #t) (print-extended-build-trace? . #t) (multiplexed-build-output? . #t) - (verbosity . 2) + (verbosity . 3) (debug . 0))) (define (show-help) diff --git a/guix/scripts/copy.scm b/guix/scripts/copy.scm index 2780d4fbe9..52b476db54 100644 --- a/guix/scripts/copy.scm +++ b/guix/scripts/copy.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2016, 2017, 2019, 2020 Ludovic Courtès +;;; Copyright © 2016, 2017, 2019, 2020, 2021 Ludovic Courtès ;;; ;;; This file is part of GNU Guix. ;;; @@ -163,7 +163,7 @@ (define %default-options (print-extended-build-trace? . #t) (multiplexed-build-output? . #t) (debug . 0) - (verbosity . 2))) + (verbosity . 3))) ;;; -- cgit v1.2.3 From 1126bb9cf33f10f004a5f53331389c777c025e75 Mon Sep 17 00:00:00 2001 From: Tobias Geerinckx-Rice via Bug reports for GNU Guix Date: Tue, 9 Mar 2021 22:41:58 +0100 Subject: lint: Warn about single-character package names. A common-sense exception is made for R. * guix/lint.scm (check-name): New procedure. (%local-checkers): Add it. --- guix/lint.scm | 18 +++++++++++++++++- 1 file changed, 17 insertions(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/lint.scm b/guix/lint.scm index be524b2b56..cdd9dd14d7 100644 --- a/guix/lint.scm +++ b/guix/lint.scm @@ -6,7 +6,7 @@ ;;; Copyright © 2016 Danny Milosavljevic ;;; Copyright © 2016 Hartmut Goebel ;;; Copyright © 2017 Alex Kost -;;; Copyright © 2017 Tobias Geerinckx-Rice +;;; Copyright © 2017, 2021 Tobias Geerinckx-Rice ;;; Copyright © 2017, 2018, 2020 Efraim Flashner ;;; Copyright © 2018, 2019 Arun Isaac ;;; Copyright © 2020 Chris Marusich @@ -170,6 +170,18 @@ (define-record-type* (requires-store? lint-checker-requires-store? (default #f))) +(define (check-name package) + "Check whether PACKAGE's name matches our guidelines." + (let ((name (package-name package))) + ;; Currently checks only whether the name is too short. + (if (and (<= (string-length name) 1) + (not (string=? name "r"))) ; common-sense exception + (list + (make-warning package + (G_ "name should be longer than a single character") + #:field 'name)) + '()))) + (define (properly-starts-sentence? s) (string-match "^[(\"'`[:upper:][:digit:]]" s)) @@ -1446,6 +1458,10 @@ (define (check-formatting package) (define %local-checkers (list + (lint-checker + (name 'name) + (description "Validate package names") + (check check-name)) (lint-checker (name 'description) (description "Validate package descriptions") -- cgit v1.2.3 From 946f563d91502768eab25ac7a93bbd52b0278b06 Mon Sep 17 00:00:00 2001 From: zimoun Date: Mon, 29 Mar 2021 12:17:59 +0200 Subject: scripts: describe: Replace 'args-fold*' by 'parse-command-line'. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit * guix/scripts/describe.scm (define-command): Replace 'args-fold*' by 'parse-command-line'. Signed-off-by: Ludovic Courtès --- guix/scripts/describe.scm | 10 ++++------ 1 file changed, 4 insertions(+), 6 deletions(-) (limited to 'guix') diff --git a/guix/scripts/describe.scm b/guix/scripts/describe.scm index be2279d254..b5f6249176 100644 --- a/guix/scripts/describe.scm +++ b/guix/scripts/describe.scm @@ -2,6 +2,7 @@ ;;; Copyright © 2018, 2019, 2020, 2021 Ludovic Courtès ;;; Copyright © 2018 Oleg Pykhalov ;;; Copyright © 2020 Ekaitz Zarraga +;;; Copyright © 2021 Simon Tournier ;;; ;;; This file is part of GNU Guix. ;;; @@ -286,12 +287,9 @@ (define* (channel-commit-hyperlink channel (define-command (guix-describe . args) (synopsis "describe the channel revisions currently used") - (let* ((opts (args-fold* args %options - (lambda (opt name arg result) - (leave (G_ "~A: unrecognized option~%") - name)) - cons - %default-options)) + (let* ((opts (parse-command-line args %options (list %default-options) + #:build-options? #f + #:argument-handler cons)) (format (assq-ref opts 'format)) (profile (or (assq-ref opts 'profile) (current-profile)))) (with-error-handling -- cgit v1.2.3 From 8e4ca1b1d0c3200d54f57fcc2497a0f56a580dea Mon Sep 17 00:00:00 2001 From: zimoun Date: Mon, 29 Mar 2021 12:18:00 +0200 Subject: scripts: discover: Replace 'args-fold*' by 'parse-command-line'. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit * guix/scripts/discover.scm (define-command): Replace 'args-fold*' by 'parse-command-line'. Signed-off-by: Ludovic Courtès --- guix/scripts/discover.scm | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) (limited to 'guix') diff --git a/guix/scripts/discover.scm b/guix/scripts/discover.scm index 6aade81ed1..be1eaa6e95 100644 --- a/guix/scripts/discover.scm +++ b/guix/scripts/discover.scm @@ -1,5 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2020 Mathieu Othacehe +;;; Copyright © 2021 Simon Tournier ;;; ;;; This file is part of GNU Guix. ;;; @@ -127,12 +128,11 @@ (define-command (guix-discover . args) (synopsis "discover Guix related services using Avahi") (with-error-handling - (let* ((opts (args-fold* args %options - (lambda (opt name arg result) - (leave (G_ "~A: unrecognized option~%") name)) - (lambda (arg result) - (leave (G_ "~A: extraneous argument~%") arg)) - %default-options)) + (let* ((opts (parse-command-line args %options (list %default-options) + #:build-options? #f + #:argument-handler + (lambda (arg result) + (leave (G_ "~A: extraneous argument~%") arg)))) (cache (assoc-ref opts 'cache)) (publish-file (publish-file cache))) (parameterize ((%publish-file publish-file)) -- cgit v1.2.3 From d8382d1ef63e8188efe60df84f78aeed449b4c67 Mon Sep 17 00:00:00 2001 From: zimoun Date: Mon, 29 Mar 2021 12:18:01 +0200 Subject: scripts: download: Replace 'args-fold*' by 'parse-command-line'. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit * guix/scripts/download.scm (define-command): Replace 'args-fold*' by 'parse-command-line'. Signed-off-by: Ludovic Courtès --- guix/scripts/download.scm | 17 ++++++++--------- 1 file changed, 8 insertions(+), 9 deletions(-) (limited to 'guix') diff --git a/guix/scripts/download.scm b/guix/scripts/download.scm index ce8dd8b02c..5a91390358 100644 --- a/guix/scripts/download.scm +++ b/guix/scripts/download.scm @@ -1,5 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2012, 2013, 2015, 2016, 2017, 2020 Ludovic Courtès +;;; Copyright © 2021 Simon Tournier ;;; ;;; This file is part of GNU Guix. ;;; @@ -162,15 +163,13 @@ (define-command (guix-download . args) (define (parse-options) ;; Return the alist of option values. - (args-fold* args %options - (lambda (opt name arg result) - (leave (G_ "~A: unrecognized option~%") name)) - (lambda (arg result) - (when (assq 'argument result) - (leave (G_ "~A: extraneous argument~%") arg)) - - (alist-cons 'argument arg result)) - %default-options)) + (parse-command-line args %options (list %default-options) + #:build-options? #f + #:argument-handler + (lambda (arg result) + (when (assq 'argument result) + (leave (G_ "~A: extraneous argument~%") arg)) + (alist-cons 'argument arg result)))) (with-error-handling (let* ((opts (parse-options)) -- cgit v1.2.3 From f4070b153dafc1102dcf3449bfec67071c2d9a4d Mon Sep 17 00:00:00 2001 From: zimoun Date: Mon, 29 Mar 2021 12:18:02 +0200 Subject: scripts: edit: Replace 'args-fold*' by 'parse-command-line'. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit * guix/scripts/edit.scm (define-command): Replace 'args-fold*' by 'parse-command-line'. Signed-off-by: Ludovic Courtès --- guix/scripts/edit.scm | 10 ++++------ 1 file changed, 4 insertions(+), 6 deletions(-) (limited to 'guix') diff --git a/guix/scripts/edit.scm b/guix/scripts/edit.scm index 49c9d945b6..b4c0507591 100644 --- a/guix/scripts/edit.scm +++ b/guix/scripts/edit.scm @@ -1,7 +1,7 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2015, 2016, 2019, 2020 Ludovic Courtès ;;; Copyright © 2015 Mathieu Lirzin -;;; Copyright © 2020 Simon Tournier +;;; Copyright © 2020, 2021 Simon Tournier ;;; ;;; This file is part of GNU Guix. ;;; @@ -84,11 +84,9 @@ (define-command (guix-edit . args) (define (parse-arguments) ;; Return the list of package names. - (args-fold* args %options - (lambda (opt name arg result) - (leave (G_ "~A: unrecognized option~%") name)) - cons - '())) + (parse-command-line args %options (list (list)) + #:build-options? #f + #:argument-handler cons)) (with-error-handling (let* ((specs (reverse (parse-arguments))) -- cgit v1.2.3 From ec3090e0c21cc18a697c8c150fbe0096d83ec4ca Mon Sep 17 00:00:00 2001 From: zimoun Date: Mon, 29 Mar 2021 12:18:03 +0200 Subject: scripts: publish: Replace 'args-fold*' by 'parse-command-line'. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit * guix/scripts/publish.scm (define-command): Replace 'args-fold*' by 'parse-command-line'. Signed-off-by: Ludovic Courtès --- guix/scripts/publish.scm | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) (limited to 'guix') diff --git a/guix/scripts/publish.scm b/guix/scripts/publish.scm index fa85088ed0..39bb224cad 100644 --- a/guix/scripts/publish.scm +++ b/guix/scripts/publish.scm @@ -3,6 +3,7 @@ ;;; Copyright © 2020 by Amar M. Singh ;;; Copyright © 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès ;;; Copyright © 2020 Maxim Cournoyer +;;; Copyright © 2021 Simon Tournier ;;; ;;; This file is part of GNU Guix. ;;; @@ -1117,12 +1118,11 @@ (define-command (guix-publish . args) (synopsis "publish build results over HTTP") (with-error-handling - (let* ((opts (args-fold* args %options - (lambda (opt name arg result) - (leave (G_ "~A: unrecognized option~%") name)) - (lambda (arg result) - (leave (G_ "~A: extraneous argument~%") arg)) - %default-options)) + (let* ((opts (parse-command-line args %options (list %default-options) + #:build-options? #f + #:argument-handler + (lambda (arg result) + (leave (G_ "~A: extraneous argument~%") arg)))) (advertise? (assoc-ref opts 'advertise?)) (user (assoc-ref opts 'user)) (port (assoc-ref opts 'port)) -- cgit v1.2.3 From f1bf6d3dbd913002f51c97c91c34a292ba0ecb5e Mon Sep 17 00:00:00 2001 From: zimoun Date: Mon, 29 Mar 2021 12:18:04 +0200 Subject: scripts: repl: Replace 'args-fold*' by 'parse-command-line'. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit * guix/scripts/repl.scm (define-command): Replace 'args-fold*' by 'parse-command-line'. Signed-off-by: Ludovic Courtès --- guix/scripts/repl.scm | 11 +++++------ 1 file changed, 5 insertions(+), 6 deletions(-) (limited to 'guix') diff --git a/guix/scripts/repl.scm b/guix/scripts/repl.scm index 9f20803efc..50d18c7760 100644 --- a/guix/scripts/repl.scm +++ b/guix/scripts/repl.scm @@ -1,6 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2018, 2019, 2020 Ludovic Courtès -;;; Copyright © 2020 Simon Tournier +;;; Copyright © 2020, 2021 Simon Tournier ;;; Copyright © 2020 Konrad Hinsen ;;; ;;; This file is part of GNU Guix. @@ -143,14 +143,13 @@ (define-command (guix-repl . args) (synopsis "read-eval-print loop (REPL) for interactive programming") (define opts - (args-fold* args %options - (lambda (opt name arg result) - (leave (G_ "~A: unrecognized option~%") name)) + (parse-command-line args %options (list %default-options) + #:build-options? #f + #:argument-handler (lambda (arg result) (append `((script . ,arg) (ignore-dot-guile? . #t)) - result)) - %default-options)) + result)))) (define user-config (and=> (getenv "HOME") -- cgit v1.2.3 From 0fac33a8ea837a27d911884a04daa347470ebf60 Mon Sep 17 00:00:00 2001 From: zimoun Date: Mon, 29 Mar 2021 12:18:05 +0200 Subject: scripts: search: Replace 'args-fold*' by 'parse-command-line'. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit * guix/scripts/search.scm (define-command): Replace 'args-fold*' by 'parse-command-line'. Signed-off-by: Ludovic Courtès --- guix/scripts/search.scm | 9 ++++----- 1 file changed, 4 insertions(+), 5 deletions(-) (limited to 'guix') diff --git a/guix/scripts/search.scm b/guix/scripts/search.scm index 0c9e6af07b..27b9da5278 100644 --- a/guix/scripts/search.scm +++ b/guix/scripts/search.scm @@ -1,5 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2019, 2020 Ludovic Courtès +;;; Copyright © 2021 Simon Tournier ;;; ;;; This file is part of GNU Guix. ;;; @@ -66,11 +67,9 @@ (define (handle-argument arg result) result)) (define opts - (args-fold* args %options - (lambda (opt name arg . rest) - (leave (G_ "~A: unrecognized option~%") name)) - handle-argument - '())) + (parse-command-line args %options (list (list)) + #:build-options? #f + #:argument-handler handle-argument)) (unless (assoc-ref opts 'query) (leave (G_ "missing arguments: no regular expressions to search for~%"))) -- cgit v1.2.3 From 4056ba364599d772463a1c2b89fd4998197afaa6 Mon Sep 17 00:00:00 2001 From: zimoun Date: Mon, 29 Mar 2021 12:18:06 +0200 Subject: scripts: show: Replace 'args-fold*' by 'parse-command-line'. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit * guix/scripts/show.scm (define-command): Replace 'args-fold*' by 'parse-command-line'. Signed-off-by: Ludovic Courtès --- guix/scripts/show.scm | 10 ++++------ 1 file changed, 4 insertions(+), 6 deletions(-) (limited to 'guix') diff --git a/guix/scripts/show.scm b/guix/scripts/show.scm index 535d03c1a6..c747eedd21 100644 --- a/guix/scripts/show.scm +++ b/guix/scripts/show.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2019 Simon Tournier +;;; Copyright © 2019, 2021 Simon Tournier ;;; ;;; This file is part of GNU Guix. ;;; @@ -66,11 +66,9 @@ (define (handle-argument arg result) result)) (define opts - (args-fold* args %options - (lambda (opt name arg . rest) - (leave (G_ "~A: unrecognized option~%") name)) - handle-argument - '())) + (parse-command-line args %options (list (list)) + #:build-options? #f + #:argument-handler handle-argument)) (unless (assoc-ref opts 'query) (leave (G_ "missing arguments: no package to show~%"))) -- cgit v1.2.3 From 23ea84cdf07c9b6bd4a61d14e5cb6009060f87cf Mon Sep 17 00:00:00 2001 From: Jelle Licht Date: Tue, 30 Mar 2021 01:27:31 -0400 Subject: build-system: Rewrite node build system. * guix/build/node-build-system.scm: Rewrite it. * guix/build-system/node.scm: Adjust accordingly. * gnu/packages/node-xyz.scm (node-semver): Likewise. Co-authored-by: Timothy Sample --- gnu/packages/node-xyz.scm | 6 +- guix/build-system/node.scm | 27 ++--- guix/build/node-build-system.scm | 207 ++++++++++++++++++--------------------- 3 files changed, 110 insertions(+), 130 deletions(-) (limited to 'guix') diff --git a/gnu/packages/node-xyz.scm b/gnu/packages/node-xyz.scm index b1d6d4ce59..60cc005ea4 100644 --- a/gnu/packages/node-xyz.scm +++ b/gnu/packages/node-xyz.scm @@ -261,7 +261,11 @@ (define-public node-semver "06biknqb05r9xsmcflm3ygh50pjvdk84x6r79w43kmck4fn3qn5p")))) (build-system node-build-system) (arguments - `(#:tests? #f)) ;; FIXME: Tests depend on node-tap + '(#:tests? #f ; FIXME: Tests depend on node-tap + #:phases + (modify-phases %standard-phases + ;; The only dependency to check for is tap, which we don't have. + (delete 'configure)))) (home-page "https://github.com/npm/node-semver") (synopsis "Parses semantic versions strings") (description diff --git a/guix/build-system/node.scm b/guix/build-system/node.scm index a8c5eed09b..4991ed53a5 100644 --- a/guix/build-system/node.scm +++ b/guix/build-system/node.scm @@ -1,5 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2016 Jelle Licht +;;; Copyright © 2019 Timothy Sample ;;; ;;; This file is part of GNU Guix. ;;; @@ -17,7 +18,6 @@ ;;; along with GNU Guix. If not, see . (define-module (guix build-system node) - #:use-module (guix store) #:use-module (guix utils) #:use-module (guix packages) #:use-module (guix derivations) @@ -25,22 +25,15 @@ (define-module (guix build-system node) #:use-module (guix build-system) #:use-module (guix build-system gnu) #:use-module (ice-9 match) - #:export (npm-meta-uri - %node-build-system-modules + #:export (%node-build-system-modules node-build node-build-system)) -(define (npm-meta-uri name) - "Return a URI string for the metadata of node module NAME found in the npm -registry." - (string-append "https://registry.npmjs.org/" name)) - (define %node-build-system-modules ;; Build-side modules imported by default. `((guix build node-build-system) (guix build json) - (guix build union) - ,@%gnu-build-system-modules)) ;; TODO: Might be not needed + ,@%gnu-build-system-modules)) (define (default-node) "Return the default Node package." @@ -76,7 +69,7 @@ (define private-keywords (define* (node-build store name inputs #:key - (npm-flags ''()) + (test-target "test") (tests? #t) (phases '(@ (guix build node-build-system) %standard-phases)) @@ -86,8 +79,6 @@ (define* (node-build store name inputs (guile #f) (imported-modules %node-build-system-modules) (modules '((guix build node-build-system) - (guix build json) - (guix build union) (guix build utils)))) "Build SOURCE using NODE and INPUTS." (define builder @@ -97,12 +88,10 @@ (define builder #:source ,(match (assoc-ref inputs "source") (((? derivation? source)) (derivation->output-path source)) - ((source) - source) - (source - source)) + ((source) source) + (source source)) #:system ,system - #:npm-flags ,npm-flags + #:test-target ,test-target #:tests? ,tests? #:phases ,phases #:outputs %outputs @@ -129,5 +118,5 @@ (define guile-for-build (define node-build-system (build-system (name 'node) - (description "The standard Node build system") + (description "The Node build system") (lower lower))) diff --git a/guix/build/node-build-system.scm b/guix/build/node-build-system.scm index 7799f03595..a55cab237c 100644 --- a/guix/build/node-build-system.scm +++ b/guix/build/node-build-system.scm @@ -1,6 +1,7 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2015 David Thompson -;;; Copyright © 2016 Jelle Licht +;;; Copyright © 2016, 2020 Jelle Licht +;;; Copyright © 2019, 2021 Timothy Sample ;;; ;;; This file is part of GNU Guix. ;;; @@ -19,144 +20,130 @@ (define-module (guix build node-build-system) #:use-module ((guix build gnu-build-system) #:prefix gnu:) - #:use-module (guix build json) - #:use-module (guix build union) #:use-module (guix build utils) + #:use-module (guix build json) + #:use-module (ice-9 ftw) #:use-module (ice-9 match) - #:use-module (ice-9 popen) - #:use-module (ice-9 regex) #:use-module (srfi srfi-1) - #:use-module (srfi srfi-26) #:export (%standard-phases node-build)) ;; Commentary: ;; -;; Builder-side code of the standard Node/npm package build procedure. +;; Builder-side code of the standard Node/NPM package install procedure. ;; ;; Code: -(define* (read-package-data #:key (filename "package.json")) - (call-with-input-file filename - (lambda (port) - (read-json port)))) +(define (set-home . _) + (with-directory-excursion ".." + (let loop ((i 0)) + (let ((dir (string-append "npm-home-" (number->string i)))) + (if (directory-exists? dir) + (loop (1+ i)) + (begin + (mkdir dir) + (setenv "HOME" (string-append (getcwd) "/" dir)) + (format #t "set HOME to ~s~%" (getenv "HOME"))))))) + #t) -(define* (build #:key inputs #:allow-other-keys) - (define (build-from-package-json? package-file) - (let* ((package-data (read-package-data #:filename package-file)) - (scripts (assoc-ref package-data "scripts"))) - (assoc-ref scripts "build"))) - "Build a new node module using the appropriate build system." - ;; XXX: Develop a more robust heuristic, allow override - (cond ((file-exists? "gulpfile.js") - (invoke "gulp")) - ((file-exists? "gruntfile.js") - (invoke "grunt")) - ((file-exists? "Makefile") - (invoke "make")) - ((and (file-exists? "package.json") - (build-from-package-json? "package.json")) - (invoke "npm" "run" "build"))) +(define (module-name module) + (let* ((package.json (string-append module "/package.json")) + (package-meta (call-with-input-file package.json read-json))) + (assoc-ref package-meta "name"))) + +(define (index-modules input-paths) + (define (list-modules directory) + (append-map (lambda (x) + (if (string-prefix? "@" x) + (list-modules (string-append directory "/" x)) + (list (string-append directory "/" x)))) + (filter (lambda (x) + (not (member x '("." "..")))) + (or (scandir directory) '())))) + (let ((index (make-hash-table (* 2 (length input-paths))))) + (for-each (lambda (dir) + (let ((nm (string-append dir "/lib/node_modules"))) + (for-each (lambda (module) + (hash-set! index (module-name module) module)) + (list-modules nm)))) + input-paths) + index)) + +(define* (patch-dependencies #:key inputs #:allow-other-keys) + + (define index (index-modules (map cdr inputs))) + + (define (resolve-dependencies package-meta meta-key) + (fold (lambda (key+value acc) + (match key+value + ('@ acc) + ((key . value) (acons key (hash-ref index key value) acc)))) + '() + (or (assoc-ref package-meta meta-key) '()))) + + (with-atomic-file-replacement "package.json" + (lambda (in out) + (let ((package-meta (read-json in))) + (assoc-set! package-meta "dependencies" + (append + '(@) + (resolve-dependencies package-meta "dependencies") + (resolve-dependencies package-meta "peerDependencies"))) + (assoc-set! package-meta "devDependencies" + (append + '(@) + (resolve-dependencies package-meta "devDependencies"))) + (write-json package-meta out)))) #t) -(define* (link-npm-dependencies #:key inputs #:allow-other-keys) - (define (inputs->node-inputs inputs) - "Filter the directory part from INPUTS." - (filter (lambda (input) - (match input - ((name . _) (node-package? name)))) - inputs)) - (define (inputs->directories inputs) - "Extract the directory part from INPUTS." - (match inputs - (((names . directories) ...) - directories))) - (define (make-node-path root) - (string-append root "/lib/node_modules/")) - - (let ((input-node-directories (inputs->directories - (inputs->node-inputs inputs)))) - (union-build "node_modules" - (map make-node-path input-node-directories)) +(define* (configure #:key outputs inputs #:allow-other-keys) + (let ((npm (string-append (assoc-ref inputs "node") "/bin/npm"))) + (invoke npm "--offline" "--ignore-scripts" "install") #t)) -(define configure link-npm-dependencies) +(define* (build #:key inputs #:allow-other-keys) + (let ((package-meta (call-with-input-file "package.json" read-json))) + (if (and=> (assoc-ref package-meta "scripts") + (lambda (scripts) + (assoc-ref scripts "build"))) + (let ((npm (string-append (assoc-ref inputs "node") "/bin/npm"))) + (invoke npm "run" "build")) + (format #t "there is no build script to run~%")) + #t)) -(define* (check #:key tests? #:allow-other-keys) +(define* (check #:key tests? inputs #:allow-other-keys) "Run 'npm test' if TESTS?" (if tests? - ;; Should only be enabled once we know that there are tests - (invoke "npm" "test")) + (let ((npm (string-append (assoc-ref inputs "node") "/bin/npm"))) + (invoke npm "test")) + (format #t "test suite not run~%")) #t) -(define (node-package? name) - "Check if NAME correspond to the name of an Node package." - (string-prefix? "node-" name)) +(define* (repack #:key inputs #:allow-other-keys) + (invoke "tar" "-czf" "../package.tgz" ".") + #t) (define* (install #:key outputs inputs #:allow-other-keys) - "Install the node module to the output store item. The module itself is -installed in a subdirectory of @file{node_modules} and its runtime dependencies -as defined by @file{package.json} are symlinked into a @file{node_modules} -subdirectory of the module's directory. Additionally, binaries are installed in -the @file{bin} directory." - (let* ((out (assoc-ref outputs "out")) - (target (string-append out "/lib")) - (binaries (string-append out "/bin")) - (data (read-package-data)) - (modulename (assoc-ref data "name")) - (binary-configuration (match (assoc-ref data "bin") - (('@ configuration ...) configuration) - ((? string? configuration) configuration) - (#f #f))) - (dependencies (match (assoc-ref data "dependencies") - (('@ deps ...) deps) - (#f #f)))) - (mkdir-p target) - (copy-recursively "." (string-append target "/node_modules/" modulename)) - ;; Remove references to dependencies - (delete-file-recursively - (string-append target "/node_modules/" modulename "/node_modules")) - (cond - ((string? binary-configuration) - (begin - (mkdir-p binaries) - (symlink (string-append target "/node_modules/" modulename "/" - binary-configuration) - (string-append binaries "/" modulename)))) - ((list? binary-configuration) - (for-each - (lambda (conf) - (match conf - ((key . value) - (begin - (mkdir-p (dirname (string-append binaries "/" key))) - (symlink (string-append target "/node_modules/" modulename "/" - value) - (string-append binaries "/" key)))))) - binary-configuration))) - (when dependencies - (mkdir-p - (string-append target "/node_modules/" modulename "/node_modules")) - (for-each - (lambda (dependency) - (let ((dependency (car dependency))) - (symlink - (string-append (assoc-ref inputs (string-append "node-" dependency)) - "/lib/node_modules/" dependency) - (string-append target "/node_modules/" modulename - "/node_modules/" dependency)))) - dependencies)) + "Install the node module to the output store item." + (let ((out (assoc-ref outputs "out")) + (npm (string-append (assoc-ref inputs "node") "/bin/npm"))) + (invoke npm "--prefix" out + "--global" + "--offline" + "--loglevel" "info" + "--production" + "install" "../package.tgz") #t)) - (define %standard-phases (modify-phases gnu:%standard-phases + (add-after 'unpack 'set-home set-home) + (add-before 'configure 'patch-dependencies patch-dependencies) (replace 'configure configure) (replace 'build build) - (replace 'install install) - (delete 'check) - (add-after 'install 'check check) - (delete 'strip))) + (replace 'check check) + (add-before 'install 'repack repack) + (replace 'install install))) (define* (node-build #:key inputs (phases %standard-phases) #:allow-other-keys #:rest args) -- cgit v1.2.3 From f6c43c932a39bfa73a9750daadcd20f505ddc939 Mon Sep 17 00:00:00 2001 From: Jelle Licht Date: Tue, 30 Mar 2021 01:27:43 -0400 Subject: gnu: Add node-lts. * gnu/packages/node.scm (node-lts): New variable. * guix/build-system/node.scm (default-node): Use it. --- gnu/packages/node.scm | 135 +++++++++++++++++++++++++++++++++++++++++++++ guix/build-system/node.scm | 2 +- 2 files changed, 136 insertions(+), 1 deletion(-) (limited to 'guix') diff --git a/gnu/packages/node.scm b/gnu/packages/node.scm index 26025c5d7c..4e80dd4d4e 100644 --- a/gnu/packages/node.scm +++ b/gnu/packages/node.scm @@ -580,6 +580,141 @@ (define-public llhttp-bootstrap source files.") (license license:expat))) +(define-public node-lts + (package + (inherit node) + (version "14.16.0") + (source (origin + (method url-fetch) + (uri (string-append "https://nodejs.org/dist/v" version + "/node-v" version ".tar.xz")) + (sha256 + (base32 + "19nz2mhmn6ikahxqyna1dn25pb5v3z9vsz9zb2flb6zp2yk4hxjf")) + (modules '((guix build utils))) + (snippet + `(begin + ;; Remove bundled software, where possible + (for-each delete-file-recursively + '("deps/cares" + "deps/icu-small" + "deps/nghttp2" + "deps/openssl" + "deps/zlib")) + (substitute* "Makefile" + ;; Remove references to bundled software. + (("deps/uv/uv.gyp") "") + (("deps/zlib/zlib.gyp") "")) + #t)))) + (arguments + (substitute-keyword-arguments (package-arguments node) + ((#:configure-flags configure-flags) + ''("--shared-cares" + "--shared-libuv" + "--shared-nghttp2" + "--shared-openssl" + "--shared-zlib" + "--shared-brotli" + "--with-intl=system-icu")) + ((#:phases phases) + `(modify-phases ,phases + (replace 'configure + ;; Node's configure script is actually a python script, so we can't + ;; run it with bash. + (lambda* (#:key outputs (configure-flags '()) inputs + #:allow-other-keys) + (let* ((prefix (assoc-ref outputs "out")) + (flags (cons (string-append "--prefix=" prefix) + configure-flags))) + (format #t "build directory: ~s~%" (getcwd)) + (format #t "configure flags: ~s~%" flags) + ;; Node's configure script expects the CC environment variable to + ;; be set. + (setenv "CC" ,(cc-for-target)) + (apply invoke + (string-append (assoc-ref inputs "python") + "/bin/python3") + "configure" flags)))) + (replace 'patch-files + (lambda* (#:key inputs #:allow-other-keys) + ;; Fix hardcoded /bin/sh references. + (substitute* '("lib/child_process.js" + "lib/internal/v8_prof_polyfill.js" + "test/parallel/test-child-process-spawnsync-shell.js" + "test/parallel/test-fs-write-sigxfsz.js" + "test/parallel/test-stdio-closed.js" + "test/sequential/test-child-process-emfile.js") + (("'/bin/sh'") + (string-append "'" (which "sh") "'"))) + + ;; Fix hardcoded /usr/bin/env references. + (substitute* '("test/parallel/test-child-process-default-options.js" + "test/parallel/test-child-process-env.js" + "test/parallel/test-child-process-exec-env.js") + (("'/usr/bin/env'") + (string-append "'" (which "env") "'"))) + + ;; FIXME: These tests fail in the build container, but they don't + ;; seem to be indicative of real problems in practice. + (for-each delete-file + '("test/parallel/test-cluster-master-error.js" + "test/parallel/test-cluster-master-kill.js")) + + ;; These require a DNS resolver. + (for-each delete-file + '("test/parallel/test-dns.js" + "test/parallel/test-dns-lookupService-promises.js")) + + ;; FIXME: This test fails randomly: + ;; https://github.com/nodejs/node/issues/31213 + (delete-file "test/parallel/test-net-listen-after-destroying-stdin.js") + + ;; FIXME: These tests fail on armhf-linux: + ;; https://github.com/nodejs/node/issues/31970 + ,@(if (target-arm32?) + '((for-each delete-file + '("test/parallel/test-zlib.js" + "test/parallel/test-zlib-brotli.js" + "test/parallel/test-zlib-brotli-flush.js" + "test/parallel/test-zlib-brotli-from-brotli.js" + "test/parallel/test-zlib-brotli-from-string.js" + "test/parallel/test-zlib-convenience-methods.js" + "test/parallel/test-zlib-random-byte-pipes.js" + "test/parallel/test-zlib-write-after-flush.js"))) + '()) + + ;; These tests have an expiry date: they depend on the validity of + ;; TLS certificates that are bundled with the source. We want this + ;; package to be reproducible forever, so remove those. + ;; TODO: Regenerate certs instead. + (for-each delete-file + '("test/parallel/test-tls-passphrase.js" + "test/parallel/test-tls-server-verify.js")) + + ;; Replace pre-generated llhttp sources + (let ((llhttp (assoc-ref inputs "llhttp"))) + (copy-file (string-append llhttp "/src/llhttp.c") + "deps/llhttp/src/llhttp.c") + (copy-file (string-append llhttp "/src/api.c") + "deps/llhttp/src/api.c") + (copy-file (string-append llhttp "/src/http.c") + "deps/llhttp/src/http.c") + (copy-file (string-append llhttp "/include/llhttp.h") + "deps/llhttp/include/llhttp.h")) + #t)))))) + (inputs + `(("c-ares" ,c-ares) + ("icu4c" ,icu4c-67) + ("libuv" ,libuv-for-node) + ("llhttp" ,llhttp-bootstrap) + ("google-brotli" ,google-brotli) + ("nghttp2" ,nghttp2 "lib") + ("openssl" ,openssl) + ("zlib" ,zlib))) + (native-inputs + (alist-replace "python" (list python-3) + (package-native-inputs node))))) + (define-public libnode (package/inherit node (name "libnode") diff --git a/guix/build-system/node.scm b/guix/build-system/node.scm index 4991ed53a5..98f63f87ef 100644 --- a/guix/build-system/node.scm +++ b/guix/build-system/node.scm @@ -39,7 +39,7 @@ (define (default-node) "Return the default Node package." ;; Lazily resolve the binding to avoid a circular dependency. (let ((node (resolve-interface '(gnu packages node)))) - (module-ref node 'node))) + (module-ref node 'node-lts))) (define* (lower name #:key source inputs native-inputs outputs system target -- cgit v1.2.3 From 973b8af72549c9c41a3c7650e76313cab2939ae1 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 2 Apr 2021 10:30:07 +0200 Subject: git: Remove unused variables. This is a followup to 298f9d29d6c26e408a90d08d147d926aa6f81ab3, which left those variables despite being unnecessary. * guix/git.scm (clone*, update-cached-checkout): Remove unused 'auth-method' variable. --- guix/git.scm | 12 +++++------- 1 file changed, 5 insertions(+), 7 deletions(-) (limited to 'guix') diff --git a/guix/git.scm b/guix/git.scm index a5103547d3..1820036f25 100644 --- a/guix/git.scm +++ b/guix/git.scm @@ -185,10 +185,9 @@ (define (clone* url directory) (lambda () (mkdir-p directory) - (let ((auth-method (%make-auth-ssh-agent))) - (clone url directory - (make-clone-options - #:fetch-options (make-default-fetch-options))))) + (clone url directory + (make-clone-options + #:fetch-options (make-default-fetch-options)))) (lambda _ (false-if-exception (rmdir directory))))) @@ -389,9 +388,8 @@ (define canonical-ref ;; Only fetch remote if it has not been cloned just before. (when (and cache-exists? (not (reference-available? repository ref))) - (let ((auth-method (%make-auth-ssh-agent))) - (remote-fetch (remote-lookup repository "origin") - #:fetch-options (make-default-fetch-options)))) + (remote-fetch (remote-lookup repository "origin") + #:fetch-options (make-default-fetch-options))) (when recursive? (update-submodules repository #:log-port log-port)) -- cgit v1.2.3 From 426ade6c8bdab243da719e369a887284368179bb Mon Sep 17 00:00:00 2001 From: Xinglu Chen Date: Sun, 4 Apr 2021 11:52:03 +0200 Subject: import: go: Replace underscores with hyphens in package names. As per section '16.4.2 Package Naming' in the manual, use hypens instead of underscores in package names. * guix/import/go.scm (go-module->guix-package-name): Replace underscores with hyphens. Signed-off-by: Leo Famulari --- guix/import/go.scm | 9 ++++++--- 1 file changed, 6 insertions(+), 3 deletions(-) (limited to 'guix') diff --git a/guix/import/go.scm b/guix/import/go.scm index 7452b4c903..6c0231e113 100644 --- a/guix/import/go.scm +++ b/guix/import/go.scm @@ -4,6 +4,7 @@ ;;; Copyright © 2021 François Joulaud ;;; Copyright © 2021 Maxim Cournoyer ;;; Copyright © 2021 Ludovic Courtès +;;; Copyright © 2021 Xinglu Chen ;;; ;;; This file is part of GNU Guix. ;;; @@ -380,9 +381,11 @@ (define (go-module->guix-package-name module-path) "Converts a module's path to the canonical Guix format for Go packages." (string-downcase (string-append "go-" (string-replace-substring (string-replace-substring - module-path - "." "-") - "/" "-")))) + (string-replace-substring + module-path + "." "-") + "/" "-") + "_" "-")))) (define-record-type (make-module-meta import-prefix vcs repo-root) -- cgit v1.2.3 From b3679f2d10a3257fbbb016e01b4f553c137fd177 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sun, 4 Apr 2021 15:40:39 +0200 Subject: gnu-maintenance: 'generic-html' updates packages with the right property. * guix/gnu-maintenance.scm (html-updatable-package?): Return true for packages with a 'release-monitoring-url' property. This allows us to cater for packages with source fetched over, say, FTP, but with an HTML page to monitor. --- guix/gnu-maintenance.scm | 21 +++++++++++++-------- 1 file changed, 13 insertions(+), 8 deletions(-) (limited to 'guix') diff --git a/guix/gnu-maintenance.scm b/guix/gnu-maintenance.scm index 4078e1f922..eff26cced4 100644 --- a/guix/gnu-maintenance.scm +++ b/guix/gnu-maintenance.scm @@ -706,14 +706,19 @@ (define html-updatable-package? "ftp.gnu.org" "download.savannah.gnu.org" "pypi.org" "crates.io" "rubygems.org" "bioconductor.org"))) - (url-predicate (lambda (url) - (match (string->uri url) - (#f #f) - (uri - (let ((scheme (uri-scheme uri)) - (host (uri-host uri))) - (and (memq scheme '(http https)) - (not (member host hosting-sites)))))))))) + (define http-url? + (url-predicate (lambda (url) + (match (string->uri url) + (#f #f) + (uri + (let ((scheme (uri-scheme uri)) + (host (uri-host uri))) + (and (memq scheme '(http https)) + (not (member host hosting-sites))))))))) + + (lambda (package) + (or (assoc-ref (package-properties package) 'release-monitoring-url) + (http-url? package))))) (define (latest-html-updatable-release package) "Return the latest release of PACKAGE. Do that by crawling the HTML page of -- cgit v1.2.3 From e917027d1f6152475777239fa87a230039f355bb Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sun, 4 Apr 2021 21:54:16 +0200 Subject: gnu-maintenance: Remove unused procedure. * guix/gnu-maintenance.scm (savannah-package?): Remove. --- guix/gnu-maintenance.scm | 3 --- 1 file changed, 3 deletions(-) (limited to 'guix') diff --git a/guix/gnu-maintenance.scm b/guix/gnu-maintenance.scm index eff26cced4..c7972d13a5 100644 --- a/guix/gnu-maintenance.scm +++ b/guix/gnu-maintenance.scm @@ -637,9 +637,6 @@ (define (adjusted-upstream-source source rewrite-url) (lambda (urls) (map rewrite-url urls)))))) -(define savannah-package? - (url-prefix-predicate "mirror://savannah/")) - (define %savannah-base ;; One of the Savannah mirrors listed at ;; that serves valid -- cgit v1.2.3 From 6f32e27e970c2f92e5ee1b5b5ce513c61484178e Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sun, 4 Apr 2021 22:24:42 +0200 Subject: utils: 'tarball-sans-extension' recognizes ".tgz". * guix/utils.scm (tarball-sans-extension): Add ".tgz". --- guix/utils.scm | 1 + 1 file changed, 1 insertion(+) (limited to 'guix') diff --git a/guix/utils.scm b/guix/utils.scm index 2dd1ddeb8a..05af86fc37 100644 --- a/guix/utils.scm +++ b/guix/utils.scm @@ -696,6 +696,7 @@ (define (file-sans-extension file) (define (tarball-sans-extension tarball) "Return TARBALL without its .tar.* or .zip extension." (let ((end (or (string-contains tarball ".tar") + (string-contains tarball ".tgz") (string-contains tarball ".zip")))) (substring tarball 0 end))) -- cgit v1.2.3 From ceeea60bbc1e2be6a86cef208fcd80eb61c92934 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 5 Apr 2021 11:30:20 +0200 Subject: gnu-maintenance: Recognize more source tarball naming schemes. * guix/gnu-maintenance.scm (%package-name-rx): Add ".src" and ".orig" suffixes. * tests/gnu-maintenance.scm ("release-file?"): Add mpg321 and bvi examples. ("tarball->version"): New test. --- guix/gnu-maintenance.scm | 2 +- tests/gnu-maintenance.scm | 18 ++++++++++++++++-- 2 files changed, 17 insertions(+), 3 deletions(-) (limited to 'guix') diff --git a/guix/gnu-maintenance.scm b/guix/gnu-maintenance.scm index c7972d13a5..0390df59f1 100644 --- a/guix/gnu-maintenance.scm +++ b/guix/gnu-maintenance.scm @@ -595,7 +595,7 @@ (define (latest-gnu-release package) (define %package-name-rx ;; Regexp for a package name, e.g., "foo-X.Y". Since TeXmacs uses ;; "TeXmacs-X.Y-src", the `-src' suffix is allowed. - (make-regexp "^(.*)[-_](([0-9]|\\.)+)(-src)?")) + (make-regexp "^(.*)[-_](([0-9]|\\.)+)(-src|\\.src|\\.orig)?")) (define (gnu-package-name->name+version name+version) "Return the package name and version number extracted from NAME+VERSION." diff --git a/tests/gnu-maintenance.scm b/tests/gnu-maintenance.scm index 59e79905c5..837b80063a 100644 --- a/tests/gnu-maintenance.scm +++ b/tests/gnu-maintenance.scm @@ -19,7 +19,8 @@ (define-module (test-gnu-maintenance) #:use-module (guix gnu-maintenance) #:use-module (srfi srfi-1) - #:use-module (srfi srfi-64)) + #:use-module (srfi srfi-64) + #:use-module (ice-9 match)) (test-begin "gnu-maintenance") @@ -31,7 +32,9 @@ (define-module (test-gnu-maintenance) ("icecat" "icecat-38.4.0-gnu1.tar.bz2") ("mit-scheme" "mit-scheme-9.2.tar.gz") ("mediainfo" "mediainfo_20.09.tar.xz") - ("exiv2" "exiv2-0.27.3-Source.tar.gz"))) + ("exiv2" "exiv2-0.27.3-Source.tar.gz") + ("mpg321" "mpg321_0.3.2.orig.tar.gz") + ("bvi" "bvi-1.4.1.src.tar.gz"))) (every (lambda (project+file) (not (apply release-file? project+file))) '(("guile" "guile-www-1.1.1.tar.gz") @@ -40,4 +43,15 @@ (define-module (test-gnu-maintenance) ("mit-scheme" "mit-scheme-9.2-doc-pdf.tar.gz") ("gnutls" "gnutls-3.2.18-w32.zip"))))) +(test-assert "tarball->version" + (let ((tarball->version (@@ (guix gnu-maintenance) tarball->version))) + (every (match-lambda + ((file version) + (equal? (tarball->version file) version))) + '(("coreutils-8.32.tar.gz" "8.32") + ("mediainfo_20.09.tar.xz" "20.09") + ("exiv2-0.27.3-Source.tar.gz" "0.27.3") + ("mpg321_0.3.2.orig.tar.gz" "0.3.2") + ("bvi-1.4.1.src.tar.gz" "1.4.1"))))) + (test-end) -- cgit v1.2.3 From b92cfc322d2f3ca55315861ecf89b3340788a5f3 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sun, 4 Apr 2021 22:33:44 +0200 Subject: gnu-maintenance: Add 'sourceforge' updater. This updater currently covers 2.4% of the packages. * guix/gnu-maintenance.scm (latest-sourceforge-release): New procedure. (%sourceforge-updater): New variable. * doc/guix.texi (Invoking guix refresh): Document it. --- doc/guix.texi | 2 ++ guix/gnu-maintenance.scm | 52 ++++++++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 54 insertions(+) (limited to 'guix') diff --git a/doc/guix.texi b/doc/guix.texi index 957f14bc75..d1a15cb28b 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -11713,6 +11713,8 @@ list of updaters). Currently, @var{updater} may be one of: the updater for GNU packages; @item savannah the updater for packages hosted at @uref{https://savannah.gnu.org, Savannah}; +@item sourceforge +the updater for packages hosted at @uref{https://sourceforge.net, SourceForge}; @item gnome the updater for GNOME packages; @item kde diff --git a/guix/gnu-maintenance.scm b/guix/gnu-maintenance.scm index 0390df59f1..ba659c0a60 100644 --- a/guix/gnu-maintenance.scm +++ b/guix/gnu-maintenance.scm @@ -66,6 +66,7 @@ (define-module (guix gnu-maintenance) %gnu-updater %gnu-ftp-updater %savannah-updater + %sourceforge-updater %xorg-updater %kernel.org-updater %generic-html-updater)) @@ -660,6 +661,50 @@ (define (latest-savannah-release package) #:directory directory) (cut adjusted-upstream-source <> rewrite)))) +(define (latest-sourceforge-release package) + "Return the latest release of PACKAGE." + (define (uri-append uri extension) + ;; Return URI with EXTENSION appended. + (build-uri (uri-scheme uri) + #:host (uri-host uri) + #:path (string-append (uri-path uri) extension))) + + (define (valid-uri? uri) + ;; Return true if URI is reachable. + (false-if-exception + (case (response-code (http-head uri)) + ((200 302) #t) + (else #f)))) + + (let* ((name (package-upstream-name package)) + (base (string-append "https://sourceforge.net/projects/" + name "/files")) + (url (string-append base "/latest/download")) + (response (false-if-exception (http-head url)))) + (and response + (= 302 (response-code response)) + (response-location response) + (match (string-tokenize (uri-path (response-location response)) + (char-set-complement (char-set #\/))) + ((_ components ...) + (let* ((path (string-join components "/")) + (url (string-append "mirror://sourceforge/" path))) + (and (release-file? name (basename path)) + + ;; Take the heavy-handed approach of probing 3 additional + ;; URLs. XXX: Would be nicer if this could be avoided. + (let* ((loc (response-location response)) + (sig (any (lambda (extension) + (let ((uri (uri-append loc extension))) + (and (valid-uri? uri) + (string-append url extension)))) + '(".asc" ".sig" ".sign")))) + (upstream-source + (package name) + (version (tarball->version (basename path))) + (urls (list url)) + (signature-urls (and sig (list sig)))))))))))) + (define (latest-xorg-release package) "Return the latest release of PACKAGE." (let ((uri (string->uri (origin-uri (package-source package))))) @@ -774,6 +819,13 @@ (define %savannah-updater (pred (url-prefix-predicate "mirror://savannah/")) (latest latest-savannah-release))) +(define %sourceforge-updater + (upstream-updater + (name 'sourceforge) + (description "Updater for packages hosted on sourceforge.net") + (pred (url-prefix-predicate "mirror://sourceforge/")) + (latest latest-sourceforge-release))) + (define %xorg-updater (upstream-updater (name 'xorg) -- cgit v1.2.3 From 35ca3cfbcf6018cee94c6f458a74cfd814747812 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sun, 4 Apr 2021 22:44:41 +0200 Subject: upstream: 'package-latest-release' tries all the matching updaters. * guix/upstream.scm (package-latest-release): Try UPDATERS until one of them returns an upstream source. This is useful for packages with several matching updaters, such a zlib ('sourceforge' and 'generic-html'). --- guix/upstream.scm | 15 +++++++++------ 1 file changed, 9 insertions(+), 6 deletions(-) (limited to 'guix') diff --git a/guix/upstream.scm b/guix/upstream.scm index accd8967d8..632e9ebc4f 100644 --- a/guix/upstream.scm +++ b/guix/upstream.scm @@ -264,12 +264,15 @@ (define* (package-latest-release package #:optional (updaters (force %updaters))) "Return an upstream source to update PACKAGE, a object, or #f if -none of UPDATERS matches PACKAGE. It is the caller's responsibility to ensure -that the returned source is newer than the current one." - (match (lookup-updater package updaters) - ((? upstream-updater? updater) - ((upstream-updater-latest updater) package)) - (_ #f))) +none of UPDATERS matches PACKAGE. When several updaters match PACKAGE, try +them until one of them returns an upstream source. It is the caller's +responsibility to ensure that the returned source is newer than the current +one." + (any (match-lambda + (($ name description pred latest) + (and (pred package) + (latest package)))) + updaters)) (define* (package-latest-release* package #:optional -- cgit v1.2.3 From 709f30b8e466b5f7155255be4f2cee008f8d01a9 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sun, 4 Apr 2021 22:43:13 +0200 Subject: lint: refresh: Warn about missing or dysfunctional updaters. This feedback should help us improve updaters. * guix/lint.scm (check-for-updates): Return a warning when PACKAGE lacks an updater or when the updater returns #f. --- guix/lint.scm | 41 ++++++++++++++++++++++++++--------------- 1 file changed, 26 insertions(+), 15 deletions(-) (limited to 'guix') diff --git a/guix/lint.scm b/guix/lint.scm index cdd9dd14d7..a7d6bbba4f 100644 --- a/guix/lint.scm +++ b/guix/lint.scm @@ -1191,21 +1191,32 @@ (define* (check-vulnerabilities package (define (check-for-updates package) "Check if there is an update available for PACKAGE." - (match (with-networking-fail-safe - (format #f (G_ "while retrieving upstream info for '~a'") - (package-name package)) - #f - (package-latest-release* package)) - ((? upstream-source? source) - (if (version>? (upstream-source-version source) - (package-version package)) - (list - (make-warning package - (G_ "can be upgraded to ~a") - (list (upstream-source-version source)) - #:field 'version)) - '())) - (#f '()))) ; cannot find newer upstream release + (match (lookup-updater package) + (#f + (list (make-warning package (G_ "no updater for ~a") + (list (package-name package)) + #:field 'source))) + ((? upstream-updater? updater) + (match (with-networking-fail-safe + (format #f (G_ "while retrieving upstream info for '~a'") + (package-name package)) + #f + (package-latest-release package)) + ((? upstream-source? source) + (if (version>? (upstream-source-version source) + (package-version package)) + (list + (make-warning package + (G_ "can be upgraded to ~a") + (list (upstream-source-version source)) + #:field 'version)) + '())) + (#f ;cannot find upstream release + (list (make-warning package + (G_ "updater '~a' failed to find \ +upstream releases") + (list (upstream-updater-name updater)) + #:field 'source))))))) (define (check-archival package) -- cgit v1.2.3 From eb6ac483a5541481a97ab7227c33353074ff9964 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 8 Apr 2021 09:34:03 +0200 Subject: gnu-maintenance: 'sourceforge' updater reuses the same connection. * guix/gnu-maintenance.scm (latest-sourceforge-release): Call 'open-socket-for-uri' upfront. Pass #:port and #:keep-alive? to 'http-head'. Wrap body in 'dynamic-wind' and call 'close-port' upon exit. --- guix/gnu-maintenance.scm | 63 +++++++++++++++++++++++++++--------------------- 1 file changed, 36 insertions(+), 27 deletions(-) (limited to 'guix') diff --git a/guix/gnu-maintenance.scm b/guix/gnu-maintenance.scm index ba659c0a60..fece84b341 100644 --- a/guix/gnu-maintenance.scm +++ b/guix/gnu-maintenance.scm @@ -31,7 +31,7 @@ (define-module (guix gnu-maintenance) #:use-module (srfi srfi-34) #:use-module (rnrs io ports) #:use-module (system foreign) - #:use-module (guix http-client) + #:use-module ((guix http-client) #:hide (open-socket-for-uri)) #:use-module (guix ftp-client) #:use-module (guix utils) #:use-module (guix memoization) @@ -669,10 +669,10 @@ (define (uri-append uri extension) #:host (uri-host uri) #:path (string-append (uri-path uri) extension))) - (define (valid-uri? uri) + (define (valid-uri? uri port) ;; Return true if URI is reachable. (false-if-exception - (case (response-code (http-head uri)) + (case (response-code (http-head uri #:port port #:keep-alive? #t)) ((200 302) #t) (else #f)))) @@ -680,30 +680,39 @@ (define (valid-uri? uri) (base (string-append "https://sourceforge.net/projects/" name "/files")) (url (string-append base "/latest/download")) - (response (false-if-exception (http-head url)))) - (and response - (= 302 (response-code response)) - (response-location response) - (match (string-tokenize (uri-path (response-location response)) - (char-set-complement (char-set #\/))) - ((_ components ...) - (let* ((path (string-join components "/")) - (url (string-append "mirror://sourceforge/" path))) - (and (release-file? name (basename path)) - - ;; Take the heavy-handed approach of probing 3 additional - ;; URLs. XXX: Would be nicer if this could be avoided. - (let* ((loc (response-location response)) - (sig (any (lambda (extension) - (let ((uri (uri-append loc extension))) - (and (valid-uri? uri) - (string-append url extension)))) - '(".asc" ".sig" ".sign")))) - (upstream-source - (package name) - (version (tarball->version (basename path))) - (urls (list url)) - (signature-urls (and sig (list sig)))))))))))) + (uri (string->uri url)) + (port (false-if-exception (open-socket-for-uri uri))) + (response (and port + (http-head uri #:port port #:keep-alive? #t)))) + (dynamic-wind + (const #t) + (lambda () + (and response + (= 302 (response-code response)) + (response-location response) + (match (string-tokenize (uri-path (response-location response)) + (char-set-complement (char-set #\/))) + ((_ components ...) + (let* ((path (string-join components "/")) + (url (string-append "mirror://sourceforge/" path))) + (and (release-file? name (basename path)) + + ;; Take the heavy-handed approach of probing 3 additional + ;; URLs. XXX: Would be nicer if this could be avoided. + (let* ((loc (response-location response)) + (sig (any (lambda (extension) + (let ((uri (uri-append loc extension))) + (and (valid-uri? uri port) + (string-append url extension)))) + '(".asc" ".sig" ".sign")))) + (upstream-source + (package name) + (version (tarball->version (basename path))) + (urls (list url)) + (signature-urls (and sig (list sig))))))))))) + (lambda () + (when port + (close-port port)))))) (define (latest-xorg-release package) "Return the latest release of PACKAGE." -- cgit v1.2.3 From c5fd1b0bd362f8b8578a76a26a65ba5d00d48992 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 8 Apr 2021 22:17:03 +0200 Subject: build-system/qt: Wrappers only include relevant directories to XDG_DATA_DIRS. Fixes . Previously the wrapper's XDG_DATA_DIRS would contain any input that had a /share sub-directory, which is usually all build-time inputs. * guix/build/qt-build-system.scm (variables-for-wrapping)[collect-sub-dirs]: Add 'selectors' parameter and honor it. Change caller to handle selectors. Add selectors for /share. --- guix/build/qt-build-system.scm | 58 ++++++++++++++++++++++++++++-------------- 1 file changed, 39 insertions(+), 19 deletions(-) (limited to 'guix') diff --git a/guix/build/qt-build-system.scm b/guix/build/qt-build-system.scm index 005157b0a4..0d5531ce05 100644 --- a/guix/build/qt-build-system.scm +++ b/guix/build/qt-build-system.scm @@ -1,6 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2014 Federico Beffa -;;; Copyright © 2014, 2015 Ludovic Courtès +;;; Copyright © 2014, 2015, 2021 Ludovic Courtès ;;; Copyright © 2018 Mark H Weaver ;;; Copyright © 2019, 2020 Hartmut Goebel ;;; @@ -49,25 +49,45 @@ (define* (check-setup #:rest args) (define (variables-for-wrapping base-directories) - (define (collect-sub-dirs base-directories subdirectory) - (filter-map - (lambda (dir) - (let ((directory (string-append dir subdirectory))) - (if (directory-exists? directory) directory #f))) - base-directories)) + (define (collect-sub-dirs base-directories subdirectory + selectors) + ;; Append SUBDIRECTORY and each of BASE-DIRECTORIES, and return the subset + ;; that exists and has at least one of the SELECTORS sub-directories, + ;; unless SELECTORS is the empty list. + (filter-map (lambda (dir) + (let ((directory (string-append dir subdirectory))) + (and (directory-exists? directory) + (or (null? selectors) + (any (lambda (selector) + (directory-exists? + (string-append directory selector))) + selectors)) + directory))) + base-directories)) + + (filter-map + (match-lambda + ((variable directory selectors ...) + (match (collect-sub-dirs base-directories directory + selectors) + (() + #f) + (directories + `(,variable = ,directories))))) + + ;; These shall match the search-path-specification for Qt and KDE + ;; libraries. + (list '("XDG_DATA_DIRS" "/share" - (filter - (lambda (var-to-wrap) (not (null? (last var-to-wrap)))) - (map - (lambda (var-spec) - `(,(first var-spec) = ,(collect-sub-dirs base-directories (last var-spec)))) - (list - ;; these shall match the search-path-specification for Qt and KDE - ;; libraries - '("XDG_DATA_DIRS" "/share") - '("XDG_CONFIG_DIRS" "/etc/xdg") - '("QT_PLUGIN_PATH" "/lib/qt5/plugins") - '("QML2_IMPORT_PATH" "/lib/qt5/qml"))))) + ;; These are "selectors": consider /share if and only if at least + ;; one of these sub-directories exist. This avoids adding + ;; irrelevant packages to XDG_DATA_DIRS just because they have a + ;; /share sub-directory. + "/glib-2.0/schemas" "/sounds" "/themes" + "/cursors" "/wallpapers" "/icons" "/mime") + '("XDG_CONFIG_DIRS" "/etc/xdg") + '("QT_PLUGIN_PATH" "/lib/qt5/plugins") + '("QML2_IMPORT_PATH" "/lib/qt5/qml")))) (define* (wrap-all-programs #:key inputs outputs (qt-wrap-excluded-outputs '()) -- cgit v1.2.3 From 06eb21856f9535ab62d0becc92b4146e0620654e Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 8 Apr 2021 22:23:21 +0200 Subject: build-system/qt: Wrappers set 'QTWEBENGINEPROCESS_PATH' if needed. Suggested by Maxim Cournoyer . * guix/build/qt-build-system.scm (variables-for-wrapping): Add "QTWEBENGINEPROCESS_PATH". --- guix/build/qt-build-system.scm | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/build/qt-build-system.scm b/guix/build/qt-build-system.scm index 0d5531ce05..bd8e694209 100644 --- a/guix/build/qt-build-system.scm +++ b/guix/build/qt-build-system.scm @@ -87,7 +87,8 @@ (define (collect-sub-dirs base-directories subdirectory "/cursors" "/wallpapers" "/icons" "/mime") '("XDG_CONFIG_DIRS" "/etc/xdg") '("QT_PLUGIN_PATH" "/lib/qt5/plugins") - '("QML2_IMPORT_PATH" "/lib/qt5/qml")))) + '("QML2_IMPORT_PATH" "/lib/qt5/qml") + '("QTWEBENGINEPROCESS_PATH" "/lib/qt5/libexec/QtWebEngineProcess")))) (define* (wrap-all-programs #:key inputs outputs (qt-wrap-excluded-outputs '()) -- cgit v1.2.3 From 2d73086262e1fb33cd0f0f16f74a495fe06b38aa Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 6 Apr 2021 12:10:29 +0200 Subject: daemon: 'guix substitute' replies on FD 4. This avoids the situation where error messages would unintentionally go to stderr and be wrongfully interpreted as a reply by the daemon. Fixes . This is a followup to ee3226e9d54891c7e696912245e4904435be191c. * guix/scripts/substitute.scm (display-narinfo-data): Add 'port' parameter and honor it. (process-query): Likewise. (process-substitution): Likewise. (%error-to-file-descriptor-4?, with-redirected-error-port): Remove. (%reply-file-descriptor): New variable. (guix-substitute): Remove use of 'with-redirected-error-port'. Define 'reply-port' and pass it to 'process-query' and 'process-substitution'. * nix/libstore/build.cc (SubstitutionGoal::handleChildOutput): Swap 'builderOut' and 'fromAgent'. * nix/libstore/local-store.cc (LocalStore::getLineFromSubstituter): Likewise. * tests/substitute.scm : Set '%reply-file-descriptor' rather than '%error-to-file-descriptor-4?'. --- guix/scripts/substitute.scm | 191 +++++++++++++++++++++----------------------- nix/libstore/build.cc | 4 +- nix/libstore/local-store.cc | 12 +-- tests/substitute.scm | 4 +- 4 files changed, 99 insertions(+), 112 deletions(-) (limited to 'guix') diff --git a/guix/scripts/substitute.scm b/guix/scripts/substitute.scm index 79eaabd8fd..48309f9b3a 100755 --- a/guix/scripts/substitute.scm +++ b/guix/scripts/substitute.scm @@ -63,7 +63,7 @@ (define-module (guix scripts substitute) #:use-module (web uri) #:use-module (guix http-client) #:export (%allow-unauthenticated-substitutes? - %error-to-file-descriptor-4? + %reply-file-descriptor substitute-urls guix-substitute)) @@ -279,29 +279,29 @@ (define-syntax-rule (with-cpu-usage-monitoring exp ...) "Evaluate EXP... Return its CPU usage as a fraction between 0 and 1." (call-with-cpu-usage-monitoring (lambda () exp ...))) -(define (display-narinfo-data narinfo) - "Write to the current output port the contents of NARINFO in the format -expected by the daemon." - (format #t "~a\n~a\n~a\n" +(define (display-narinfo-data port narinfo) + "Write to PORT the contents of NARINFO in the format expected by the +daemon." + (format port "~a\n~a\n~a\n" (narinfo-path narinfo) (or (and=> (narinfo-deriver narinfo) (cute string-append (%store-prefix) "/" <>)) "") (length (narinfo-references narinfo))) - (for-each (cute format #t "~a/~a~%" (%store-prefix) <>) + (for-each (cute format port "~a/~a~%" (%store-prefix) <>) (narinfo-references narinfo)) (let-values (((uri compression file-size) (narinfo-best-uri narinfo #:fast-decompression? %prefer-fast-decompression?))) - (format #t "~a\n~a\n" + (format port "~a\n~a\n" (or file-size 0) (or (narinfo-size narinfo) 0)))) -(define* (process-query command +(define* (process-query port command #:key cache-urls acl) - "Reply to COMMAND, a query as written by the daemon to this process's + "Reply on PORT to COMMAND, a query as written by the daemon to this process's standard input. Use ACL as the access-control list against which to check authorized substitutes." (define valid? @@ -338,17 +338,17 @@ (define (report-progress) #:open-connection open-connection-for-uri/cached #:make-progress-reporter make-progress-reporter))) (for-each (lambda (narinfo) - (format #t "~a~%" (narinfo-path narinfo))) + (format port "~a~%" (narinfo-path narinfo))) substitutable) - (newline))) + (newline port))) (("info" paths ..1) ;; Reply info about PATHS if it's in CACHE-URLS. (let ((substitutable (lookup-narinfos/diverse cache-urls paths valid? #:open-connection open-connection-for-uri/cached #:make-progress-reporter make-progress-reporter))) - (for-each display-narinfo-data substitutable) - (newline))) + (for-each (cut display-narinfo-data port <>) substitutable) + (newline port))) (wtf (error "unknown `--query' command" wtf)))) @@ -428,14 +428,14 @@ (define-syntax-rule (with-cached-connection uri port exp ...) "Bind PORT with EXP... to a socket connected to URI." (call-with-cached-connection uri (lambda (port) exp ...))) -(define* (process-substitution store-item destination +(define* (process-substitution port store-item destination #:key cache-urls acl deduplicate? print-build-trace?) "Substitute STORE-ITEM (a store file name) from CACHE-URLS, and write it to DESTINATION as a nar file. Verify the substitute against ACL, and verify its hash against what appears in the narinfo. When DEDUPLICATE? is true, and if -DESTINATION is in the store, deduplicate its files. Print a status line on -the current output port." +DESTINATION is in the store, deduplicate its files. Print a status line to +PORT." (define narinfo (lookup-narinfo cache-urls store-item (if (%allow-unauthenticated-substitutes?) @@ -565,10 +565,10 @@ (define cpu-usage (let ((actual (get-hash))) (if (bytevector=? actual expected) ;; Tell the daemon that we're done. - (format (current-output-port) "success ~a ~a~%" + (format port "success ~a ~a~%" (narinfo-hash narinfo) (narinfo-size narinfo)) ;; The actual data has a different hash than that in NARINFO. - (format (current-output-port) "hash-mismatch ~a ~a ~a~%" + (format port "hash-mismatch ~a ~a ~a~%" (hash-algorithm-name algorithm) (bytevector->nix-base32-string expected) (bytevector->nix-base32-string actual))))))) @@ -682,28 +682,10 @@ (define (validate-uri uri) (unless (string->uri uri) (leave (G_ "~a: invalid URI~%") uri))) -(define %error-to-file-descriptor-4? - ;; Whether to direct 'current-error-port' to file descriptor 4 like - ;; 'guix-daemon' expects. - (make-parameter #t)) - -;; The daemon's agent code opens file descriptor 4 for us and this is where -;; stderr should go. -(define-syntax-rule (with-redirected-error-port exp ...) - "Evaluate EXP... with the current error port redirected to file descriptor 4 -if needed, as expected by the daemon's agent." - (let ((thunk (lambda () exp ...))) - (if (%error-to-file-descriptor-4?) - (parameterize ((current-error-port (fdopen 4 "wl"))) - ;; Redirect diagnostics to file descriptor 4 as well. - (guix-warning-port (current-error-port)) - - ;; 'with-continuation-barrier' captures the initial value of - ;; 'current-error-port' to report backtraces in case of uncaught - ;; exceptions. Without it, backtraces would be printed to FD 2, - ;; thereby confusing the daemon. - (with-continuation-barrier thunk)) - (thunk)))) +(define %reply-file-descriptor + ;; The file descriptor where replies to the daemon must be sent, or #f to + ;; use the current output port instead. + (make-parameter 4)) (define-command (guix-substitute . args) (category internal) @@ -719,68 +701,73 @@ (define print-build-trace? (define deduplicate? (find-daemon-option "deduplicate")) - (with-redirected-error-port - (mkdir-p %narinfo-cache-directory) - (maybe-remove-expired-cache-entries %narinfo-cache-directory - cached-narinfo-files - #:entry-expiration - cached-narinfo-expiration-time - #:cleanup-period - %narinfo-expired-cache-entry-removal-delay) - (check-acl-initialized) - - ;; Sanity-check SUBSTITUTE-URLS so we can provide a meaningful error - ;; message. - (for-each validate-uri (substitute-urls)) - - ;; Attempt to install the client's locale so that messages are suitably - ;; translated. LC_CTYPE must be a UTF-8 locale; it's the case by default - ;; so don't change it. - (match (or (find-daemon-option "untrusted-locale") - (find-daemon-option "locale")) - (#f #f) - (locale (false-if-exception (setlocale LC_MESSAGES locale)))) - - (catch 'system-error - (lambda () - (set-thread-name "guix substitute")) - (const #t)) ;GNU/Hurd lacks 'prctl' - - (with-networking - (with-error-handling ; for signature errors - (match args - (("--query") - (let ((acl (current-acl))) - (let loop ((command (read-line))) - (or (eof-object? command) - (begin - (process-query command - #:cache-urls (substitute-urls) - #:acl acl) - (loop (read-line))))))) - (("--substitute") - ;; Download STORE-PATH and store it as a Nar in file DESTINATION. - ;; Specify the number of columns of the terminal so the progress - ;; report displays nicely. - (parameterize ((current-terminal-columns (client-terminal-columns))) - (let loop () - (match (read-line) - ((? eof-object?) - #t) - ((= string-tokenize ("substitute" store-path destination)) - (process-substitution store-path destination - #:cache-urls (substitute-urls) - #:acl (current-acl) - #:deduplicate? deduplicate? - #:print-build-trace? - print-build-trace?) - (loop)))))) - ((or ("-V") ("--version")) - (show-version-and-exit "guix substitute")) - (("--help") - (show-help)) - (opts - (leave (G_ "~a: unrecognized options~%") opts))))))) + (define reply-port + ;; Port used to reply to the daemon. + (if (%reply-file-descriptor) + (fdopen (%reply-file-descriptor) "wl") + (current-output-port))) + + (mkdir-p %narinfo-cache-directory) + (maybe-remove-expired-cache-entries %narinfo-cache-directory + cached-narinfo-files + #:entry-expiration + cached-narinfo-expiration-time + #:cleanup-period + %narinfo-expired-cache-entry-removal-delay) + (check-acl-initialized) + + ;; Sanity-check SUBSTITUTE-URLS so we can provide a meaningful error + ;; message. + (for-each validate-uri (substitute-urls)) + + ;; Attempt to install the client's locale so that messages are suitably + ;; translated. LC_CTYPE must be a UTF-8 locale; it's the case by default + ;; so don't change it. + (match (or (find-daemon-option "untrusted-locale") + (find-daemon-option "locale")) + (#f #f) + (locale (false-if-exception (setlocale LC_MESSAGES locale)))) + + (catch 'system-error + (lambda () + (set-thread-name "guix substitute")) + (const #t)) ;GNU/Hurd lacks 'prctl' + + (with-networking + (with-error-handling ; for signature errors + (match args + (("--query") + (let ((acl (current-acl))) + (let loop ((command (read-line))) + (or (eof-object? command) + (begin + (process-query reply-port command + #:cache-urls (substitute-urls) + #:acl acl) + (loop (read-line))))))) + (("--substitute") + ;; Download STORE-PATH and store it as a Nar in file DESTINATION. + ;; Specify the number of columns of the terminal so the progress + ;; report displays nicely. + (parameterize ((current-terminal-columns (client-terminal-columns))) + (let loop () + (match (read-line) + ((? eof-object?) + #t) + ((= string-tokenize ("substitute" store-path destination)) + (process-substitution reply-port store-path destination + #:cache-urls (substitute-urls) + #:acl (current-acl) + #:deduplicate? deduplicate? + #:print-build-trace? + print-build-trace?) + (loop)))))) + ((or ("-V") ("--version")) + (show-version-and-exit "guix substitute")) + (("--help") + (show-help)) + (opts + (leave (G_ "~a: unrecognized options~%") opts)))))) ;;; Local Variables: ;;; eval: (put 'with-timeout 'scheme-indent-function 1) diff --git a/nix/libstore/build.cc b/nix/libstore/build.cc index 4f486f0822..5697ae5a43 100644 --- a/nix/libstore/build.cc +++ b/nix/libstore/build.cc @@ -3158,13 +3158,13 @@ void SubstitutionGoal::finished() void SubstitutionGoal::handleChildOutput(int fd, const string & data) { if (verbosity >= settings.buildVerbosity - && fd == substituter->builderOut.readSide) { + && fd == substituter->fromAgent.readSide) { writeToStderr(data); /* Don't write substitution output to a log file for now. We probably should, though. */ } - if (fd == substituter->fromAgent.readSide) { + if (fd == substituter->builderOut.readSide) { /* DATA may consist of several lines. Process them one by one. */ string input = data; while (!input.empty()) { diff --git a/nix/libstore/local-store.cc b/nix/libstore/local-store.cc index c304e2ddd1..675d1ba66f 100644 --- a/nix/libstore/local-store.cc +++ b/nix/libstore/local-store.cc @@ -780,8 +780,8 @@ Path LocalStore::queryPathFromHashPart(const string & hashPart) }); } -/* Read a line from the substituter's stdout, while also processing - its stderr. */ +/* Read a line from the substituter's reply file descriptor, while also + processing its stderr. */ string LocalStore::getLineFromSubstituter(Agent & run) { string res, err; @@ -802,9 +802,9 @@ string LocalStore::getLineFromSubstituter(Agent & run) } /* Completely drain stderr before dealing with stdout. */ - if (FD_ISSET(run.builderOut.readSide, &fds)) { + if (FD_ISSET(run.fromAgent.readSide, &fds)) { char buf[4096]; - ssize_t n = read(run.builderOut.readSide, (unsigned char *) buf, sizeof(buf)); + ssize_t n = read(run.fromAgent.readSide, (unsigned char *) buf, sizeof(buf)); if (n == -1) { if (errno == EINTR) continue; throw SysError("reading from substituter's stderr"); @@ -822,9 +822,9 @@ string LocalStore::getLineFromSubstituter(Agent & run) } /* Read from stdout until we get a newline or the buffer is empty. */ - else if (FD_ISSET(run.fromAgent.readSide, &fds)) { + else if (FD_ISSET(run.builderOut.readSide, &fds)) { unsigned char c; - readFull(run.fromAgent.readSide, (unsigned char *) &c, 1); + readFull(run.builderOut.readSide, (unsigned char *) &c, 1); if (c == '\n') { if (!err.empty()) printMsg(lvlError, "substitute: " + err); return res; diff --git a/tests/substitute.scm b/tests/substitute.scm index 697abc4684..21b513e1d8 100644 --- a/tests/substitute.scm +++ b/tests/substitute.scm @@ -1,6 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2014 Nikita Karetnikov -;;; Copyright © 2014, 2015, 2017, 2018, 2019 Ludovic Courtès +;;; Copyright © 2014, 2015, 2017, 2018, 2019, 2021 Ludovic Courtès ;;; ;;; This file is part of GNU Guix. ;;; @@ -198,7 +198,7 @@ (define-syntax-rule (with-narinfo* narinfo directory body ...) ;; Never use file descriptor 4, unlike what happens when invoked by the ;; daemon. -(%error-to-file-descriptor-4? #f) +(%reply-file-descriptor #f) (test-equal "query narinfo without signature" -- cgit v1.2.3 From 2446a112dfb79e851449b832006c1160bf818504 Mon Sep 17 00:00:00 2001 From: Maxim Cournoyer Date: Fri, 5 Mar 2021 09:21:14 -0500 Subject: import: utils: Refactor maybe-inputs and add maybe-propagated-inputs. * guix/import/utils.scm (maybe-inputs)[type]: New argument. Update docstring. The argument is used to derive the input field name to use. (maybe-native-inputs): Adjust to use the above. (maybe-propagated-inputs): New procedure. --- guix/import/utils.scm | 36 ++++++++++++++++++++++-------------- 1 file changed, 22 insertions(+), 14 deletions(-) (limited to 'guix') diff --git a/guix/import/utils.scm b/guix/import/utils.scm index 6b85b3aa1d..c2db5a323b 100644 --- a/guix/import/utils.scm +++ b/guix/import/utils.scm @@ -7,6 +7,7 @@ ;;; Copyright © 2019 Robert Vollmert ;;; Copyright © 2020 Helio Machado <0x2b3bfa0+guix@googlemail.com> ;;; Copyright © 2020 Martin Becze +;;; Copyright © 2021 Maxim Cournoyer ;;; ;;; This file is part of GNU Guix. ;;; @@ -57,6 +58,7 @@ (define-module (guix import utils) package-names->package-inputs maybe-inputs maybe-native-inputs + maybe-propagated-inputs package->definition spdx-string->license @@ -247,23 +249,29 @@ (define (make-input input version) (input (make-input input #f))) names)) -(define* (maybe-inputs package-names #:optional (output #f)) +(define* (maybe-inputs package-names #:optional (output #f) + #:key (type #f)) "Given a list of PACKAGE-NAMES, tries to generate the 'inputs' field of a -package definition." - (match (package-names->package-inputs package-names output) - (() - '()) - ((package-inputs ...) - `((inputs (,'quasiquote ,package-inputs)))))) +package definition. TYPE can be used to specify the type of the inputs; +either the 'native or 'propagated symbols are accepted. Left unspecified, the +snippet generated is for regular inputs." + (let ((field-name (match type + ('native 'native-inputs) + ('propagated 'propagated-inputs) + (_ 'inputs)))) + (match (package-names->package-inputs package-names output) + (() + '()) + ((package-inputs ...) + `((,field-name (,'quasiquote ,package-inputs))))))) (define* (maybe-native-inputs package-names #:optional (output #f)) - "Given a list of PACKAGE-NAMES, tries to generate the 'inputs' field of a -package definition." - (match (package-names->package-inputs package-names output) - (() - '()) - ((package-inputs ...) - `((native-inputs (,'quasiquote ,package-inputs)))))) + "Same as MAYBE-INPUTS, but for native inputs." + (maybe-inputs package-names output #:type 'native)) + +(define* (maybe-propagated-inputs package-names #:optional (output #f)) + "Same as MAYBE-INPUTS, but for propagated inputs." + (maybe-inputs package-names output #:type 'propagated)) (define* (package->definition guix-package #:optional append-version?/string) "If APPEND-VERSION?/STRING is #t, append the package's major+minor -- cgit v1.2.3 From 6aee902eaf9e38d5f41f568ef787fa0cc5203318 Mon Sep 17 00:00:00 2001 From: Maxim Cournoyer Date: Sun, 21 Mar 2021 23:53:21 -0400 Subject: import: go: Improve synopsis and description parsing. * guix/import/go.scm (%strict-tokenizer?): Set parameter to #t. (go-path-escape): Redefine to prevent inlining. (http-get*): Replace by ... (http-fetch*): this ... (json-fetch*): New procedure. (go.pkg.dev-info): Use http-fetch*. (go-package-licenses): Rewrite in terms of go.pkg.dev-info. (go-package-description): Likewise. (go-package-synopsis): Likewise. (fetch-go.mod): Use the memoized http-fetch*. (parse-go.mod): Adjust to receive content as a string. (fetch-module-meta-data): Adjust to use http-fetch*. (go-module->guix-package): Adjust to the modified fetch-go.mod return value. [inputs]: Use propagated inputs, which is the most common situations for Go libraries. [description]: Beautify description. [licenses]: Do no check for #f. The result of the license parsing is always a list. * tests/go.scm: Adjust following above changes. --- guix/import/go.scm | 213 +++++++++++++++++++++++++++++++------------------- guix/import/utils.scm | 4 +- tests/go.scm | 75 +++++++++--------- 3 files changed, 170 insertions(+), 122 deletions(-) (limited to 'guix') diff --git a/guix/import/go.scm b/guix/import/go.scm index 6c0231e113..8c8f20b109 100644 --- a/guix/import/go.scm +++ b/guix/import/go.scm @@ -33,7 +33,7 @@ (define-module (guix import go) #:use-module (guix http-client) #:use-module ((guix licenses) #:prefix license:) #:use-module (guix memoization) - #:autoload (htmlprag) (html->sxml) ;from Guile-Lib + #:use-module (htmlprag) ;from Guile-Lib #:autoload (guix git) (update-cached-checkout) #:autoload (gcrypt hash) (open-hash-port hash-algorithm sha256) #:autoload (guix serialization) (write-file) @@ -43,20 +43,28 @@ (define-module (guix import go) #:use-module (ice-9 rdelim) #:use-module (ice-9 receive) #:use-module (ice-9 regex) + #:use-module (ice-9 textual-ports) #:use-module ((rnrs io ports) #:select (call-with-port)) #:use-module (srfi srfi-1) + #:use-module (srfi srfi-2) #:use-module (srfi srfi-9) #:use-module (srfi srfi-11) #:use-module (srfi srfi-26) - #:use-module (sxml xpath) + #:use-module (sxml match) + #:use-module ((sxml xpath) #:renamer (lambda (s) + (if (eq? 'filter s) + 'xfilter + s))) #:use-module (web client) #:use-module (web response) #:use-module (web uri) - #:export (go-path-escape - go-module->guix-package + #:export (go-module->guix-package go-module-recursive-import)) +;;; Parameterize htmlprag to parse valid HTML more reliably. +(%strict-tokenizer? #t) + ;;; Commentary: ;;; ;;; (guix import go) attempts to make it easier to create Guix package @@ -90,6 +98,14 @@ (define-module (guix import go) ;;; Code: +(define http-fetch* + ;; Like http-fetch, but memoized and returning the body as a string. + (memoize (lambda args + (call-with-port (apply http-fetch args) get-string-all)))) + +(define json-fetch* + (memoize json-fetch)) + (define (go-path-escape path) "Escape a module path by replacing every uppercase letter with an exclamation mark followed with its lowercase equivalent, as per the module @@ -99,54 +115,73 @@ (define (escape occurrence) (string-append "!" (string-downcase (match:substring occurrence)))) (regexp-substitute/global #f "[A-Z]" path 'pre escape 'post)) +;; Prevent inlining of this procedure, which is accessed by unit tests. +(set! go-path-escape go-path-escape) + +(define (go.pkg.dev-info name) + (http-fetch* (string-append "https://pkg.go.dev/" name))) + (define (go-module-latest-version goproxy-url module-path) "Fetch the version number of the latest version for MODULE-PATH from the given GOPROXY-URL server." - (assoc-ref (json-fetch (format #f "~a/~a/@latest" goproxy-url - (go-path-escape module-path))) + (assoc-ref (json-fetch* (format #f "~a/~a/@latest" goproxy-url + (go-path-escape module-path))) "Version")) - (define (go-package-licenses name) "Retrieve the list of licenses that apply to NAME, a Go package or module -name (e.g. \"github.com/golang/protobuf/proto\"). The data is scraped from -the https://pkg.go.dev/ web site." - (let*-values (((url) (string-append "https://pkg.go.dev/" name - "?tab=licenses")) - ((response body) (http-get url)) - ;; Extract the text contained in a h2 child node of any - ;; element marked with a "License" class attribute. - ((select) (sxpath `(// (* (@ (equal? (class "License")))) - h2 // *text*)))) - (and (eq? (response-code response) 200) - (match (select (html->sxml body)) - (() #f) ;nothing selected - (licenses licenses))))) - -(define (go.pkg.dev-info name) - (http-get (string-append "https://pkg.go.dev/" name))) -(define go.pkg.dev-info* - (memoize go.pkg.dev-info)) +name (e.g. \"github.com/golang/protobuf/proto\")." + (let* ((body (go.pkg.dev-info (string-append name "?tab=licenses"))) + ;; Extract the text contained in a h2 child node of any + ;; element marked with a "License" class attribute. + (select (sxpath `(// (* (@ (equal? (class "License")))) + h2 // *text*)))) + (select (html->sxml body)))) + +(define (sxml->texi sxml-node) + "A very basic SXML to Texinfo converter which attempts to preserve HTML +formatting and links as text." + (sxml-match sxml-node + ((strong ,text) + (format #f "@strong{~a}" text)) + ((a (@ (href ,url)) ,text) + (format #f "@url{~a,~a}" url text)) + ((code ,text) + (format #f "@code{~a}" text)) + (,something-else something-else))) (define (go-package-description name) "Retrieve a short description for NAME, a Go package name, -e.g. \"google.golang.org/protobuf/proto\". The data is scraped from the -https://pkg.go.dev/ web site." - (let*-values (((response body) (go.pkg.dev-info* name)) - ;; Extract the text contained in a h2 child node of any - ;; element marked with a "License" class attribute. - ((select) (sxpath - `(// (section - (@ (equal? (class "Documentation-overview")))) - (p 1))))) - (and (eq? (response-code response) 200) - (match (select (html->sxml body)) - (() #f) ;nothing selected - (((p . strings)) - ;; The paragraph text is returned as a list of strings embedding - ;; newline characters. Join them and strip the newline - ;; characters. - (string-delete #\newline (string-join strings))))))) +e.g. \"google.golang.org/protobuf/proto\"." + (let* ((body (go.pkg.dev-info name)) + (sxml (html->sxml body)) + (overview ((sxpath + `(// + (* (@ (equal? (class "Documentation-overview")))) + (p 1))) sxml)) + ;; Sometimes, the first paragraph just contains images/links that + ;; has only "\n" for text. The following filter is designed to + ;; omit it. + (contains-text? (lambda (node) + (remove string-null? + (map string-trim-both + (filter (node-typeof? '*text*) + (cdr node)))))) + (select-content (sxpath + `(// + (* (@ (equal? (class "UnitReadme-content")))) + div // p ,(xfilter contains-text?)))) + ;; Fall-back to use content; this is less desirable as it is more + ;; verbose, but not every page has an overview. + (description (if (not (null? overview)) + overview + (select-content sxml))) + (description* (and (not (null? description)) + (first description)))) + (match description* + (() #f) ;nothing selected + ((p elements ...) + (apply string-append (filter string? (map sxml->texi elements))))))) (define (go-package-synopsis module-name) "Retrieve a short synopsis for a Go module named MODULE-NAME, @@ -154,17 +189,17 @@ (define (go-package-synopsis module-name) the https://pkg.go.dev/ web site." ;; Note: Only the *module* (rather than package) page has the README title ;; used as a synopsis on the https://pkg.go.dev web site. - (let*-values (((response body) (go.pkg.dev-info* module-name)) - ;; Extract the text contained in a h2 child node of any - ;; element marked with a "License" class attribute. - ((select) (sxpath - `(// (div (@ (equal? (class "UnitReadme-content")))) - // h3 *text*)))) - (and (eq? (response-code response) 200) - (match (select (html->sxml body)) - (() #f) ;nothing selected - ((title more ...) ;title is the first string of the list - (string-trim-both title)))))) + (let* ((url (string-append "https://pkg.go.dev/" module-name)) + (body (http-fetch* url)) + ;; Extract the text contained in a h2 child node of any + ;; element marked with a "License" class attribute. + (select-title (sxpath + `(// (div (@ (equal? (class "UnitReadme-content")))) + // h3 *text*)))) + (match (select-title (html->sxml body)) + (() #f) ;nothing selected + ((title more ...) ;title is the first string of the list + (string-trim-both title))))) (define (list->licenses licenses) "Given a list of LICENSES mostly following the SPDX conventions, return the @@ -189,13 +224,13 @@ (define (list->licenses licenses) 'unknown-license!))) licenses)) -(define (fetch-go.mod goproxy-url module-path version) - "Fetches go.mod from the given GOPROXY-URL server for the given MODULE-PATH -and VERSION." - (let ((url (format #f "~a/~a/@v/~a.mod" goproxy-url +(define (fetch-go.mod goproxy module-path version) + "Fetch go.mod from the given GOPROXY server for the given MODULE-PATH +and VERSION and return an input port." + (let ((url (format #f "~a/~a/@v/~a.mod" goproxy (go-path-escape module-path) (go-path-escape version)))) - (http-fetch url))) + (http-fetch* url))) (define %go.mod-require-directive-rx ;; A line in a require directive is composed of a module path and @@ -216,9 +251,8 @@ (define %go.mod-replace-directive-rx "[[:blank:]]+" "=>" "[[:blank:]]+" "([^[:blank:]]+)([[:blank:]]+([^[:blank:]]+))?"))) -(define (parse-go.mod port) - "Parse the go.mod file accessible via the input PORT, returning a list of -requirements." +(define (parse-go.mod content) + "Parse the go.mod file CONTENT, returning a list of requirements." (define-record-type (make-results requirements replacements) results? @@ -229,7 +263,7 @@ (define-record-type (define (toplevel results) "Main parser, RESULTS is a pair of alist serving as accumulator for all encountered requirements and replacements." - (let ((line (read-line port))) + (let ((line (read-line))) (cond ((eof-object? line) ;; parsing ended, give back the result @@ -255,7 +289,7 @@ (define (toplevel results) (toplevel results))))) (define (in-require results) - (let ((line (read-line port))) + (let ((line (read-line))) (cond ((eof-object? line) ;; this should never happen here but we ignore silently @@ -267,7 +301,7 @@ (define (in-require results) (in-require (require-directive results line)))))) (define (in-replace results) - (let ((line (read-line port))) + (let ((line (read-line))) (cond ((eof-object? line) ;; this should never happen here but we ignore silently @@ -306,7 +340,9 @@ (define (require-directive results line) (($ requirements replaced) (make-results (alist-cons module-path version requirements) replaced))))) - (let ((results (toplevel (make-results '() '())))) + (let ((results (with-input-from-string content + (lambda _ + (toplevel (make-results '() '())))))) (match results (($ requirements replaced) ;; At last we remove replaced modules from the requirements list @@ -325,8 +361,10 @@ (define-record-type (url-prefix vcs-url-prefix) (root-regex vcs-root-regex) (type vcs-type)) + (define (make-vcs prefix regexp type) - (%make-vcs prefix (make-regexp regexp) type)) + (%make-vcs prefix (make-regexp regexp) type)) + (define known-vcs ;; See the following URL for the official Go equivalent: ;; https://github.com/golang/go/blob/846dce9d05f19a1f53465e62a304dea21b99f910/src/cmd/go/internal/vcs/vcs.go#L1026-L1087 @@ -387,6 +425,14 @@ (define (go-module->guix-package-name module-path) "/" "-") "_" "-")))) +(define (strip-.git-suffix/maybe repo-url) + "Strip a repository URL '.git' suffix from REPO-URL if hosted at GitHub." + (match repo-url + ((and (? (cut string-prefix? "https://github.com" <>)) + (? (cut string-suffix? ".git" <>))) + (string-drop-right repo-url 4)) + (_ repo-url))) + (define-record-type (make-module-meta import-prefix vcs repo-root) module-meta? @@ -399,21 +445,22 @@ (define (fetch-module-meta-data module-path) because goproxy servers don't currently provide all the information needed to build a package." ;; - (let* ((port (http-fetch (format #f "https://~a?go-get=1" module-path))) + (let* ((meta-data (http-fetch* (format #f "https://~a?go-get=1" module-path))) (select (sxpath `(// head (meta (@ (equal? (name "go-import")))) // content)))) - (match (select (call-with-port port html->sxml)) - (() #f) ;nothing selected + (match (select (html->sxml meta-data)) + (() #f) ;nothing selected (((content content-text)) (match (string-split content-text #\space) ((root-path vcs repo-url) - (make-module-meta root-path (string->symbol vcs) repo-url))))))) + (make-module-meta root-path (string->symbol vcs) + (strip-.git-suffix/maybe repo-url)))))))) -(define (module-meta-data-repo-url meta-data goproxy-url) +(define (module-meta-data-repo-url meta-data goproxy) "Return the URL where the fetcher which will be used can download the source." (if (member (module-meta-vcs meta-data) '(fossil mod)) - goproxy-url + goproxy (module-meta-repo-root meta-data))) ;; XXX: Copied from (guix scripts hash). @@ -466,6 +513,9 @@ (define (vcs->origin vcs-type vcs-repo-url version) (method git-fetch) (uri (git-reference (url ,vcs-repo-url) + ;; This is done because the version field of the package, + ;; which the generated quoted expression refers to, has been + ;; stripped of any 'v' prefixed. (commit ,(if (and plain-version? v-prefixed?) '(string-append "v" version) '(go-version->git-ref version))))) @@ -505,8 +555,8 @@ (define (vcs->origin vcs-type vcs-repo-url version) (define* (go-module->guix-package module-path #:key (goproxy-url "https://proxy.golang.org")) (let* ((latest-version (go-module-latest-version goproxy-url module-path)) - (port (fetch-go.mod goproxy-url module-path latest-version)) - (dependencies (map car (call-with-port port parse-go.mod))) + (content (fetch-go.mod goproxy-url module-path latest-version)) + (dependencies (map car (parse-go.mod content))) (guix-name (go-module->guix-package-name module-path)) (root-module-path (module-path->repository-root module-path)) ;; The VCS type and URL are not included in goproxy information. For @@ -527,14 +577,17 @@ (define* (go-module->guix-package module-path #:key (build-system go-build-system) (arguments '(#:import-path ,root-module-path)) - ,@(maybe-inputs (map go-module->guix-package-name dependencies)) + ,@(maybe-propagated-inputs + (map go-module->guix-package-name dependencies)) (home-page ,(format #f "https://~a" root-module-path)) (synopsis ,synopsis) - (description ,description) - (license ,(match (and=> licenses list->licenses) - ((license) license) - ((licenses ...) `(list ,@licenses)) - (x x)))) + (description ,(and=> description beautify-description)) + (license ,(match (list->licenses licenses) + (() #f) ;unknown license + ((license) ;a single license + license) + ((license ...) ;a list of licenses + `(list ,@license))))) dependencies))) (define go-module->guix-package* (memoize go-module->guix-package)) diff --git a/guix/import/utils.scm b/guix/import/utils.scm index c2db5a323b..adf90f84d7 100644 --- a/guix/import/utils.scm +++ b/guix/import/utils.scm @@ -446,8 +446,8 @@ (define* (recursive-import package-name "Return a list of package expressions for PACKAGE-NAME and all its dependencies, sorted in topological order. For each package, call (REPO->GUIX-PACKAGE NAME :KEYS version repo), which should return a -package expression and a list of dependencies; call (GUIX-NAME NAME) to -obtain the Guix package name corresponding to the upstream name." +package expression and a list of dependencies; call (GUIX-NAME PACKAGE-NAME) +to obtain the Guix package name corresponding to the upstream name." (define-record-type (make-node name version package dependencies) node? diff --git a/tests/go.scm b/tests/go.scm index 6ab99f508a..fa8fa7a2a6 100644 --- a/tests/go.scm +++ b/tests/go.scm @@ -180,13 +180,9 @@ (define fixtures-go-check-test (define (testing-parse-mod name expected input) (define (inf? p1 p2) (stringguix-package" '(package - (name "go-github-com-go-check-check") - (version "0.0.0-20201130134442-10cb98267c6c") - (source - (origin - (method git-fetch) - (uri (git-reference - (url "https://github.com/go-check/check.git") - (commit (go-version->git-ref version)))) - (file-name (git-file-name name version)) - (sha256 - (base32 - "0sjjj9z1dhilhpc8pq4154czrb79z9cm044jvn75kxcjv6v5l2m5")))) - (build-system go-build-system) - (arguments - (quote (#:import-path "github.com/go-check/check"))) - (inputs - (quasiquote (("go-github-com-kr-pretty" - (unquote go-github-com-kr-pretty))))) - (home-page "https://github.com/go-check/check") - (synopsis "Instructions") - (description #f) - (license license:bsd-2)) + (name "go-github-com-go-check-check") + (version "0.0.0-20201130134442-10cb98267c6c") + (source + (origin + (method git-fetch) + (uri (git-reference + (url "https://github.com/go-check/check") + (commit (go-version->git-ref version)))) + (file-name (git-file-name name version)) + (sha256 + (base32 + "0sjjj9z1dhilhpc8pq4154czrb79z9cm044jvn75kxcjv6v5l2m5")))) + (build-system go-build-system) + (arguments + '(#:import-path "github.com/go-check/check")) + (propagated-inputs + `(("go-github-com-kr-pretty" ,go-github-com-kr-pretty))) + (home-page "https://github.com/go-check/check") + (synopsis "Instructions") + (description "Package check is a rich testing extension for Go's testing \ +package.") + (license license:bsd-2)) ;; Replace network resources with sample data. (call-with-temporary-directory (lambda (checkout) (mock ((web client) http-get (mock-http-get fixtures-go-check-test)) - (mock ((guix http-client) http-fetch - (mock-http-fetch fixtures-go-check-test)) - (mock ((guix git) update-cached-checkout - (lambda* (url #:key ref) - ;; Return an empty directory and its hash. - (values checkout - (nix-base32-string->bytevector - "0sjjj9z1dhilhpc8pq4154czrb79z9cm044jvn75kxcjv6v5l2m5") - #f))) - (go-module->guix-package "github.com/go-check/check"))))))) + (mock ((guix http-client) http-fetch + (mock-http-fetch fixtures-go-check-test)) + (mock ((guix git) update-cached-checkout + (lambda* (url #:key ref) + ;; Return an empty directory and its hash. + (values checkout + (nix-base32-string->bytevector + "0sjjj9z1dhilhpc8pq4154czrb79z9cm044jvn75kxcjv6v5l2m5") + #f))) + (go-module->guix-package "github.com/go-check/check"))))))) (test-end "go") - -- cgit v1.2.3 From a8b927a562aad7e5f77d0e4db2d9cee3434446d2 Mon Sep 17 00:00:00 2001 From: Maxim Cournoyer Date: Fri, 19 Mar 2021 16:41:51 -0400 Subject: import: go: Add an option to use pinned versions. The ability to pin versions is handy when having to deal to packages that bootstrap themselves through a chain of former versions. Not using pinned versions in these case could introduce dependency cycles. * guix/build-system/go.scm (guix) (%go-version-rx): Rename to... (%go-pseudo-version-rx): ... this. Simplify the regular expression, which in turns makes it more robust. * guix/build-system/go.scm (go-version->git-ref): Adjust following the above rename. (go-pseudo-version?): New predicate. (go-module-latest-version): Rename to ... (go-module-version-string): ... this. Rename goproxy-url argument to just goproxy. Add a VERSION keyword argument, update docstring and adjust to have it used. (go-module-available-versions): New procedure. (%go.mod-require-directive-rx): Document regexp. (parse-go.mod): Harmonize the way dependencies are recorded to a list of lists rather than a list of pairs, as done for other importers. Rewrite to directly pass multiple values rather than a record object. Filter the replaced modules in a functional style. (go-module->guix-package): Add docstring. [version, pin-versions?]: New arguments. Rename the GOPROXY-URL argument to GOPROXY. Adjust to the new returned value of fetch-go.mod, which is a string. Fail when the provided version doesn't exist. Return a list dependencies and their versions when in pinned versions mode, else just the dependencies. (go-module-recursive-import)[version, pin-versions?]: New arguments. Honor the new arguments and guard against network errors. * guix/scripts/import/go.scm (%default-options): Register a default value for the goproxy argument. (show-help): Document that a version can be specified. Remove the --version argument and add a --pin-versions argument. (%options)[version]: Remove option. [pin-versions]: Add option. (guix-import-go): Adjust so the version provided from the module name is honored, along the new pin-versions? argument. * tests/go.scm: Adjust and add new tests. --- guix/build-system/go.scm | 24 +++-- guix/import/go.scm | 239 +++++++++++++++++++++++++++------------------ guix/scripts/import/go.scm | 70 +++++++------ tests/go.scm | 64 ++++++------ 4 files changed, 234 insertions(+), 163 deletions(-) (limited to 'guix') diff --git a/guix/build-system/go.scm b/guix/build-system/go.scm index 0e2c1cd2ee..8f55796e86 100644 --- a/guix/build-system/go.scm +++ b/guix/build-system/go.scm @@ -31,6 +31,7 @@ (define-module (guix build-system go) go-build go-build-system + go-pseudo-version? go-version->git-ref)) ;; Commentary: @@ -40,17 +41,19 @@ (define-module (guix build-system go) ;; ;; Code: -(define %go-version-rx +(define %go-pseudo-version-rx + ;; Match only the end of the version string; this is so that matching the + ;; more complex leading semantic version pattern is not required. (make-regexp (string-append - "(v?[0-9]\\.[0-9]\\.[0-9])" ;"v" prefix can be omitted in version prefix - "(-|-pre\\.0\\.|-0\\.)" ;separator - "([0-9]{14})-" ;timestamp - "([0-9A-Fa-f]{12})"))) ;commit hash + "([0-9]{14}-)" ;timestamp + "([0-9A-Fa-f]{12})" ;commit hash + "(\\+incompatible)?$"))) ;optional +incompatible tag (define (go-version->git-ref version) "Parse VERSION, a \"pseudo-version\" as defined at , and extract the commit hash from -it, defaulting to full VERSION if a pseudo-version pattern is not recognized." +it, defaulting to full VERSION (stripped from the \"+incompatible\" suffix if +present) if a pseudo-version pattern is not recognized." ;; A module version like v1.2.3 is introduced by tagging a revision in the ;; underlying source repository. Untagged revisions can be referred to ;; using a "pseudo-version" like v0.0.0-yyyymmddhhmmss-abcdefabcdef, where @@ -65,11 +68,16 @@ (define (go-version->git-ref version) (if (string-suffix? "+incompatible" version) (string-drop-right version 13) version)) - (match (regexp-exec %go-version-rx version))) + (match (regexp-exec %go-pseudo-version-rx version))) (if match - (match:substring match 4) + (match:substring match 2) version))) +(define (go-pseudo-version? version) + "True if VERSION is a Go pseudo-version, i.e., a version string made of a +commit hash and its date rather than a proper release tag." + (regexp-exec %go-pseudo-version-rx version)) + (define %go-build-system-modules ;; Build-side modules imported and used by default. `((guix build go-build-system) diff --git a/guix/import/go.scm b/guix/import/go.scm index 8c8f20b109..ca2b9c6fa0 100644 --- a/guix/import/go.scm +++ b/guix/import/go.scm @@ -50,6 +50,7 @@ (define-module (guix import go) #:use-module (srfi srfi-9) #:use-module (srfi srfi-11) #:use-module (srfi srfi-26) + #:use-module (srfi srfi-34) #:use-module (sxml match) #:use-module ((sxml xpath) #:renamer (lambda (s) (if (eq? 'filter s) @@ -92,9 +93,7 @@ (define-module (guix import go) ;;; assumption that there will be no collision. ;;; TODO list -;;; - get correct hash in vcs->origin -;;; - print partial result during recursive imports (need to catch -;;; exceptions) +;;; - get correct hash in vcs->origin for Mercurial and Subversion ;;; Code: @@ -121,12 +120,26 @@ (define (escape occurrence) (define (go.pkg.dev-info name) (http-fetch* (string-append "https://pkg.go.dev/" name))) -(define (go-module-latest-version goproxy-url module-path) - "Fetch the version number of the latest version for MODULE-PATH from the -given GOPROXY-URL server." - (assoc-ref (json-fetch* (format #f "~a/~a/@latest" goproxy-url - (go-path-escape module-path))) - "Version")) +(define* (go-module-version-string goproxy name #:key version) + "Fetch the version string of the latest version for NAME from the given +GOPROXY server, or for VERSION when specified." + (let ((file (if version + (string-append "@v/" version ".info") + "@latest"))) + (assoc-ref (json-fetch* (format #f "~a/~a/~a" + goproxy (go-path-escape name) file)) + "Version"))) + +(define* (go-module-available-versions goproxy name) + "Retrieve the available versions for a given module from the module proxy. +Versions are being returned **unordered** and may contain different versioning +styles for the same package." + (let* ((url (string-append goproxy "/" (go-path-escape name) "/@v/list")) + (body (http-fetch* url)) + (versions (remove string-null? (string-split body #\newline)))) + (if (null? versions) + (list (go-module-version-string goproxy name)) ;latest version + versions))) (define (go-package-licenses name) "Retrieve the list of licenses that apply to NAME, a Go package or module @@ -238,119 +251,119 @@ (define %go.mod-require-directive-rx ;; the end. (make-regexp (string-append - "^[[:blank:]]*" - "([^[:blank:]]+)[[:blank:]]+([^[:blank:]]+)" - "([[:blank:]]+//.*)?"))) + "^[[:blank:]]*([^[:blank:]]+)[[:blank:]]+" ;the module path + "([^[:blank:]]+)" ;the version + "([[:blank:]]+//.*)?"))) ;an optional comment (define %go.mod-replace-directive-rx ;; ReplaceSpec = ModulePath [ Version ] "=>" FilePath newline ;; | ModulePath [ Version ] "=>" ModulePath Version newline . (make-regexp (string-append - "([^[:blank:]]+)([[:blank:]]+([^[:blank:]]+))?" - "[[:blank:]]+" "=>" "[[:blank:]]+" - "([^[:blank:]]+)([[:blank:]]+([^[:blank:]]+))?"))) + "([^[:blank:]]+)" ;the module path + "([[:blank:]]+([^[:blank:]]+))?" ;optional version + "[[:blank:]]+=>[[:blank:]]+" + "([^[:blank:]]+)" ;the file or module path + "([[:blank:]]+([^[:blank:]]+))?"))) ;the version (if a module path) (define (parse-go.mod content) "Parse the go.mod file CONTENT, returning a list of requirements." - (define-record-type - (make-results requirements replacements) - results? - (requirements results-requirements) - (replacements results-replacements)) ;; We parse only a subset of https://golang.org/ref/mod#go-mod-file-grammar ;; which we think necessary for our use case. - (define (toplevel results) - "Main parser, RESULTS is a pair of alist serving as accumulator for - all encountered requirements and replacements." + (define (toplevel requirements replaced) + "This is the main parser. The results are accumulated in THE REQUIREMENTS +and REPLACED lists." (let ((line (read-line))) (cond ((eof-object? line) ;; parsing ended, give back the result - results) + (values requirements replaced)) ((string=? line "require (") ;; a require block begins, delegate parsing to IN-REQUIRE - (in-require results)) + (in-require requirements replaced)) ((string=? line "replace (") ;; a replace block begins, delegate parsing to IN-REPLACE - (in-replace results)) + (in-replace requirements replaced)) ((string-prefix? "require " line) - ;; a standalone require directive - (let* ((stripped-line (string-drop line 8)) - (new-results (require-directive results stripped-line))) - (toplevel new-results))) + ;; a require directive by itself + (let* ((stripped-line (string-drop line 8))) + (call-with-values + (lambda () + (require-directive requirements replaced stripped-line)) + toplevel))) ((string-prefix? "replace " line) - ;; a standalone replace directive - (let* ((stripped-line (string-drop line 8)) - (new-results (replace-directive results stripped-line))) - (toplevel new-results))) + ;; a replace directive by itself + (let* ((stripped-line (string-drop line 8))) + (call-with-values + (lambda () + (replace-directive requirements replaced stripped-line)) + toplevel))) (#t ;; unrecognised line, ignore silently - (toplevel results))))) + (toplevel requirements replaced))))) - (define (in-require results) + (define (in-require requirements replaced) (let ((line (read-line))) (cond ((eof-object? line) ;; this should never happen here but we ignore silently - results) + (values requirements replaced)) ((string=? line ")") ;; end of block, coming back to toplevel - (toplevel results)) + (toplevel requirements replaced)) (#t - (in-require (require-directive results line)))))) + (call-with-values (lambda () + (require-directive requirements replaced line)) + in-require))))) - (define (in-replace results) + (define (in-replace requirements replaced) (let ((line (read-line))) (cond ((eof-object? line) ;; this should never happen here but we ignore silently - results) + (values requirements replaced)) ((string=? line ")") ;; end of block, coming back to toplevel - (toplevel results)) + (toplevel requirements replaced)) (#t - (in-replace (replace-directive results line)))))) - - (define (replace-directive results line) - "Extract replaced modules and new requirements from replace directive - in LINE and add to RESULTS." - (match results - (($ requirements replaced) - (let* ((rx-match (regexp-exec %go.mod-replace-directive-rx line)) - (module-path (match:substring rx-match 1)) - (version (match:substring rx-match 3)) - (new-module-path (match:substring rx-match 4)) - (new-version (match:substring rx-match 6)) - (new-replaced (alist-cons module-path version replaced)) - (new-requirements - (if (string-match "^\\.?\\./" new-module-path) - requirements - (alist-cons new-module-path new-version requirements)))) - (make-results new-requirements new-replaced))))) - (define (require-directive results line) - "Extract requirement from LINE and add it to RESULTS." + (call-with-values (lambda () + (replace-directive requirements replaced line)) + in-replace))))) + + (define (replace-directive requirements replaced line) + "Extract replaced modules and new requirements from the replace directive +in LINE and add them to the REQUIREMENTS and REPLACED lists." + (let* ((rx-match (regexp-exec %go.mod-replace-directive-rx line)) + (module-path (match:substring rx-match 1)) + (version (match:substring rx-match 3)) + (new-module-path (match:substring rx-match 4)) + (new-version (match:substring rx-match 6)) + (new-replaced (cons (list module-path version) replaced)) + (new-requirements + (if (string-match "^\\.?\\./" new-module-path) + requirements + (cons (list new-module-path new-version) requirements)))) + (values new-requirements new-replaced))) + + (define (require-directive requirements replaced line) + "Extract requirement from LINE and augment the REQUIREMENTS and REPLACED +lists." (let* ((rx-match (regexp-exec %go.mod-require-directive-rx line)) (module-path (match:substring rx-match 1)) - ;; we saw double-quoted string in the wild without escape - ;; sequences so we just trim the quotes + ;; Double-quoted strings were seen in the wild without escape + ;; sequences; trim the quotes to be on the safe side. (module-path (string-trim-both module-path #\")) (version (match:substring rx-match 2))) - (match results - (($ requirements replaced) - (make-results (alist-cons module-path version requirements) replaced))))) - - (let ((results (with-input-from-string content - (lambda _ - (toplevel (make-results '() '())))))) - (match results - (($ requirements replaced) - ;; At last we remove replaced modules from the requirements list - (fold - (lambda (replacedelem requirements) - (alist-delete! (car replacedelem) requirements)) - requirements - replaced))))) + (values (cons (list module-path version) requirements) replaced))) + + (with-input-from-string content + (lambda () + (receive (requirements replaced) + (toplevel '() '()) + ;; At last remove the replaced modules from the requirements list. + (remove (lambda (r) + (assoc (car r) replaced)) + requirements))))) ;; Prevent inlining of this procedure, which is accessed by unit tests. (set! parse-go.mod parse-go.mod) @@ -553,17 +566,32 @@ (define (vcs->origin vcs-type vcs-repo-url version) vcs-type vcs-repo-url))))) (define* (go-module->guix-package module-path #:key - (goproxy-url "https://proxy.golang.org")) - (let* ((latest-version (go-module-latest-version goproxy-url module-path)) - (content (fetch-go.mod goproxy-url module-path latest-version)) - (dependencies (map car (parse-go.mod content))) + (goproxy "https://proxy.golang.org") + version + pin-versions?) + "Return the package S-expression corresponding to MODULE-PATH at VERSION, a Go package. +The meta-data is fetched from the GOPROXY server and https://pkg.go.dev/. +When VERSION is unspecified, the latest version available is used." + (let* ((available-versions (go-module-available-versions goproxy module-path)) + (version* (or version + (go-module-version-string goproxy module-path))) ;latest + ;; Pseudo-versions do not appear in the versions list; skip the + ;; following check. + (_ (unless (or (go-pseudo-version? version*) + (member version* available-versions)) + (error (format #f "error: version ~s is not available +hint: use one of the following available versions ~a\n" + version* available-versions)))) + (content (fetch-go.mod goproxy module-path version*)) + (dependencies+versions (parse-go.mod content)) + (dependencies (map car dependencies+versions)) (guix-name (go-module->guix-package-name module-path)) (root-module-path (module-path->repository-root module-path)) ;; The VCS type and URL are not included in goproxy information. For ;; this we need to fetch it from the official module page. (meta-data (fetch-module-meta-data root-module-path)) (vcs-type (module-meta-vcs meta-data)) - (vcs-repo-url (module-meta-data-repo-url meta-data goproxy-url)) + (vcs-repo-url (module-meta-data-repo-url meta-data goproxy)) (synopsis (go-package-synopsis root-module-path)) (description (go-package-description module-path)) (licenses (go-package-licenses module-path))) @@ -571,14 +599,14 @@ (define* (go-module->guix-package module-path #:key `(package (name ,guix-name) ;; Elide the "v" prefix Go uses - (version ,(string-trim latest-version #\v)) + (version ,(string-trim version* #\v)) (source - ,(vcs->origin vcs-type vcs-repo-url latest-version)) + ,(vcs->origin vcs-type vcs-repo-url version*)) (build-system go-build-system) (arguments '(#:import-path ,root-module-path)) - ,@(maybe-propagated-inputs - (map go-module->guix-package-name dependencies)) + ,@(maybe-propagated-inputs (map go-module->guix-package-name + dependencies)) (home-page ,(format #f "https://~a" root-module-path)) (synopsis ,synopsis) (description ,(and=> description beautify-description)) @@ -588,16 +616,37 @@ (define* (go-module->guix-package module-path #:key license) ((license ...) ;a list of licenses `(list ,@license))))) - dependencies))) + (if pin-versions? + dependencies+versions + dependencies)))) (define go-module->guix-package* (memoize go-module->guix-package)) (define* (go-module-recursive-import package-name - #:key (goproxy-url "https://proxy.golang.org")) + #:key (goproxy "https://proxy.golang.org") + version + pin-versions?) + (recursive-import package-name - #:repo->guix-package (lambda* (name . _) - (go-module->guix-package* - name - #:goproxy-url goproxy-url)) - #:guix-name go-module->guix-package-name)) + #:repo->guix-package + (lambda* (name #:key version repo) + ;; Disable output buffering so that the following warning gets printed + ;; consistently. + (setvbuf (current-error-port) 'none) + (guard (c ((http-get-error? c) + (warning (G_ "Failed to import package ~s. +reason: ~s could not be fetched: HTTP error ~a (~s). +This package and its dependencies won't be imported.~%") + name + (uri->string (http-get-error-uri c)) + (http-get-error-code c) + (http-get-error-reason c)) + (values '() '()))) + (receive (package-sexp dependencies) + (go-module->guix-package* name #:goproxy goproxy + #:version version + #:pin-versions? pin-versions?) + (values package-sexp dependencies)))) + #:guix-name go-module->guix-package-name + #:version version)) diff --git a/guix/scripts/import/go.scm b/guix/scripts/import/go.scm index afdba4e8f1..33d2470ce1 100644 --- a/guix/scripts/import/go.scm +++ b/guix/scripts/import/go.scm @@ -1,5 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2020 Katherine Cox-Buday +;;; Copyright © 2020 Katherine Cox-Buday +;;; Copyright © 2021 Maxim Cournoyer ;;; ;;; This file is part of GNU Guix. ;;; @@ -27,28 +28,30 @@ (define-module (guix scripts import go) #:use-module (srfi srfi-37) #:use-module (ice-9 match) #:use-module (ice-9 format) + #:use-module (ice-9 receive) #:export (guix-import-go)) - + ;;; ;;; Command-line options. ;;; (define %default-options - '()) + '((goproxy . "https://proxy.golang.org"))) (define (show-help) - (display (G_ "Usage: guix import go PACKAGE-PATH -Import and convert the Go module for PACKAGE-PATH.\n")) + (display (G_ "Usage: guix import go PACKAGE-PATH[@VERSION] +Import and convert the Go module for PACKAGE-PATH. Optionally, a version +can be specified after the arobas (@) character.\n")) (display (G_ " -h, --help display this help and exit")) (display (G_ " - -V, --version display version information and exit")) - (display (G_ " - -r, --recursive generate package expressions for all Go modules\ - that are not yet in Guix")) + -r, --recursive generate package expressions for all Go modules +that are not yet in Guix")) (display (G_ " -p, --goproxy=GOPROXY specify which goproxy server to use")) + (display (G_ " + --pin-versions use the exact versions of a module's dependencies")) (newline) (show-bug-report-information)) @@ -58,9 +61,6 @@ (define %options (lambda args (show-help) (exit 0))) - (option '(#\V "version") #f #f - (lambda args - (show-version-and-exit "guix import go"))) (option '(#\r "recursive") #f #f (lambda (opt name arg result) (alist-cons 'recursive #t result))) @@ -69,9 +69,12 @@ (define %options (alist-cons 'goproxy (string->symbol arg) (alist-delete 'goproxy result)))) + (option '("pin-versions") #f #f + (lambda (opt name arg result) + (alist-cons 'pin-versions? #t result))) %standard-import-options)) - + ;;; ;;; Entry point. ;;; @@ -93,25 +96,28 @@ (define (parse-options) (_ #f)) (reverse opts)))) (match args - ((module-name) - (if (assoc-ref opts 'recursive) - (map (match-lambda - ((and ('package ('name name) . rest) pkg) - `(define-public ,(string->symbol name) - ,pkg)) - (_ #f)) - (go-module-recursive-import module-name - #:goproxy-url - (or (assoc-ref opts 'goproxy) - "https://proxy.golang.org"))) - (let ((sexp (go-module->guix-package module-name - #:goproxy-url - (or (assoc-ref opts 'goproxy) - "https://proxy.golang.org")))) - (unless sexp - (leave (G_ "failed to download meta-data for module '~a'~%") - module-name)) - sexp))) + ((spec) ;e.g., github.com/golang/protobuf@v1.3.1 + (receive (name version) + (package-name->name+version spec) + (let ((arguments (list name + #:goproxy (assoc-ref opts 'goproxy) + #:version version + #:pin-versions? + (assoc-ref opts 'pin-versions?)))) + (if (assoc-ref opts 'recursive) + ;; Recursive import. + (map (match-lambda + ((and ('package ('name name) . rest) pkg) + `(define-public ,(string->symbol name) + ,pkg)) + (_ #f)) + (apply go-module-recursive-import arguments)) + ;; Single import. + (let ((sexp (apply go-module->guix-package arguments))) + (unless sexp + (leave (G_ "failed to download meta-data for module '~a'~%") + module-name)) + sexp))))) (() (leave (G_ "too few arguments~%"))) ((many ...) diff --git a/tests/go.scm b/tests/go.scm index fa8fa7a2a6..e5780e68b0 100644 --- a/tests/go.scm +++ b/tests/go.scm @@ -19,7 +19,7 @@ ;;; Summary ;; Tests for guix/import/go.scm -(define-module (test-import-go) +(define-module (tests-import-go) #:use-module (guix base32) #:use-module (guix build-system go) #:use-module (guix import go) @@ -147,7 +147,8 @@ (define fixtures-go-check-test ("https://pkg.go.dev/github.com/go-check/check" . ,pkg.go.dev) ("https://pkg.go.dev/github.com/go-check/check?tab=licenses" - . ,pkg.go.dev-licence)))) + . ,pkg.go.dev-licence) + ("https://proxy.golang.org/github.com/go-check/check/@v/list" . "")))) (test-begin "go") @@ -169,6 +170,12 @@ (define fixtures-go-check-test "daa7c04131f5" (go-version->git-ref "v1.2.4-0.20191109021931-daa7c04131f5")) +(test-assert "go-pseudo-version? multi-digit version number" + (go-pseudo-version? "v1.23.1-0.20200526195155-81db48ad09cc")) + +(test-assert "go-pseudo-version? semantic version with rc" + (go-pseudo-version? "v1.4.0-rc.4.0.20200313231945-b860323f09d0")) + ;;; Unit tests for (guix import go) (test-equal "go-path-escape" @@ -185,37 +192,38 @@ (define (inf? p1 p2) (sort ((@@ (guix import go) parse-go.mod) input) inf?))) (testing-parse-mod "parse-go.mod-simple" - '(("good/thing" . "v1.4.5") - ("new/thing/v2" . "v2.3.4") - ("other/thing" . "v1.0.2")) + '(("good/thing" "v1.4.5") + ("new/thing/v2" "v2.3.4") + ("other/thing" "v1.0.2")) fixture-go-mod-simple) (testing-parse-mod "parse-go.mod-with-block" - '(("A" . "v1") - ("B" . "v1.0.0") - ("C" . "v1.0.0") - ("D" . "v1.2.3") - ("E" . "dev")) + '(("A" "v1") + ("B" "v1.0.0") + ("C" "v1.0.0") + ("D" "v1.2.3") + ("E" "dev")) fixture-go-mod-with-block) -(testing-parse-mod "parse-go.mod-complete" - '(("github.com/corp/arbitrary-repo" . "v0.0.2") - ("quoted.example.com/abitrary/repo" . "v0.0.2") - ("one.example.com/abitrary/repo" . "v1.1.111") - ("hub.jazz.net/git/user/project/sub/directory" . "v1.1.19") - ("hub.jazz.net/git/user/project" . "v1.1.18") - ("launchpad.net/~user/project/branch/sub/directory" . "v1.1.17") - ("launchpad.net/~user/project/branch" . "v1.1.16") - ("launchpad.net/project/series/sub/directory" . "v1.1.15") - ("launchpad.net/project/series" . "v1.1.14") - ("launchpad.net/project" . "v1.1.13") - ("bitbucket.org/user/project/sub/directory" . "v1.11.21") - ("bitbucket.org/user/project" . "v1.11.20") - ("k8s.io/kubernetes/subproject" . "v1.1.101") - ("github.com/user/project/sub/directory" . "v1.1.12") - ("github.com/user/project" . "v1.1.11") - ("github.com/go-check/check" . "v0.0.0-20140225173054-eb6ee6f84d0a")) - fixture-go-mod-complete) +(testing-parse-mod + "parse-go.mod-complete" + '(("github.com/corp/arbitrary-repo" "v0.0.2") + ("quoted.example.com/abitrary/repo" "v0.0.2") + ("one.example.com/abitrary/repo" "v1.1.111") + ("hub.jazz.net/git/user/project/sub/directory" "v1.1.19") + ("hub.jazz.net/git/user/project" "v1.1.18") + ("launchpad.net/~user/project/branch/sub/directory" "v1.1.17") + ("launchpad.net/~user/project/branch" "v1.1.16") + ("launchpad.net/project/series/sub/directory" "v1.1.15") + ("launchpad.net/project/series" "v1.1.14") + ("launchpad.net/project" "v1.1.13") + ("bitbucket.org/user/project/sub/directory" "v1.11.21") + ("bitbucket.org/user/project" "v1.11.20") + ("k8s.io/kubernetes/subproject" "v1.1.101") + ("github.com/user/project/sub/directory" "v1.1.12") + ("github.com/user/project" "v1.1.11") + ("github.com/go-check/check" "v0.0.0-20140225173054-eb6ee6f84d0a")) + fixture-go-mod-complete) ;;; End-to-end tests for (guix import go) (define (mock-http-fetch testcase) -- cgit v1.2.3 From 83f8b6d32c76c56e4bb58eeb5af1259028d7ee72 Mon Sep 17 00:00:00 2001 From: Maxim Cournoyer Date: Sun, 21 Mar 2021 00:16:22 -0400 Subject: import: go: Append version to symbol name in the pinned version mode. This allows importing packages with complicated version specific dependency chains without the package symbol names colliding. * doc/guix.texi (Invoking guix import): Document the --pin-versions option. Mention that a specific version can be imported. Remove the experimental warning. * guix/import/go.scm (go-module->guix-package-name)[version]: Add optional argument. Rewrite the character translation in terms of string-map. (go-module->guix-package): Conditionally use dependencies whose symbol include their version, based no the value of the PIN-VERSIONS? argument. * guix/import/utils.scm (package->definition): Add a new case where the full version string is appended to the package symbol. * guix/scripts/import.scm (guix-import): Correctly print forms starting with '(define-public [...]'. * guix/scripts/import/go.scm (guix-import-go): Conditionally include the version in the package symbols defined. --- doc/guix.texi | 14 +++++++++++--- guix/import/go.scm | 46 +++++++++++++++++++++++++++++----------------- guix/import/utils.scm | 7 +++++-- guix/scripts/import.scm | 3 ++- guix/scripts/import/go.scm | 17 ++++++++++------- 5 files changed, 57 insertions(+), 30 deletions(-) (limited to 'guix') diff --git a/doc/guix.texi b/doc/guix.texi index d4320f16e1..84d8bf50be 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -11553,13 +11553,13 @@ Select the given repository (a repository name). Possible values include: Import metadata for a Go module using @uref{https://proxy.golang.org, proxy.golang.org}. -This importer is highly experimental. See the source code for more info -about the current state. - @example guix import go gopkg.in/yaml.v2 @end example +It is possible to use a package specification with a @code{@@VERSION} +suffix to import a specific version. + Additional options include: @table @code @@ -11568,6 +11568,14 @@ Additional options include: Traverse the dependency graph of the given upstream package recursively and generate package expressions for all those packages that are not yet in Guix. +@item --pin-versions +When using this option, the importer preserves the exact versions of the +Go modules dependencies instead of using their latest available +versions. This can be useful when attempting to import packages that +recursively depend on former versions of themselves to build. When +using this mode, the symbol of the package is made by appending the +version to its name, so that multiple versions of the same package can +coexist. @end table @end table diff --git a/guix/import/go.scm b/guix/import/go.scm index ca2b9c6fa0..bc53f8f558 100644 --- a/guix/import/go.scm +++ b/guix/import/go.scm @@ -428,15 +428,19 @@ (define (vcs-qualified-module-path->root-repo-url module-path) (vcs-qualified-module-path->root-repo-url module-path) module-path)) -(define (go-module->guix-package-name module-path) - "Converts a module's path to the canonical Guix format for Go packages." - (string-downcase (string-append "go-" (string-replace-substring - (string-replace-substring - (string-replace-substring - module-path - "." "-") - "/" "-") - "_" "-")))) +(define* (go-module->guix-package-name module-path #:optional version) + "Converts a module's path to the canonical Guix format for Go packages. +Optionally include a VERSION string to append to the name." + ;; Map dot, slash and underscore characters to hyphens. + (let ((module-path* (string-map (lambda (c) + (if (member c '(#\. #\/ #\_)) + #\- + c)) + module-path))) + (string-downcase (string-append "go-" module-path* + (if version + (string-append "-" version) + ""))))) (define (strip-.git-suffix/maybe repo-url) "Strip a repository URL '.git' suffix from REPO-URL if hosted at GitHub." @@ -575,6 +579,8 @@ (define* (go-module->guix-package module-path #:key (let* ((available-versions (go-module-available-versions goproxy module-path)) (version* (or version (go-module-version-string goproxy module-path))) ;latest + ;; Elide the "v" prefix Go uses. + (strip-v-prefix (cut string-trim <> #\v)) ;; Pseudo-versions do not appear in the versions list; skip the ;; following check. (_ (unless (or (go-pseudo-version? version*) @@ -584,7 +590,9 @@ (define* (go-module->guix-package module-path #:key version* available-versions)))) (content (fetch-go.mod goproxy module-path version*)) (dependencies+versions (parse-go.mod content)) - (dependencies (map car dependencies+versions)) + (dependencies (if pin-versions? + dependencies+versions + (map car dependencies+versions))) (guix-name (go-module->guix-package-name module-path)) (root-module-path (module-path->repository-root module-path)) ;; The VCS type and URL are not included in goproxy information. For @@ -598,23 +606,27 @@ (define* (go-module->guix-package module-path #:key (values `(package (name ,guix-name) - ;; Elide the "v" prefix Go uses - (version ,(string-trim version* #\v)) + (version ,(strip-v-prefix version*)) (source ,(vcs->origin vcs-type vcs-repo-url version*)) (build-system go-build-system) (arguments '(#:import-path ,root-module-path)) - ,@(maybe-propagated-inputs (map go-module->guix-package-name - dependencies)) + ,@(maybe-propagated-inputs + (map (match-lambda + ((name version) + (go-module->guix-package-name name (strip-v-prefix version))) + (name + (go-module->guix-package-name name))) + dependencies)) (home-page ,(format #f "https://~a" root-module-path)) (synopsis ,synopsis) (description ,(and=> description beautify-description)) (license ,(match (list->licenses licenses) - (() #f) ;unknown license - ((license) ;a single license + (() #f) ;unknown license + ((license) ;a single license license) - ((license ...) ;a list of licenses + ((license ...) ;a list of licenses `(list ,@license))))) (if pin-versions? dependencies+versions diff --git a/guix/import/utils.scm b/guix/import/utils.scm index adf90f84d7..d817318a91 100644 --- a/guix/import/utils.scm +++ b/guix/import/utils.scm @@ -274,8 +274,9 @@ (define* (maybe-propagated-inputs package-names #:optional (output #f)) (maybe-inputs package-names output #:type 'propagated)) (define* (package->definition guix-package #:optional append-version?/string) - "If APPEND-VERSION?/STRING is #t, append the package's major+minor -version. If APPEND-VERSION?/string is a string, append this string." + "If APPEND-VERSION?/STRING is #t, append the package's major+minor version. +If it is the symbol 'full, append the package's complete version. If +APPEND-VERSION?/string is a string, append this string." (match guix-package ((or ('package ('name name) ('version version) . rest) @@ -287,6 +288,8 @@ (define* (package->definition guix-package #:optional append-version?/string) (string-append name "-" append-version?/string)) ((eq? append-version?/string #t) (string-append name "-" (version-major+minor version))) + ((eq? 'full append-version?/string) + (string-append name "-" version)) (else name))) ,guix-package)))) diff --git a/guix/scripts/import.scm b/guix/scripts/import.scm index 1d2b45d942..98554ef79b 100644 --- a/guix/scripts/import.scm +++ b/guix/scripts/import.scm @@ -119,7 +119,8 @@ (define-command (guix-import . args) (current-output-port)))))) (match (apply (resolve-importer importer) args) ((and expr (or ('package _ ...) - ('let _ ...))) + ('let _ ...) + ('define-public _ ...))) (print expr)) ((? list? expressions) (for-each (lambda (expr) diff --git a/guix/scripts/import/go.scm b/guix/scripts/import/go.scm index 33d2470ce1..04b07f80cc 100644 --- a/guix/scripts/import/go.scm +++ b/guix/scripts/import/go.scm @@ -22,9 +22,11 @@ (define-module (guix scripts import go) #:use-module (guix utils) #:use-module (guix scripts) #:use-module (guix import go) + #:use-module (guix import utils) #:use-module (guix scripts import) #:use-module (srfi srfi-1) #:use-module (srfi srfi-11) + #:use-module (srfi srfi-26) #:use-module (srfi srfi-37) #:use-module (ice-9 match) #:use-module (ice-9 format) @@ -94,7 +96,12 @@ (define (parse-options) (('argument . value) value) (_ #f)) - (reverse opts)))) + (reverse opts))) + ;; Append the full version to the package symbol name when using + ;; pinned versions. + (package->definition* (if (assoc-ref opts 'pin-versions?) + (cut package->definition <> 'full) + package->definition))) (match args ((spec) ;e.g., github.com/golang/protobuf@v1.3.1 (receive (name version) @@ -106,18 +113,14 @@ (define (parse-options) (assoc-ref opts 'pin-versions?)))) (if (assoc-ref opts 'recursive) ;; Recursive import. - (map (match-lambda - ((and ('package ('name name) . rest) pkg) - `(define-public ,(string->symbol name) - ,pkg)) - (_ #f)) + (map package->definition* (apply go-module-recursive-import arguments)) ;; Single import. (let ((sexp (apply go-module->guix-package arguments))) (unless sexp (leave (G_ "failed to download meta-data for module '~a'~%") module-name)) - sexp))))) + (package->definition* sexp)))))) (() (leave (G_ "too few arguments~%"))) ((many ...) -- cgit v1.2.3 From fed28a9632ba69225151757e44a5d70e9b0652a2 Mon Sep 17 00:00:00 2001 From: Maxim Cournoyer Date: Sat, 10 Apr 2021 00:49:04 -0400 Subject: build-system/qt: Fix wrapping with QTWEBENGINEPROCESS_PATH. This is a follow up commit to 06eb21856f, which added QTWEBENGINEPROCESS_PATH to the list of wrapped variables. Unfortunately it wouldn't be set, as its value is a plain file rather than a directory, and the code only checked for directories. * guix/build/qt-build-system.scm (variables-for-wrapping): Define a file type entry for each variable definition, and use it to determine if we should look for directories versus plain files. --- guix/build/qt-build-system.scm | 29 ++++++++++++++++++----------- 1 file changed, 18 insertions(+), 11 deletions(-) (limited to 'guix') diff --git a/guix/build/qt-build-system.scm b/guix/build/qt-build-system.scm index bd8e694209..f59b0c420f 100644 --- a/guix/build/qt-build-system.scm +++ b/guix/build/qt-build-system.scm @@ -49,17 +49,23 @@ (define* (check-setup #:rest args) (define (variables-for-wrapping base-directories) - (define (collect-sub-dirs base-directories subdirectory + (define (collect-sub-dirs base-directories file-type subdirectory selectors) ;; Append SUBDIRECTORY and each of BASE-DIRECTORIES, and return the subset ;; that exists and has at least one of the SELECTORS sub-directories, - ;; unless SELECTORS is the empty list. + ;; unless SELECTORS is the empty list. FILE-TYPE should by 'directory or + ;; 'regular file. For the later, it allows searching for plain files + ;; rather than directories. + (define exists? (match file-type + ('directory directory-exists?) + ('regular file-exists?))) + (filter-map (lambda (dir) (let ((directory (string-append dir subdirectory))) - (and (directory-exists? directory) + (and (exists? directory) (or (null? selectors) (any (lambda (selector) - (directory-exists? + (exists? (string-append directory selector))) selectors)) directory))) @@ -67,8 +73,8 @@ (define (collect-sub-dirs base-directories subdirectory (filter-map (match-lambda - ((variable directory selectors ...) - (match (collect-sub-dirs base-directories directory + ((variable file-type directory selectors ...) + (match (collect-sub-dirs base-directories file-type directory selectors) (() #f) @@ -77,7 +83,7 @@ (define (collect-sub-dirs base-directories subdirectory ;; These shall match the search-path-specification for Qt and KDE ;; libraries. - (list '("XDG_DATA_DIRS" "/share" + (list '("XDG_DATA_DIRS" directory "/share" ;; These are "selectors": consider /share if and only if at least ;; one of these sub-directories exist. This avoids adding @@ -85,10 +91,11 @@ (define (collect-sub-dirs base-directories subdirectory ;; /share sub-directory. "/glib-2.0/schemas" "/sounds" "/themes" "/cursors" "/wallpapers" "/icons" "/mime") - '("XDG_CONFIG_DIRS" "/etc/xdg") - '("QT_PLUGIN_PATH" "/lib/qt5/plugins") - '("QML2_IMPORT_PATH" "/lib/qt5/qml") - '("QTWEBENGINEPROCESS_PATH" "/lib/qt5/libexec/QtWebEngineProcess")))) + '("XDG_CONFIG_DIRS" directory "/etc/xdg") + '("QT_PLUGIN_PATH" directory "/lib/qt5/plugins") + '("QML2_IMPORT_PATH" directory "/lib/qt5/qml") + '("QTWEBENGINEPROCESS_PATH" regular + "/lib/qt5/libexec/QtWebEngineProcess")))) (define* (wrap-all-programs #:key inputs outputs (qt-wrap-excluded-outputs '()) -- cgit v1.2.3 From cb41c15827a2e910aa56fb5d1917ba8a085c95c7 Mon Sep 17 00:00:00 2001 From: Kyle Meyer Date: Fri, 9 Apr 2021 23:50:13 -0400 Subject: git: Update cached checkout to the remote HEAD by default. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Fixes . Reported by Ricardo Wurmus . update-cached-checkout hard codes "master" as the default branch, leading to a failure when the clone doesn't have a "master" branch. Instead use the remote HEAD symref as an indicator of what the primary branch is. * guix/git.scm (resolve-reference): Support resolving symrefs. (update-cached-checkout, latest-repository-commit): Change the default for REF to the empty list and translate it to the remote HEAD symref. (): Change branch field's default to #f. (git-checkout-compiler): When branch and commit fields are both #f, call latest-repository-commit* with the empty list as the ref. Signed-off-by: Ludovic Courtès --- guix/git.scm | 23 ++++++++++++++++------- 1 file changed, 16 insertions(+), 7 deletions(-) (limited to 'guix') diff --git a/guix/git.scm b/guix/git.scm index 1820036f25..776b03f33a 100644 --- a/guix/git.scm +++ b/guix/git.scm @@ -1,6 +1,7 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2017, 2020 Mathieu Othacehe ;;; Copyright © 2018, 2019, 2020, 2021 Ludovic Courtès +;;; Copyright © 2021 Kyle Meyer ;;; ;;; This file is part of GNU Guix. ;;; @@ -209,6 +210,9 @@ (define (resolve-reference repository ref) (let ((oid (reference-target (branch-lookup repository branch BRANCH-REMOTE)))) (object-lookup repository oid))) + (('symref . symref) + (let ((oid (reference-name->oid repository symref))) + (object-lookup repository oid))) (('commit . commit) (let ((len (string-length commit))) ;; 'object-lookup-prefix' appeared in Guile-Git in Mar. 2018, so we @@ -340,7 +344,7 @@ (define (delete-checkout directory) (define* (update-cached-checkout url #:key - (ref '(branch . "master")) + (ref '()) recursive? (check-out? #t) starting-commit @@ -356,6 +360,7 @@ (define* (update-cached-checkout url REF is pair whose key is [branch | commit | tag | tag-or-commit ] and value the associated data: [ | | | ]. +If REF is the empty list, the remote HEAD is used. When RECURSIVE? is true, check out submodules as well, if any. @@ -374,6 +379,7 @@ (define canonical-ref ;; made little sense since the cache should be transparent to them. So ;; here we append "origin/" if it's missing and otherwise keep it. (match ref + (() '(symref . "refs/remotes/origin/HEAD")) (('branch . branch) `(branch . ,(if (string-prefix? "origin/" branch) branch @@ -433,12 +439,13 @@ (define* (latest-repository-commit store url (log-port (%make-void-port "w")) (cache-directory (%repository-cache-directory)) - (ref '(branch . "master"))) + (ref '())) "Return two values: the content of the git repository at URL copied into a store directory and the sha1 of the top level commit in this directory. The reference to be checkout, once the repository is fetched, is specified by REF. REF is pair whose key is [branch | commit | tag] and value the associated -data, respectively [ | | ]. +data, respectively [ | | ]. If REF is the empty +list, the remote HEAD is used. When RECURSIVE? is true, check out submodules as well, if any. @@ -548,7 +555,7 @@ (define-record-type* git-checkout make-git-checkout git-checkout? (url git-checkout-url) - (branch git-checkout-branch (default "master")) + (branch git-checkout-branch (default #f)) (commit git-checkout-commit (default #f)) ;#f | tag | commit (recursive? git-checkout-recursive? (default #f))) @@ -587,9 +594,11 @@ (define-gexp-compiler (git-checkout-compiler (checkout ) (match checkout (($ url branch commit recursive?) (latest-repository-commit* url - #:ref (if commit - `(tag-or-commit . ,commit) - `(branch . ,branch)) + #:ref (cond (commit + `(tag-or-commit . ,commit)) + (branch + `(branch . ,branch)) + (else '())) #:recursive? recursive? #:log-port (current-error-port))))) -- cgit v1.2.3 From e18e2e458fe584ee9eaeca40adbdcef895d32abf Mon Sep 17 00:00:00 2001 From: Mark H Weaver Date: Fri, 9 Apr 2021 23:19:05 -0400 Subject: scripts: system: Default to -v3 when building a system. This is a followup to 8f9052d5434a3a11e7b4ff14d6b0090256e08aa4. * guix/scripts/system.scm (verbosity-level): Change the default from 2 to 3 when building a system. --- guix/scripts/system.scm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm index c226f08371..0a051ee4e3 100644 --- a/guix/scripts/system.scm +++ b/guix/scripts/system.scm @@ -1145,7 +1145,7 @@ (define (verbosity-level opts) "Return the verbosity level based on OPTS, the alist of parsed options." (or (assoc-ref opts 'verbosity) (if (eq? (assoc-ref opts 'action) 'build) - 2 1))) + 3 1))) ;;; -- cgit v1.2.3 From b18f45c21f5d697d384a7bd5c9d3ee314bba9e35 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 28 Dec 2018 01:07:58 +0100 Subject: Add (guix ipfs). MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit This module allows for communicating with the IPFS gateway over the HTTP interface. The commit has been cherry-picked from . The procedures for adding and restoring file trees have been removed as according to a reply issue 33899, a different format will be used. The procedure 'add-data' has been exported as it will be used in the system test for IPFS. * guix/ipfs.scm: New file. * Makefile.am (MODULES): Add it. Signed-off-by: Ludovic Courtès --- Makefile.am | 1 + guix/ipfs.scm | 183 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++ tests/ipfs.scm | 55 +++++++++++++++++ 3 files changed, 239 insertions(+) create mode 100644 guix/ipfs.scm create mode 100644 tests/ipfs.scm (limited to 'guix') diff --git a/Makefile.am b/Makefile.am index 1c2d45527c..17ad236655 100644 --- a/Makefile.am +++ b/Makefile.am @@ -126,6 +126,7 @@ MODULES = \ guix/cache.scm \ guix/cve.scm \ guix/workers.scm \ + guix/ipfs.scm \ guix/build-system.scm \ guix/build-system/android-ndk.scm \ guix/build-system/ant.scm \ diff --git a/guix/ipfs.scm b/guix/ipfs.scm new file mode 100644 index 0000000000..31a89888a7 --- /dev/null +++ b/guix/ipfs.scm @@ -0,0 +1,183 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2018 Ludovic Courtès +;;; +;;; 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 ipfs) + #:use-module (json) + #:use-module (guix base64) + #:use-module ((guix build utils) #:select (dump-port)) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-11) + #:use-module (srfi srfi-26) + #:use-module (rnrs io ports) + #:use-module (rnrs bytevectors) + #:use-module (ice-9 match) + #:use-module (ice-9 ftw) + #:use-module (web uri) + #:use-module (web client) + #:use-module (web response) + #:export (%ipfs-base-url + add-data + add-file + + content? + content-name + content-hash + content-size + + add-empty-directory + add-to-directory + read-contents + publish-name)) + +;;; Commentary: +;;; +;;; This module implements bindings for the HTTP interface of the IPFS +;;; gateway, documented here: . It +;;; allows you to add and retrieve files over IPFS, and a few other things. +;;; +;;; Code: + +(define %ipfs-base-url + ;; URL of the IPFS gateway. + (make-parameter "http://localhost:5001")) + +(define* (call url decode #:optional (method http-post) + #:key body (false-if-404? #t) (headers '())) + "Invoke the endpoint at URL using METHOD. Decode the resulting JSON body +using DECODE, a one-argument procedure that takes an input port; when DECODE +is false, return the input port. When FALSE-IF-404? is true, return #f upon +404 responses." + (let*-values (((response port) + (method url #:streaming? #t + #:body body + + ;; Always pass "Connection: close". + #:keep-alive? #f + #:headers `((connection close) + ,@headers)))) + (cond ((= 200 (response-code response)) + (if decode + (let ((result (decode port))) + (close-port port) + result) + port)) + ((and false-if-404? + (= 404 (response-code response))) + (close-port port) + #f) + (else + (close-port port) + (throw 'ipfs-error url response))))) + +;; Result of a file addition. +(define-json-mapping make-content content? + json->content + (name content-name "Name") + (hash content-hash "Hash") + (bytes content-bytes "Bytes") + (size content-size "Size" string->number)) + +;; Result of a 'patch/add-link' operation. +(define-json-mapping make-directory directory? + json->directory + (hash directory-hash "Hash") + (links directory-links "Links" json->links)) + +;; A "link". +(define-json-mapping make-link link? + json->link + (name link-name "Name") + (hash link-hash "Hash") + (size link-size "Size" string->number)) + +;; A "binding", also known as a "name". +(define-json-mapping make-binding binding? + json->binding + (name binding-name "Name") + (value binding-value "Value")) + +(define (json->links json) + (match json + (#f '()) + (links (map json->link links)))) + +(define %multipart-boundary + ;; XXX: We might want to find a more reliable boundary. + (string-append (make-string 24 #\-) "2698127afd7425a6")) + +(define (bytevector->form-data bv port) + "Write to PORT a 'multipart/form-data' representation of BV." + (display (string-append "--" %multipart-boundary "\r\n" + "Content-Disposition: form-data\r\n" + "Content-Type: application/octet-stream\r\n\r\n") + port) + (put-bytevector port bv) + (display (string-append "\r\n--" %multipart-boundary "--\r\n") + port)) + +(define* (add-data data #:key (name "file.txt") recursive?) + "Add DATA, a bytevector, to IPFS. Return a content object representing it." + (call (string-append (%ipfs-base-url) + "/api/v0/add?arg=" (uri-encode name) + "&recursive=" + (if recursive? "true" "false")) + json->content + #:headers + `((content-type + . (multipart/form-data + (boundary . ,%multipart-boundary)))) + #:body + (call-with-bytevector-output-port + (lambda (port) + (bytevector->form-data data port))))) + +(define (not-dot? entry) + (not (member entry '("." "..")))) + +(define* (add-file file #:key (name (basename file))) + "Add FILE under NAME to the IPFS and return a content object for it." + (add-data (match (call-with-input-file file get-bytevector-all) + ((? eof-object?) #vu8()) + (bv bv)) + #:name name)) + +(define* (add-empty-directory #:key (name "directory")) + "Return a content object for an empty directory." + (add-data #vu8() #:recursive? #t #:name name)) + +(define* (add-to-directory directory file name) + "Add FILE to DIRECTORY under NAME, and return the resulting directory. +DIRECTORY and FILE must be hashes identifying objects in the IPFS store." + (call (string-append (%ipfs-base-url) + "/api/v0/object/patch/add-link?arg=" + (uri-encode directory) + "&arg=" (uri-encode name) "&arg=" (uri-encode file) + "&create=true") + json->directory)) + +(define* (read-contents object #:key offset length) + "Return an input port to read the content of OBJECT from." + (call (string-append (%ipfs-base-url) + "/api/v0/cat?arg=" object) + #f)) + +(define* (publish-name object) + "Publish OBJECT under the current peer ID." + (call (string-append (%ipfs-base-url) + "/api/v0/name/publish?arg=" object) + json->binding)) diff --git a/tests/ipfs.scm b/tests/ipfs.scm new file mode 100644 index 0000000000..3b662b22bd --- /dev/null +++ b/tests/ipfs.scm @@ -0,0 +1,55 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2018 Ludovic Courtès +;;; +;;; 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 (test-ipfs) + #:use-module (guix ipfs) + #:use-module ((guix utils) #:select (call-with-temporary-directory)) + #:use-module (guix tests) + #:use-module (web uri) + #:use-module (srfi srfi-64)) + +;; Test the (guix ipfs) module. + +(define (ipfs-gateway-running?) + "Return true if the IPFS gateway is running at %IPFS-BASE-URL." + (let* ((uri (string->uri (%ipfs-base-url))) + (socket (socket AF_INET SOCK_STREAM 0))) + (define connected? + (catch 'system-error + (lambda () + (format (current-error-port) + "probing IPFS gateway at localhost:~a...~%" + (uri-port uri)) + (connect socket AF_INET INADDR_LOOPBACK (uri-port uri)) + #t) + (const #f))) + + (close-port socket) + connected?)) + +(unless (ipfs-gateway-running?) + (test-skip 1)) + +(test-assert "add-file-tree + restore-file-tree" + (call-with-temporary-directory + (lambda (directory) + (let* ((source (dirname (search-path %load-path "guix/base32.scm"))) + (target (string-append directory "/r")) + (content (pk 'content (add-file-tree source)))) + (restore-file-tree (content-name content) target) + (file=? source target))))) -- cgit v1.2.3 From a514b4ab19a628cbfa8b6d7c316ed7242018fcbf Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 12 Apr 2021 18:33:17 +0200 Subject: channels: Build user channels with '-O1'. This should noticeably speed up compilation for channels with many files. * guix/channels.scm (standard-module-derivation)[build]: Define 'optimizations-for-level' and '-O1'. Pass #:optimization-options to 'compile-files'. --- guix/channels.scm | 17 ++++++++++++++++- 1 file changed, 16 insertions(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/channels.scm b/guix/channels.scm index b812c1b6e5..c40fc0c507 100644 --- a/guix/channels.scm +++ b/guix/channels.scm @@ -597,9 +597,24 @@ (define scm (string-append #$output "/share/guile/site/" (effective-version))) + (define optimizations-for-level + ;; Guile 3.0 provides this procedure but Guile 2.2 didn't. + ;; Since this code may be executed by either version, we can't + ;; rely on its availability. + (or (and=> (false-if-exception + (resolve-interface '(system base optimize))) + (lambda (iface) + (module-ref iface 'optimizations-for-level))) + (const '()))) + + (define -O1 + ;; Optimize for package module compilation speed. + (optimizations-for-level 1)) + (let* ((subdir #$directory) (source (string-append #$source subdir))) - (compile-files source go (find-files source "\\.scm$")) + (compile-files source go (find-files source "\\.scm$") + #:optimization-options (const -O1)) (mkdir-p (dirname scm)) (symlink (string-append #$source subdir) scm)) -- cgit v1.2.3 From fab8ab7617d4ba2eed4546e81b004ade5b739691 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 14 Apr 2021 22:50:02 +0200 Subject: git: Honor proxy settings when fetching submodules. Fixes . * guix/git.scm (update-submodules): Add #:fetch-options and honor it. (update-cached-checkout): Pass #:fetch-options to 'update-submodules'. * doc/guix.texi (Requirements): Adjust comment about Guile-Git. --- doc/guix.texi | 3 ++- guix/git.scm | 10 +++++++--- 2 files changed, 9 insertions(+), 4 deletions(-) (limited to 'guix') diff --git a/doc/guix.texi b/doc/guix.texi index 1069a5d296..58bcfbdbb5 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -848,7 +848,8 @@ version 0.1.0 or later; @item @uref{https://notabug.org/guile-lzlib/guile-lzlib, Guile-lzlib}; @item @uref{https://www.nongnu.org/guile-avahi/, Guile-Avahi}; @item -@c FIXME: Specify a version number once a release has been made. +@c FIXME: We need the #:fetch-options parameter of 'submodule-update', +@c which appeared in 0.5.0. Change below after string freeze. @uref{https://gitlab.com/guile-git/guile-git, Guile-Git}, version 0.3.0 or later; @item @uref{https://savannah.nongnu.org/projects/guile-json/, Guile-JSON} diff --git a/guix/git.scm b/guix/git.scm index 776b03f33a..57fa2ca1ee 100644 --- a/guix/git.scm +++ b/guix/git.scm @@ -283,13 +283,15 @@ (define-syntax-rule (with-git-error-handling body ...) (report-git-error err)))) (define* (update-submodules repository - #:key (log-port (current-error-port))) + #:key (log-port (current-error-port)) + (fetch-options #f)) "Update the submodules of REPOSITORY, a Git repository object." (for-each (lambda (name) (let ((submodule (submodule-lookup repository name))) (format log-port (G_ "updating submodule '~a'...~%") name) - (submodule-update submodule) + (submodule-update submodule + #:fetch-options fetch-options) ;; Recurse in SUBMODULE. (let ((directory (string-append @@ -297,6 +299,7 @@ (define* (update-submodules repository "/" (submodule-path submodule)))) (with-repository directory repository (update-submodules repository + #:fetch-options fetch-options #:log-port log-port))))) (repository-submodules repository))) @@ -397,7 +400,8 @@ (define canonical-ref (remote-fetch (remote-lookup repository "origin") #:fetch-options (make-default-fetch-options))) (when recursive? - (update-submodules repository #:log-port log-port)) + (update-submodules repository #:log-port log-port + #:fetch-options (make-default-fetch-options))) ;; Note: call 'commit-relation' from here because it's more efficient ;; than letting users re-open the checkout later on. -- cgit v1.2.3 From 1bab9b9f17256a9e4f45f5b0cceb8b52e0a1b1ed Mon Sep 17 00:00:00 2001 From: Mark H Weaver Date: Fri, 2 Apr 2021 18:36:50 -0400 Subject: grafts: Support rewriting UTF-16 and UTF-32 store references. Partially fixes . * guix/build/graft.scm (replace-store-references): Add support for finding and rewriting UTF-16 and UTF-32 store references. * tests/grafts.scm: Add tests. --- guix/build/graft.scm | 281 ++++++++++++++++++++++++++++++++++----------------- tests/grafts.scm | 83 +++++++++++++++ 2 files changed, 273 insertions(+), 91 deletions(-) (limited to 'guix') diff --git a/guix/build/graft.scm b/guix/build/graft.scm index c119ee71d1..f04c35fa74 100644 --- a/guix/build/graft.scm +++ b/guix/build/graft.scm @@ -1,6 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2014, 2015, 2016, 2018 Ludovic Courtès -;;; Copyright © 2016 Mark H Weaver +;;; Copyright © 2016, 2021 Mark H Weaver ;;; ;;; This file is part of GNU Guix. ;;; @@ -55,6 +55,52 @@ (define nix-base32-char? (string->char-set "0123456789abcdfghijklmnpqrsvwxyz") <>)) +(define (nix-base32-char-or-nul? c) + "Return true if C is a nix-base32 character or NUL, otherwise return false." + (or (nix-base32-char? c) + (char=? c #\nul))) + +(define (possible-utf16-hash? buffer i w) + "Return true if (I - W) is large enough to hold a UTF-16 encoded +nix-base32 hash and if BUFFER contains NULs in all positions where NULs +are to be expected in a UTF-16 encoded hash+dash pattern whose dash is +found at position I. Otherwise, return false." + (and (<= (* 2 hash-length) (- i w)) + (let loop ((j (+ 1 (- i (* 2 hash-length))))) + (or (>= j i) + (and (zero? (bytevector-u8-ref buffer j)) + (loop (+ j 2))))))) + +(define (possible-utf32-hash? buffer i w) + "Return true if (I - W) is large enough to hold a UTF-32 encoded +nix-base32 hash and if BUFFER contains NULs in all positions where NULs +are to be expected in a UTF-32 encoded hash+dash pattern whose dash is +found at position I. Otherwise, return false." + (and (<= (* 4 hash-length) (- i w)) + (let loop ((j (+ 1 (- i (* 4 hash-length))))) + (or (>= j i) + (and (zero? (bytevector-u8-ref buffer j)) + (zero? (bytevector-u8-ref buffer (+ j 1))) + (zero? (bytevector-u8-ref buffer (+ j 2))) + (loop (+ j 4))))))) + +(define (insert-nuls char-size bv) + "Given a bytevector BV, return a bytevector containing the same bytes but +with (CHAR-SIZE - 1) NULs inserted between every two adjacent bytes from BV. +For example, (insert-nuls 4 #u8(1 2 3)) => #u8(1 0 0 0 2 0 0 0 3)." + (if (= char-size 1) + bv + (let* ((len (bytevector-length bv)) + (bv* (make-bytevector (+ 1 (* char-size + (- len 1))) + 0))) + (let loop ((i 0)) + (when (< i len) + (bytevector-u8-set! bv* (* i char-size) + (bytevector-u8-ref bv i)) + (loop (+ i 1)))) + bv*))) + (define* (replace-store-references input output replacement-table #:optional (store (%store-directory))) "Read data from INPUT, replacing store references according to @@ -76,9 +122,9 @@ (define (optimize-u8-predicate pred) (list->vector (map pred (iota 256))) <>)) - (define nix-base32-byte? + (define nix-base32-byte-or-nul? (optimize-u8-predicate - (compose nix-base32-char? + (compose nix-base32-char-or-nul? integer->char))) (define (dash? byte) (= byte 45)) @@ -86,100 +132,153 @@ (define (dash? byte) (= byte 45)) (define request-size (expt 2 20)) ; 1 MiB ;; We scan the file for the following 33-byte pattern: 32 bytes of - ;; nix-base32 characters followed by a dash. To accommodate large files, - ;; we do not read the entire file, but instead work on buffers of up to - ;; 'request-size' bytes. To ensure that every 33-byte sequence appears - ;; entirely within exactly one buffer, adjacent buffers must overlap, - ;; i.e. they must share 32 byte positions. We accomplish this by - ;; "ungetting" the last 32 bytes of each buffer before reading the next - ;; buffer, unless we know that we've reached the end-of-file. + ;; nix-base32 characters followed by a dash. When we find such a pattern + ;; whose hash is in REPLACEMENT-TABLE, we perform the required rewrite and + ;; continue scanning. + ;; + ;; To support UTF-16 and UTF-32 store references, the 33 bytes comprising + ;; this hash+dash pattern may optionally be interspersed by extra NUL bytes. + ;; This simple approach works because the characters we are looking for are + ;; restricted to ASCII. UTF-16 hashes are interspersed with single NUL + ;; bytes ("\0"), and UTF-32 hashes are interspersed with triplets of NULs + ;; ("\0\0\0"). Note that we require NULs to be present only *between* the + ;; other bytes, and not at either end, in order to be insensitive to byte + ;; order. + ;; + ;; To accommodate large files, we do not read the entire file at once, but + ;; instead work on buffers of up to REQUEST-SIZE bytes. To ensure that + ;; every hash+dash pattern appears in its entirety in at least one buffer, + ;; adjacent buffers must overlap by one byte less than the maximum size of a + ;; hash+dash pattern. We accomplish this by "ungetting" a suffix of each + ;; buffer before reading the next buffer, unless we know that we've reached + ;; the end-of-file. (let ((buffer (make-bytevector request-size))) - (let loop () - ;; Note: We avoid 'get-bytevector-n' to work around - ;; . + (define-syntax-rule (byte-at i) + (bytevector-u8-ref buffer i)) + (let outer-loop () (match (get-bytevector-n! input buffer 0 request-size) ((? eof-object?) 'done) (end - ;; We scan the buffer for dashes that might be preceded by a - ;; nix-base32 hash. The key optimization here is that whenever we - ;; find a NON-nix-base32 character at position 'i', we know that it - ;; cannot be part of a hash, so the earliest position where the next - ;; hash could start is i+1 with the following dash at position i+33. - ;; - ;; Since nix-base32 characters comprise only 1/8 of the 256 possible - ;; byte values, and exclude some of the most common letters in - ;; English text (e t o u), in practice we can advance by 33 positions - ;; most of the time. - (let scan-from ((i hash-length) (written 0)) - ;; 'i' is the first position where we look for a dash. 'written' - ;; is the number of bytes in the buffer that have already been - ;; written. + (define (scan-from i w) + ;; Scan the buffer for dashes that might be preceded by nix hashes, + ;; where I is the minimum position where such a dash might be + ;; found, and W is the number of bytes in the buffer that have been + ;; written so far. We assume that I - W >= HASH-LENGTH. + ;; + ;; The key optimization here is that whenever we find a byte at + ;; position I that cannot occur within a nix hash (because it's + ;; neither a nix-base32 character nor NUL), we can infer that the + ;; earliest position where the next hash could start is at I + 1, + ;; and therefore the earliest position for the following dash is + ;; (+ I 1 HASH-LENGTH), which is I + 33. + ;; + ;; Since nix-base32-or-nul characters comprise only about 1/8 of + ;; the 256 possible byte values, and exclude some of the most + ;; common letters in English text (e t o u), we can advance 33 + ;; positions much of the time. (if (< i end) - (let ((byte (bytevector-u8-ref buffer i))) - (cond ((and (dash? byte) - ;; We've found a dash. Note that we do not know - ;; whether the preceeding 32 bytes are nix-base32 - ;; characters, but we do not need to know. If - ;; they are not, the following lookup will fail. - (lookup-replacement - (string-tabulate (lambda (j) - (integer->char - (bytevector-u8-ref buffer - (+ j (- i hash-length))))) - hash-length))) - => (lambda (replacement) - ;; We've found a hash that needs to be replaced. - ;; First, write out all bytes preceding the hash - ;; that have not yet been written. - (put-bytevector output buffer written - (- i hash-length written)) - ;; Now write the replacement string. - (put-bytevector output replacement) - ;; Since the byte at position 'i' is a dash, - ;; which is not a nix-base32 char, the earliest - ;; position where the next hash might start is - ;; i+1, and the earliest position where the - ;; following dash might start is (+ i 1 - ;; hash-length). Also, increase the write - ;; position to account for REPLACEMENT. - (let ((len (bytevector-length replacement))) - (scan-from (+ i 1 len) - (+ i (- len hash-length)))))) - ;; If the byte at position 'i' is a nix-base32 char, - ;; then the dash we're looking for might be as early as - ;; the following byte, so we can only advance by 1. - ((nix-base32-byte? byte) - (scan-from (+ i 1) written)) - ;; If the byte at position 'i' is NOT a nix-base32 - ;; char, then the earliest position where the next hash - ;; might start is i+1, with the following dash at - ;; position (+ i 1 hash-length). + (let ((byte (byte-at i))) + (cond ((dash? byte) + (found-dash i w)) + ((nix-base32-byte-or-nul? byte) + (scan-from (+ i 1) w)) (else - (scan-from (+ i 1 hash-length) written)))) - - ;; We have finished scanning the buffer. Now we determine how - ;; many bytes have not yet been written, and how many bytes to - ;; "unget". If 'end' is less than 'request-size' then we read - ;; less than we asked for, which indicates that we are at EOF, - ;; so we needn't unget anything. Otherwise, we unget up to - ;; 'hash-length' bytes (32 bytes). However, we must be careful - ;; not to unget bytes that have already been written, because - ;; that would cause them to be written again from the next - ;; buffer. In practice, this case occurs when a replacement is - ;; made near or beyond the end of the buffer. When REPLACEMENT - ;; went beyond END, we consume the extra bytes from INPUT. - (begin - (if (> written end) - (get-bytevector-n! input buffer 0 (- written end)) - (let* ((unwritten (- end written)) - (unget-size (if (= end request-size) - (min hash-length unwritten) - 0)) - (write-size (- unwritten unget-size))) - (put-bytevector output buffer written write-size) - (unget-bytevector input buffer (+ written write-size) - unget-size))) - (loop))))))))) + (not-part-of-hash i w)))) + (finish-buffer i w))) + + (define (not-part-of-hash i w) + ;; Position I is known to not be within a nix hash that we must + ;; rewrite. Therefore, the earliest position where the next hash + ;; might start is I + 1, and therefore the earliest position of + ;; the following dash is (+ I 1 HASH-LENGTH). + (scan-from (+ i 1 hash-length) w)) + + (define (found-dash i w) + ;; We know that there is a dash '-' at position I, and that + ;; I - W >= HASH-LENGTH. The immediately preceding bytes *might* + ;; contain a nix-base32 hash, but that is not yet known. Here, + ;; we rule out all but one possible encoding (ASCII, UTF-16, + ;; UTF-32) by counting how many NULs precede the dash. + (cond ((not (zero? (byte-at (- i 1)))) + ;; The dash is *not* preceded by a NUL, therefore it + ;; cannot possibly be a UTF-16 or UTF-32 hash. Proceed + ;; to check for an ASCII hash. + (found-possible-hash 1 i w)) + + ((not (zero? (byte-at (- i 2)))) + ;; The dash is preceded by exactly one NUL, therefore it + ;; cannot be an ASCII or UTF-32 hash. Proceed to check + ;; for a UTF-16 hash. + (if (possible-utf16-hash? buffer i w) + (found-possible-hash 2 i w) + (not-part-of-hash i w))) + + (else + ;; The dash is preceded by at least two NULs, therefore + ;; it cannot be an ASCII or UTF-16 hash. Proceed to + ;; check for a UTF-32 hash. + (if (possible-utf32-hash? buffer i w) + (found-possible-hash 4 i w) + (not-part-of-hash i w))))) + + (define (found-possible-hash char-size i w) + ;; We know that there is a dash '-' at position I, that + ;; I - W >= CHAR-SIZE * HASH-LENGTH, and that the only + ;; possible encoding for the preceding hash is as indicated by + ;; CHAR-SIZE. Here we check to see if the given hash is in + ;; REPLACEMENT-TABLE, and if so, we perform the required + ;; rewrite. + (let* ((hash (string-tabulate + (lambda (j) + (integer->char + (byte-at (- i (* char-size + (- hash-length j)))))) + hash-length)) + (replacement* (lookup-replacement hash)) + (replacement (and replacement* + (insert-nuls char-size replacement*)))) + (cond + ((not replacement) + (not-part-of-hash i w)) + (else + ;; We've found a hash that needs to be replaced. + ;; First, write out all bytes preceding the hash + ;; that have not yet been written. + (put-bytevector output buffer w + (- i (* char-size hash-length) w)) + ;; Now write the replacement string. + (put-bytevector output replacement) + ;; Now compute the new values of W and I and continue. + (let ((w (+ (- i (* char-size hash-length)) + (bytevector-length replacement)))) + (scan-from (+ w hash-length) w)))))) + + (define (finish-buffer i w) + ;; We have finished scanning the buffer. Now we determine how many + ;; bytes have not yet been written, and how many bytes to "unget". + ;; If END is less than REQUEST-SIZE then we read less than we asked + ;; for, which indicates that we are at EOF, so we needn't unget + ;; anything. Otherwise, we unget up to (* 4 HASH-LENGTH) bytes. + ;; However, we must be careful not to unget bytes that have already + ;; been written, because that would cause them to be written again + ;; from the next buffer. In practice, this case occurs when a + ;; replacement is made near or beyond the end of the buffer. When + ;; REPLACEMENT went beyond END, we consume the extra bytes from + ;; INPUT. + (if (> w end) + (get-bytevector-n! input buffer 0 (- w end)) + (let* ((unwritten (- end w)) + (unget-size (if (= end request-size) + (min (* 4 hash-length) + unwritten) + 0)) + (write-size (- unwritten unget-size))) + (put-bytevector output buffer w write-size) + (unget-bytevector input buffer (+ w write-size) + unget-size))) + (outer-loop)) + + (scan-from hash-length 0)))))) (define (rename-matching-files directory mapping) "Apply MAPPING to the names of all the files in DIRECTORY, where MAPPING is diff --git a/tests/grafts.scm b/tests/grafts.scm index a12c6a5911..7e1959e4a7 100644 --- a/tests/grafts.scm +++ b/tests/grafts.scm @@ -1,5 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2014, 2015, 2016, 2017, 2018, 2019 Ludovic Courtès +;;; Copyright © 2021 Mark H Weaver ;;; ;;; This file is part of GNU Guix. ;;; @@ -468,4 +469,86 @@ (define buffer-size replacement "/gnu/store"))))) +(define (insert-nuls char-size str) + (string-join (map string (string->list str)) + (make-string (- char-size 1) #\nul))) + +(define (nuls-to-underscores s) + (string-replace-substring s "\0" "_")) + +(define (annotate-buffer-boundary s) + (string-append (string-take s buffer-size) + "|" + (string-drop s buffer-size))) + +(define (abbreviate-leading-fill s) + (let ((s* (string-trim s #\=))) + (format #f "[~a =s]~a" + (- (string-length s) + (string-length s*)) + s*))) + +(define (prettify-for-display s) + (abbreviate-leading-fill + (annotate-buffer-boundary + (nuls-to-underscores s)))) + +(define (two-sample-refs-with-gap char-size1 char-size2 gap offset + char1 name1 char2 name2) + (string-append + (make-string (- buffer-size offset) #\=) + (insert-nuls char-size1 + (string-append "/gnu/store/" (make-string 32 char1) name1)) + gap + (insert-nuls char-size2 + (string-append "/gnu/store/" (make-string 32 char2) name2)) + (list->string (map integer->char (iota 77 33))))) + +(define (sample-map-entry old-char new-char new-name) + (cons (make-string 32 old-char) + (string->utf8 (string-append (make-string 32 new-char) + new-name)))) + +(define (test-two-refs-with-gap char-size1 char-size2 gap offset) + (test-equal + (format #f "test-two-refs-with-gap, char-sizes ~a ~a, gap ~s, offset ~a" + char-size1 char-size2 gap offset) + (prettify-for-display + (two-sample-refs-with-gap char-size1 char-size2 gap offset + #\6 "-BlahBlaH" + #\8"-SoMeTHiNG")) + (prettify-for-display + (let* ((content (two-sample-refs-with-gap char-size1 char-size2 gap offset + #\5 "-blahblah" + #\7 "-something")) + (replacement (alist->vhash + (list (sample-map-entry #\5 #\6 "-BlahBlaH") + (sample-map-entry #\7 #\8 "-SoMeTHiNG"))))) + (call-with-output-string + (lambda (output) + ((@@ (guix build graft) replace-store-references) + (open-input-string content) output + replacement + "/gnu/store"))))))) + +(for-each (lambda (char-size1) + (for-each (lambda (char-size2) + (for-each (lambda (gap) + (for-each (lambda (offset) + (test-two-refs-with-gap char-size1 + char-size2 + gap + offset)) + ;; offsets to test + (map (lambda (i) + (+ i (* 40 char-size1))) + (iota 30)))) + ;; gaps + '("" "-" " " "a"))) + ;; char-size2 values to test + '(1 2))) + ;; char-size1 values to test + '(1 2 4)) + + (test-end) -- cgit v1.2.3