From bbe66a530a014e8146d63002a5294941e935f863 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 21 Dec 2018 22:54:02 +0100 Subject: offload: Decompose 'machine-load' into simpler procedures. * guix/scripts/offload.scm (machine-load): Remove. (node-load, normalized-load): New procedures. (choose-build-machine): Call 'open-ssh-session' and 'make-node' from here; pass the node to 'node-load'. (check-machine-status): Use 'node-load' instead of 'machine-load'. Call 'disconnect!' on SESSION. --- guix/scripts/offload.scm | 92 +++++++++++++++++++++++++----------------------- 1 file changed, 48 insertions(+), 44 deletions(-) (limited to 'guix/scripts') diff --git a/guix/scripts/offload.scm b/guix/scripts/offload.scm index ee5857e16b..c345d438d1 100644 --- a/guix/scripts/offload.scm +++ b/guix/scripts/offload.scm @@ -392,33 +392,31 @@ (define (machine-matches? machine requirements) (build-requirements-features requirements) (build-machine-features machine)))) -(define (machine-load machine) - "Return the load of MACHINE, divided by the number of parallel builds -allowed on MACHINE. Return +∞ if MACHINE is unreachable." - ;; Note: This procedure is costly since it creates a new SSH session. - (match (false-if-exception (open-ssh-session machine)) - ((? session? session) - (let* ((pipe (open-remote-pipe* session OPEN_READ - "cat" "/proc/loadavg")) - (line (read-line pipe))) - (close-port pipe) - (disconnect! session) - - (if (eof-object? line) - +inf.0 ;MACHINE does not respond, so assume it is infinitely loaded - (match (string-tokenize line) - ((one five fifteen . x) - (let* ((raw (string->number one)) - (jobs (build-machine-parallel-builds machine)) - (normalized (/ raw jobs))) - (format (current-error-port) "load on machine '~a' is ~s\ +(define (node-load node) + "Return the load on NODE. Return +∞ if NODE is misbehaving." + (let ((line (node-eval node + '(begin + (use-modules (ice-9 rdelim)) + (call-with-input-file "/proc/loadavg" + read-string))))) + (if (eof-object? line) + +inf.0 ;MACHINE does not respond, so assume it is infinitely loaded + (match (string-tokenize line) + ((one five fifteen . x) + (string->number one)) + (x + +inf.0))))) + +(define (normalized-load machine load) + "Divide LOAD by the number of parallel builds of MACHINE." + (if (rational? load) + (let* ((jobs (build-machine-parallel-builds machine)) + (normalized (/ load jobs))) + (format (current-error-port) "load on machine '~a' is ~s\ (normalized: ~s)~%" - (build-machine-name machine) raw normalized) - normalized)) - (x - +inf.0))))) ;something's fishy about MACHINE, so avoid it - (x - +inf.0))) ;failed to connect to MACHINE, so avoid it + (build-machine-name machine) load normalized) + normalized) + load)) (define (machine-lock-file machine hint) "Return the name of MACHINE's lock file for HINT." @@ -484,21 +482,25 @@ (define (machine-faster? m1 m2) (match machines+slots (((best slot) others ...) ;; Return the best machine unless it's already overloaded. - ;; Note: We call 'machine-load' only as a last resort because it is + ;; Note: We call 'node-load' only as a last resort because it is ;; too costly to call it once for every machine. - (if (< (machine-load best) 2.) - (match others - (((machines slots) ...) - ;; Release slots from the uninteresting machines. - (for-each release-build-slot slots) - - ;; The caller must keep SLOT to protect it from GC and to - ;; eventually release it. - (values best slot))) - (begin - ;; BEST is overloaded, so try the next one. - (release-build-slot slot) - (loop others)))) + (let* ((session (false-if-exception (open-ssh-session best))) + (node (and session (make-node session))) + (load (and node (normalized-load best (node-load node))))) + (when session (disconnect! session)) + (if (and node (< load 2.)) + (match others + (((machines slots) ...) + ;; Release slots from the uninteresting machines. + (for-each release-build-slot slots) + + ;; The caller must keep SLOT to protect it from GC and to + ;; eventually release it. + (values best slot))) + (begin + ;; BEST is overloaded, so try the next one. + (release-build-slot slot) + (loop others))))) (() (values #f #f)))))) @@ -689,16 +691,18 @@ (define (build-machine=? m1 m2) (info (G_ "getting status of ~a build machines defined in '~a'...~%") (length machines) machine-file) (for-each (lambda (machine) - (let* ((node (make-node (open-ssh-session machine))) - (uts (node-eval node '(uname)))) + (let* ((session (open-ssh-session machine)) + (node (make-node session)) + (uts (node-eval node '(uname))) + (load (node-load node))) + (disconnect! session) (format #t "~a~% kernel: ~a ~a~% architecture: ~a~%\ host name: ~a~% normalized load: ~a~%" (build-machine-name machine) (utsname:sysname uts) (utsname:release uts) (utsname:machine uts) (utsname:nodename uts) - (parameterize ((current-error-port (%make-void-port "rw+"))) - (machine-load machine))))) + load))) machines))) -- cgit v1.2.3 From 63b0c3eaccdf1816b419632cd7fe721934d2eb27 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 21 Dec 2018 23:12:52 +0100 Subject: offload: Skip machines that are low on disk space. Fixes . * guix/scripts/offload.scm (node-free-disk-space): New procedure. (%minimum-disk-space): New variable. (choose-build-machine): Call 'node-free-disk-space' and take it into account in addition to LOAD. (check-machine-status): Display the free disk space. --- guix/scripts/offload.scm | 34 ++++++++++++++++++++++++++++------ 1 file changed, 28 insertions(+), 6 deletions(-) (limited to 'guix/scripts') diff --git a/guix/scripts/offload.scm b/guix/scripts/offload.scm index c345d438d1..0bedcb402f 100644 --- a/guix/scripts/offload.scm +++ b/guix/scripts/offload.scm @@ -321,6 +321,13 @@ (define (build-log-port) (set-port-revealed! port 1) port)) +(define (node-free-disk-space node) + "Return the free disk space, in bytes, in NODE's store." + (node-eval node + `(begin + (use-modules (guix build syscalls)) + (free-disk-space ,(%store-prefix))))) + (define* (transfer-and-offload drv machine #:key (inputs '()) @@ -392,6 +399,12 @@ (define (machine-matches? machine requirements) (build-requirements-features requirements) (build-machine-features machine)))) +(define %minimum-disk-space + ;; Minimum disk space required on the build machine for a build to be + ;; offloaded. This keeps us from offloading to machines that are bound to + ;; run out of disk space. + (* 100 (expt 2 20))) ;100 MiB + (define (node-load node) "Return the load on NODE. Return +∞ if NODE is misbehaving." (let ((line (node-eval node @@ -486,9 +499,10 @@ (define (machine-faster? m1 m2) ;; too costly to call it once for every machine. (let* ((session (false-if-exception (open-ssh-session best))) (node (and session (make-node session))) - (load (and node (normalized-load best (node-load node))))) + (load (and node (normalized-load best (node-load node)))) + (space (and node (node-free-disk-space node)))) (when session (disconnect! session)) - (if (and node (< load 2.)) + (if (and node (< load 2.) (>= space %minimum-disk-space)) (match others (((machines slots) ...) ;; Release slots from the uninteresting machines. @@ -498,7 +512,13 @@ (define (machine-faster? m1 m2) ;; eventually release it. (values best slot))) (begin - ;; BEST is overloaded, so try the next one. + ;; BEST is unsuitable, so try the next one. + (when (and space (< space %minimum-disk-space)) + (format (current-error-port) + "skipping machine '~a' because it is low \ +on disk space (~,2f MiB free)~%" + (build-machine-name best) + (/ space (expt 2 20) 1.))) (release-build-slot slot) (loop others))))) (() @@ -694,15 +714,17 @@ (define (build-machine=? m1 m2) (let* ((session (open-ssh-session machine)) (node (make-node session)) (uts (node-eval node '(uname))) - (load (node-load node))) + (load (node-load node)) + (free (node-free-disk-space node))) (disconnect! session) (format #t "~a~% kernel: ~a ~a~% architecture: ~a~%\ - host name: ~a~% normalized load: ~a~%" + host name: ~a~% normalized load: ~a~% free disk space: ~,2f MiB~%" (build-machine-name machine) (utsname:sysname uts) (utsname:release uts) (utsname:machine uts) (utsname:nodename uts) - load))) + load + (/ free (expt 2 20) 1.)))) machines))) -- cgit v1.2.3 From b96e05aefd7a4f734cfec3b27c2d38320d43b687 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 21 Dec 2018 23:31:19 +0100 Subject: offload: Recognize build failures due to lack of disk space. Previously, if a remote build would fail due to lack of disk space, this would be considered a permanent failure and thus cached as a build failure if the local daemon runs with '--cache-failures'. * guix/scripts/offload.scm (transfer-and-offload): Upon 'nix-protocol-error?' call 'node-free-disk-space' and return 1 instead of 100 if the result if lower than 10 MiB. --- guix/scripts/offload.scm | 16 +++++++++++++--- 1 file changed, 13 insertions(+), 3 deletions(-) (limited to 'guix/scripts') diff --git a/guix/scripts/offload.scm b/guix/scripts/offload.scm index 0bedcb402f..1e0ea1c4c6 100644 --- a/guix/scripts/offload.scm +++ b/guix/scripts/offload.scm @@ -367,9 +367,19 @@ (define store (derivation-file-name drv) (build-machine-name machine) (nix-protocol-error-message c)) - ;; Use exit code 100 for a permanent build failure. The daemon - ;; interprets other non-zero codes as transient build failures. - (primitive-exit 100))) + (let* ((space (false-if-exception + (node-free-disk-space (make-node session))))) + + ;; Use exit code 100 for a permanent build failure. The daemon + ;; interprets other non-zero codes as transient build failures. + (if (and space (< space (* 10 (expt 2 20)))) + (begin + (format (current-error-port) + (G_ "build failure may have been caused by lack \ +of free disk space on '~a'~%") + (build-machine-name machine)) + (primitive-exit 1)) + (primitive-exit 100))))) (parameterize ((current-build-output-port (build-log-port))) (build-derivations store (list drv)))) -- cgit v1.2.3 From 62b845c5e2c28a360102f095548e3dc3e9cf3200 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sat, 22 Dec 2018 14:24:49 +0100 Subject: offload: Display the normalized load in 'guix offload status' output. Fixes a regression introduced in bbe66a530a014e8146d63002a5294941e935f863 whereby the actual load (non-normalized) would be displayed. * guix/scripts/offload.scm (check-machine-status): Add call to 'normalized-load'. --- guix/scripts/offload.scm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'guix/scripts') diff --git a/guix/scripts/offload.scm b/guix/scripts/offload.scm index 1e0ea1c4c6..bfdaa3c011 100644 --- a/guix/scripts/offload.scm +++ b/guix/scripts/offload.scm @@ -733,7 +733,7 @@ (define (build-machine=? m1 m2) (utsname:sysname uts) (utsname:release uts) (utsname:machine uts) (utsname:nodename uts) - load + (normalized-load machine load) (/ free (expt 2 20) 1.)))) machines))) -- cgit v1.2.3 From 0865d8a8f6c229fef5bcba647cc7b37c2f3d3dae Mon Sep 17 00:00:00 2001 From: Arun Isaac Date: Fri, 21 Dec 2018 17:48:55 +0530 Subject: guix: lint: Check for source URIs redirecting to GitHub. * guix/scripts/lint.scm (check-github-uri): New procedure. (%checkers): Add it. * doc/guix.texi (Invoking guix lint): Document it. * tests/lint.scm ("github-url", "github-url: one suggestion"): New tests. --- doc/guix.texi | 10 ++++++---- guix/scripts/lint.scm | 39 +++++++++++++++++++++++++++++++++++++++ tests/lint.scm | 28 ++++++++++++++++++++++++++++ 3 files changed, 73 insertions(+), 4 deletions(-) (limited to 'guix/scripts') diff --git a/doc/guix.texi b/doc/guix.texi index 33f5c63420..484a29f2e1 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -7660,12 +7660,14 @@ Identify inputs that should most likely be native inputs. @item source @itemx home-page @itemx mirror-url +@itemx github-url @itemx source-file-name Probe @code{home-page} and @code{source} URLs and report those that are -invalid. Suggest a @code{mirror://} URL when applicable. Check that -the source file name is meaningful, e.g.@: is not -just a version number or ``git-checkout'', without a declared -@code{file-name} (@pxref{origin Reference}). +invalid. Suggest a @code{mirror://} URL when applicable. If the +@code{source} URL redirects to a GitHub URL, recommend usage of the GitHub +URL. Check that the source file name is meaningful, e.g.@: is not just a +version number or ``git-checkout'', without a declared @code{file-name} +(@pxref{origin Reference}). @item cve @cindex security vulnerabilities diff --git a/guix/scripts/lint.scm b/guix/scripts/lint.scm index 2314f3b28c..354f6f7031 100644 --- a/guix/scripts/lint.scm +++ b/guix/scripts/lint.scm @@ -8,6 +8,7 @@ ;;; Copyright © 2017 Alex Kost ;;; Copyright © 2017 Tobias Geerinckx-Rice ;;; Copyright © 2017 Efraim Flashner +;;; Copyright © 2018 Arun Isaac ;;; ;;; This file is part of GNU Guix. ;;; @@ -44,8 +45,10 @@ (define-module (guix scripts lint) #:use-module (guix cve) #:use-module (gnu packages) #:use-module (ice-9 match) + #:use-module (ice-9 receive) #:use-module (ice-9 regex) #:use-module (ice-9 format) + #:use-module (web client) #:use-module (web uri) #:use-module ((guix build download) #:select (maybe-expand-mirrors @@ -74,6 +77,7 @@ (define-module (guix scripts lint) check-source check-source-file-name check-mirror-url + check-github-url check-license check-vulnerabilities check-for-updates @@ -773,6 +777,37 @@ (define (check-mirror-uri uri) ;XXX: could be optimized (let ((uris (origin-uris origin))) (for-each check-mirror-uri uris))))) +(define (check-github-url package) + "Check whether PACKAGE uses source URLs that redirect to GitHub." + (define (follow-redirect uri) + (receive (response body) (http-head uri) + (case (response-code response) + ((301 302) + (uri->string (assoc-ref (response-headers response) 'location))) + (else #f)))) + + (define (follow-redirects-to-github uri) + (cond + ((string-prefix? "https://github.com/" uri) uri) + ((string-prefix? "http" uri) + (and=> (follow-redirect uri) follow-redirects-to-github)) + ;; Do not attempt to follow redirects on URIs other than http and https + ;; (such as mirror, file) + (else #f))) + + (let ((origin (package-source package))) + (when (and (origin? origin) + (eqv? (origin-method origin) url-fetch)) + (for-each + (lambda (uri) + (and=> (follow-redirects-to-github uri) + (lambda (github-uri) + (emit-warning + package + (format #f (G_ "URL should be '~a'") github-uri) + 'source)))) + (origin-uris origin))))) + (define (check-derivation package) "Emit a warning if we fail to compile PACKAGE to a derivation." (define (try system) @@ -1055,6 +1090,10 @@ (define %checkers (name 'mirror-url) (description "Suggest 'mirror://' URLs") (check check-mirror-url)) + (lint-checker + (name 'github-uri) + (description "Suggest GitHub URIs") + (check check-github-url)) (lint-checker (name 'source-file-name) (description "Validate file names of sources") diff --git a/tests/lint.scm b/tests/lint.scm index 300153e24e..d4aa7c0e8e 100644 --- a/tests/lint.scm +++ b/tests/lint.scm @@ -6,6 +6,7 @@ ;;; Copyright © 2016 Hartmut Goebel ;;; Copyright © 2017 Alex Kost ;;; Copyright © 2017 Efraim Flashner +;;; Copyright © 2018 Arun Isaac ;;; ;;; This file is part of GNU Guix. ;;; @@ -669,6 +670,33 @@ (define-syntax-rule (with-warnings body ...) (check-mirror-url (dummy-package "x" (source source))))) "mirror://gnu/foo/foo.tar.gz")) +(test-assert "github-url" + (string-null? + (with-warnings + (with-http-server 200 %long-string + (check-github-url + (dummy-package "x" (source + (origin + (method url-fetch) + (uri (%local-url)) + (sha256 %null-sha256))))))))) + +(let ((github-url "https://github.com/foo/bar/bar-1.0.tar.gz")) + (test-assert "github-url: one suggestion" + (string-contains + (with-warnings + (with-http-server (301 `((location . ,(string->uri github-url)))) "" + (let ((initial-uri (%local-url))) + (parameterize ((%http-server-port (+ 1 (%http-server-port)))) + (with-http-server (302 `((location . ,(string->uri initial-uri)))) "" + (check-github-url + (dummy-package "x" (source + (origin + (method url-fetch) + (uri (%local-url)) + (sha256 %null-sha256)))))))))) + github-url))) + (test-assert "cve" (mock ((guix scripts lint) package-vulnerabilities (const '())) (string-null? -- cgit v1.2.3 From c39491829a0c1d870f8133b8f7a699152fc71503 Mon Sep 17 00:00:00 2001 From: Efraim Flashner Date: Wed, 19 Dec 2018 22:08:18 +0200 Subject: scripts: refresh: Allow searching recursively. * guix/scripts/refresh.scm (refresh-recursive, list-transitive): New procedures. (show-help): Document it. (guix-refresh): Add flags and checks for new options. * doc/guix.texi (Invoking guix refresh): Document new options. --- doc/guix.texi | 32 ++++++++++++++++++++++++++++ guix/scripts/refresh.scm | 55 ++++++++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 87 insertions(+) (limited to 'guix/scripts') diff --git a/doc/guix.texi b/doc/guix.texi index 2553ba7fe0..514ee3e6a8 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -7392,6 +7392,22 @@ are many packages, though, for which it lacks a method to determine whether a new upstream release is available. However, the mechanism is extensible, so feel free to get in touch with us to add a new method! +@table @code + +@item --recursive +Consider the packages specified, and all the packages upon which they depend. + +@example +$ guix refresh --recursive coreutils +gnu/packages/acl.scm:35:2: warning: no updater for acl +gnu/packages/m4.scm:30:12: info: 1.4.18 is already the latest version of m4 +gnu/packages/xml.scm:68:2: warning: no updater for expat +gnu/packages/multiprecision.scm:40:12: info: 6.1.2 is already the latest version of gmp +@dots{} +@end example + +@end table + Sometimes the upstream name differs from the package name used in Guix, and @command{guix refresh} needs a little help. Most updaters honor the @code{upstream-name} property in package definitions, which can be used @@ -7565,6 +7581,22 @@ hop@@2.4.0 geiser@@0.4 notmuch@@0.18 mu@@0.9.9.5 cflow@@1.4 idutils@@4.6 @dots{} The command above lists a set of packages that could be built to check for compatibility with an upgraded @code{flex} package. +@table @code + +@item --list-transitive +List all the packages which one or more packages depend upon. + +@example +$ guix refresh --list-transitive flex +flex@2.6.4 depends on the following 25 packages: perl@5.28.0 help2man@1.47.6 +bison@3.0.5 indent@2.2.10 tar@1.30 gzip@1.9 bzip2@1.0.6 xz@5.2.4 file@5.33 @dote{} +@end example + +@end table + +The command above lists a set of packages which, when changed, would cause +@code{flex} to be rebuilt. + The following options can be used to customize GnuPG operation: @table @code diff --git a/guix/scripts/refresh.scm b/guix/scripts/refresh.scm index 1d86f949c8..003c915da3 100644 --- a/guix/scripts/refresh.scm +++ b/guix/scripts/refresh.scm @@ -5,6 +5,7 @@ ;;; Copyright © 2015 Alex Kost ;;; Copyright © 2016 Ben Woodcroft ;;; Copyright © 2017 Mathieu Othacehe +;;; Copyright © 2018 Efraim Flashner ;;; ;;; This file is part of GNU Guix. ;;; @@ -40,6 +41,7 @@ (define-module (guix scripts refresh) #:use-module (ice-9 regex) #:use-module (ice-9 vlist) #:use-module (ice-9 format) + #:use-module (ice-9 threads) ; par-for-each #:use-module (srfi srfi-1) #:use-module (srfi srfi-11) #:use-module (srfi srfi-26) @@ -88,6 +90,12 @@ (define %options (option '(#\l "list-dependent") #f #f (lambda (opt name arg result) (alist-cons 'list-dependent? #t result))) + (option '(#\r "recursive") #f #f + (lambda (opt name arg result) + (alist-cons 'recursive? #t result))) + (option '("list-transitive") #f #f + (lambda (opt name arg result) + (alist-cons 'list-transitive? #t result))) (option '("keyring") #t #f (lambda (opt name arg result) @@ -140,6 +148,10 @@ (define (show-help) (display (G_ " -l, --list-dependent list top-level dependent packages that would need to be rebuilt as a result of upgrading PACKAGE...")) + (display (G_ " + -r, --recursive check the PACKAGE and its inputs for upgrades")) + (display (G_ " + --list-transitive list all the packages that PACKAGE depends on")) (newline) (display (G_ " --keyring=FILE use FILE as the keyring of upstream OpenPGP keys")) @@ -323,6 +335,43 @@ (define (full-name package) (map full-name covering)))) (return #t)))) +(define (refresh-recursive packages) + "Check all of the package inputs of PACKAGES for newer upstream versions." + (mlet %store-monad ((edges (node-edges %bag-node-type + ;; Here we don't want the -boot0 packages. + (fold-packages cons '())))) + (let ((dependent (node-transitive-edges packages edges))) + ;; par-for-each has an undefined return value, so packages which cause + ;; errors can be ignored. + (par-for-each (lambda (package) + (guix-refresh package)) + (map package-name dependent))) + (return #t))) + +(define (list-transitive packages) + "List all the packages that would cause PACKAGES to be rebuilt if they are changed." + ;; Using %BAG-NODE-TYPE is more accurate than using %PACKAGE-NODE-TYPE + ;; because it includes implicit dependencies. + (define (full-name package) + (string-append (package-name package) "@" + (package-version package))) + + (mlet %store-monad ((edges (node-edges %bag-node-type + ;; Here we don't want the -boot0 packages. + (fold-packages cons '())))) + (let ((dependent (node-transitive-edges packages edges))) + (match packages + ((x) + (format (current-output-port) + (G_ "~a depends on the following ~d packages: ~{~a~^ ~}~%.") + (full-name x) (length dependent) (map full-name dependent))) + (lst + (format (current-output-port) + (G_ "The following ~d packages \ +all are dependent packages: ~{~a~^ ~}~%") + (length dependent) (map full-name dependent)))) + (return #t)))) + ;;; ;;; Manifest. @@ -402,7 +451,9 @@ (define core-package? (let* ((opts (parse-options)) (update? (assoc-ref opts 'update?)) (updaters (options->updaters opts)) + (recursive? (assoc-ref opts 'recursive?)) (list-dependent? (assoc-ref opts 'list-dependent?)) + (list-transitive? (assoc-ref opts 'list-transitive?)) (key-download (assoc-ref opts 'key-download)) ;; Warn about missing updaters when a package is explicitly given on @@ -441,6 +492,10 @@ (define core-package? (cond (list-dependent? (list-dependents packages)) + (list-transitive? + (list-transitive packages)) + (recursive? + (refresh-recursive packages)) (update? (parameterize ((%openpgp-key-server (or (assoc-ref opts 'key-server) -- cgit v1.2.3 From ed7b44370f71126087eb953f36aad8dc4c44109f Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 24 Dec 2018 15:40:04 +0100 Subject: offload: Use (guix inferior) instead of (ssh dist node). Using inferiors and thus 'guix repl' simplifies setup on build machines (no need to worry about GUILE_LOAD_PATH etc.) Furthermore, the 'guix repl -t machine' protocol running in a remote pipe addresses several issues with the current implementation of nodes and RREPLs in Guile-SSH: fewer round trips, doesn't leave a 'guile --listen' process behind it, stateless (since a new process is started each time), more efficient (the SSH channel can be reused), more reliable (no 'pgrep', 'pkill', and shellology; see as an example.) * guix/ssh.scm (inferior-remote-eval): New procedure. (send-files): Use it instead of 'make-node' and 'node-eval'. * guix/scripts/offload.scm (node-guile-version): New procedure. (node-free-disk-space, transfer-and-offload, node-load) (choose-build-machine, assert-node-has-guix): Use 'remote-inferior' instead of 'make-node' and 'inferior-eval' instead of 'node-eval'. (assert-node-can-import, assert-node-can-export): Likewise, and add 'session' parameter. (check-machine-availability): Likewise, and add calls to 'close-inferior' and 'disconnect!'. (check-machine-status): Likewise. * doc/guix.texi (Daemon Offload Setup): Remove bit related to 'guile' in $PATH and $GUILE_LOAD_PATH; mention 'guix' alone. --- doc/guix.texi | 8 ++-- guix/scripts/offload.scm | 107 +++++++++++++++++++++++++---------------------- guix/ssh.scm | 34 ++++++++++----- 3 files changed, 83 insertions(+), 66 deletions(-) (limited to 'guix/scripts') diff --git a/doc/guix.texi b/doc/guix.texi index f86a2885a7..c182995b2b 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -1051,13 +1051,11 @@ name, and they will be scheduled on matching build machines. @end table @end deftp -The @code{guile} command must be in the search path on the build -machines. In addition, the Guix modules must be in -@code{$GUILE_LOAD_PATH} on the build machine---you can check whether -this is the case by running: +The @command{guix} command must be in the search path on the build +machines. You can check whether this is the case by running: @example -ssh build-machine guile -c "'(use-modules (guix config))'" +ssh build-machine guix repl --version @end example There is one last thing to do once @file{machines.scm} is in place. As diff --git a/guix/scripts/offload.scm b/guix/scripts/offload.scm index bfdaa3c011..b472d202a9 100644 --- a/guix/scripts/offload.scm +++ b/guix/scripts/offload.scm @@ -23,13 +23,12 @@ (define-module (guix scripts offload) #:use-module (ssh session) #:use-module (ssh channel) #:use-module (ssh popen) - #:use-module (ssh dist) - #:use-module (ssh dist node) #:use-module (ssh version) #:use-module (guix config) #:use-module (guix records) #:use-module (guix ssh) #:use-module (guix store) + #:use-module (guix inferior) #:use-module (guix derivations) #:use-module ((guix serialization) #:select (nar-error? nar-error-file)) @@ -321,12 +320,15 @@ (define (build-log-port) (set-port-revealed! port 1) port)) +(define (node-guile-version node) + (inferior-eval '(version) node)) + (define (node-free-disk-space node) "Return the free disk space, in bytes, in NODE's store." - (node-eval node - `(begin - (use-modules (guix build syscalls)) - (free-disk-space ,(%store-prefix))))) + (inferior-eval `(begin + (use-modules (guix build syscalls)) + (free-disk-space ,(%store-prefix))) + node)) (define* (transfer-and-offload drv machine #:key @@ -367,8 +369,12 @@ (define store (derivation-file-name drv) (build-machine-name machine) (nix-protocol-error-message c)) - (let* ((space (false-if-exception - (node-free-disk-space (make-node session))))) + (let* ((inferior (false-if-exception (remote-inferior session))) + (space (false-if-exception + (node-free-disk-space inferior)))) + + (when inferior + (close-inferior inferior)) ;; Use exit code 100 for a permanent build failure. The daemon ;; interprets other non-zero codes as transient build failures. @@ -417,11 +423,11 @@ (define %minimum-disk-space (define (node-load node) "Return the load on NODE. Return +∞ if NODE is misbehaving." - (let ((line (node-eval node - '(begin - (use-modules (ice-9 rdelim)) - (call-with-input-file "/proc/loadavg" - read-string))))) + (let ((line (inferior-eval '(begin + (use-modules (ice-9 rdelim)) + (call-with-input-file "/proc/loadavg" + read-string)) + node))) (if (eof-object? line) +inf.0 ;MACHINE does not respond, so assume it is infinitely loaded (match (string-tokenize line) @@ -508,9 +514,10 @@ (define (machine-faster? m1 m2) ;; Note: We call 'node-load' only as a last resort because it is ;; too costly to call it once for every machine. (let* ((session (false-if-exception (open-ssh-session best))) - (node (and session (make-node session))) + (node (and session (remote-inferior session))) (load (and node (normalized-load best (node-load node)))) (space (and node (node-free-disk-space node)))) + (when node (close-inferior node)) (when session (disconnect! session)) (if (and node (< load 2.) (>= space %minimum-disk-space)) (match others @@ -613,18 +620,17 @@ (define (assert-node-repl node name) (#f (report-guile-error name)) ((? string? version) - ;; Note: The version string already contains the word "Guile". - (info (G_ "'~a' is running ~a~%") + (info (G_ "'~a' is running GNU Guile ~a~%") name (node-guile-version node))))) (define (assert-node-has-guix node name) "Bail out if NODE lacks the (guix) module, or if its daemon is not running." (catch 'node-repl-error (lambda () - (match (node-eval node - '(begin - (use-modules (guix)) - (and add-text-to-store 'alright))) + (match (inferior-eval '(begin + (use-modules (guix)) + (and add-text-to-store 'alright)) + node) ('alright #t) (_ (report-module-error name)))) (lambda (key . args) @@ -632,12 +638,12 @@ (define (assert-node-has-guix node name) (catch 'node-repl-error (lambda () - (match (node-eval node - '(begin - (use-modules (guix)) - (with-store store - (add-text-to-store store "test" - "Hello, build machine!")))) + (match (inferior-eval '(begin + (use-modules (guix)) + (with-store store + (add-text-to-store store "test" + "Hello, build machine!"))) + node) ((? string? str) (info (G_ "Guix is usable on '~a' (test returned ~s)~%") name str)) @@ -656,25 +662,23 @@ (define* (nonce #:optional (name (gethostname))) (string-append name "-" (number->string (random 1000000 (force %random-state))))) -(define (assert-node-can-import node name daemon-socket) +(define (assert-node-can-import session node name daemon-socket) "Bail out if NODE refuses to import our archives." - (let ((session (node-session node))) - (with-store store - (let* ((item (add-text-to-store store "export-test" (nonce))) - (remote (connect-to-remote-daemon session daemon-socket))) - (with-store local - (send-files local (list item) remote)) - - (if (valid-path? remote item) - (info (G_ "'~a' successfully imported '~a'~%") - name item) - (leave (G_ "'~a' was not properly imported on '~a'~%") - item name)))))) - -(define (assert-node-can-export node name daemon-socket) + (with-store store + (let* ((item (add-text-to-store store "export-test" (nonce))) + (remote (connect-to-remote-daemon session daemon-socket))) + (with-store local + (send-files local (list item) remote)) + + (if (valid-path? remote item) + (info (G_ "'~a' successfully imported '~a'~%") + name item) + (leave (G_ "'~a' was not properly imported on '~a'~%") + item name))))) + +(define (assert-node-can-export session node name daemon-socket) "Bail out if we cannot import signed archives from NODE." - (let* ((session (node-session node)) - (remote (connect-to-remote-daemon session daemon-socket)) + (let* ((remote (connect-to-remote-daemon session daemon-socket)) (item (add-text-to-store remote "import-test" (nonce name)))) (with-store store (if (and (retrieve-files store (list item) remote) @@ -701,11 +705,13 @@ (define (build-machine=? m1 m2) (let* ((names (map build-machine-name machines)) (sockets (map build-machine-daemon-socket machines)) (sessions (map open-ssh-session machines)) - (nodes (map make-node sessions))) + (nodes (map remote-inferior sessions))) (for-each assert-node-repl nodes names) (for-each assert-node-has-guix nodes names) - (for-each assert-node-can-import nodes names sockets) - (for-each assert-node-can-export nodes names sockets)))) + (for-each assert-node-can-import sessions nodes names sockets) + (for-each assert-node-can-export sessions nodes names sockets) + (for-each close-inferior nodes) + (for-each disconnect! sessions)))) (define (check-machine-status machine-file pred) "Print the load of each machine matching PRED in MACHINE-FILE." @@ -722,10 +728,11 @@ (define (build-machine=? m1 m2) (length machines) machine-file) (for-each (lambda (machine) (let* ((session (open-ssh-session machine)) - (node (make-node session)) - (uts (node-eval node '(uname))) - (load (node-load node)) - (free (node-free-disk-space node))) + (inferior (remote-inferior session)) + (uts (inferior-eval '(uname) inferior)) + (load (node-load inferior)) + (free (node-free-disk-space inferior))) + (close-inferior inferior) (disconnect! session) (format #t "~a~% kernel: ~a ~a~% architecture: ~a~%\ host name: ~a~% normalized load: ~a~% free disk space: ~,2f MiB~%" diff --git a/guix/ssh.scm b/guix/ssh.scm index b8bea8028a..1ed8406633 100644 --- a/guix/ssh.scm +++ b/guix/ssh.scm @@ -27,8 +27,6 @@ (define-module (guix ssh) #:use-module (ssh channel) #:use-module (ssh popen) #:use-module (ssh session) - #:use-module (ssh dist) - #:use-module (ssh dist node) #:use-module (srfi srfi-1) #:use-module (srfi srfi-11) #:use-module (srfi srfi-26) @@ -102,6 +100,20 @@ (define (remote-inferior session) "guix" "repl" "-t" "machine"))) (port->inferior pipe))) +(define (inferior-remote-eval exp session) + "Evaluate EXP in a new inferior running in SESSION, and close the inferior +right away." + (let ((inferior (remote-inferior session))) + (dynamic-wind + (const #t) + (lambda () + (inferior-eval exp inferior)) + (lambda () + ;; Close INFERIOR right away to prevent finalization from happening in + ;; another thread at the wrong time (see + ;; .) + (close-inferior inferior))))) + (define* (remote-daemon-channel session #:optional (socket-name @@ -277,15 +289,15 @@ (define* (send-files local files remote ;; Compute the subset of FILES missing on SESSION and send them. (let* ((files (if recursive? (requisites local files) files)) (session (channel-get-session (nix-server-socket remote))) - (node (make-node session)) - (missing (node-eval node - `(begin - (use-modules (guix) - (srfi srfi-1) (srfi srfi-26)) - - (with-store store - (remove (cut valid-path? store <>) - ',files))))) + (missing (inferior-remote-eval + `(begin + (use-modules (guix) + (srfi srfi-1) (srfi srfi-26)) + + (with-store store + (remove (cut valid-path? store <>) + ',files))) + session)) (count (length missing)) (sizes (map (lambda (item) (path-info-nar-size (query-path-info local item))) -- cgit v1.2.3 From 10b2834f82b7502dc2dc733d39d97f9ff2d07564 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 25 Dec 2018 17:03:37 +0100 Subject: offload: Adjust 'test' and 'status' to the latest changes. This is a followup to ed7b44370f71126087eb953f36aad8dc4c44109f; following that commit, 'guix offload test' and 'guix offload status' would abort with a backtrace instead of clearly diagnosing a missing 'guix' command on the build machine. * guix/scripts/offload.scm (assert-node-has-guix): Call 'leave' when NODE is not an inferior. Remove 'catch' blocks for 'node-repl-error'. (check-machine-availability): Invoke 'assert-node-has-guix' first. (check-machine-status): Print a warning when 'remote-inferior' returns #f. --- guix/scripts/offload.scm | 90 +++++++++++++++++++++++++----------------------- 1 file changed, 46 insertions(+), 44 deletions(-) (limited to 'guix/scripts') diff --git a/guix/scripts/offload.scm b/guix/scripts/offload.scm index b472d202a9..dcdccc80e0 100644 --- a/guix/scripts/offload.scm +++ b/guix/scripts/offload.scm @@ -624,35 +624,30 @@ (define (assert-node-repl node name) name (node-guile-version node))))) (define (assert-node-has-guix node name) - "Bail out if NODE lacks the (guix) module, or if its daemon is not running." - (catch 'node-repl-error - (lambda () - (match (inferior-eval '(begin - (use-modules (guix)) - (and add-text-to-store 'alright)) - node) - ('alright #t) - (_ (report-module-error name)))) - (lambda (key . args) - (report-module-error name))) - - (catch 'node-repl-error - (lambda () - (match (inferior-eval '(begin - (use-modules (guix)) - (with-store store - (add-text-to-store store "test" - "Hello, build machine!"))) - node) - ((? string? str) - (info (G_ "Guix is usable on '~a' (test returned ~s)~%") - name str)) - (x - (leave (G_ "failed to talk to guix-daemon on '~a' (test returned ~s)~%") - name x)))) - (lambda (key . args) - (leave (G_ "remote evaluation on '~a' failed:~{ ~s~}~%") - name args)))) + "Bail out if NODE if #f or if we fail to use the (guix) module, or if its +daemon is not running." + (unless (inferior? node) + (leave (G_ "failed to run 'guix repl' on '~a'~%") name)) + + (match (inferior-eval '(begin + (use-modules (guix)) + (and add-text-to-store 'alright)) + node) + ('alright #t) + (_ (report-module-error name))) + + (match (inferior-eval '(begin + (use-modules (guix)) + (with-store store + (add-text-to-store store "test" + "Hello, build machine!"))) + node) + ((? string? str) + (info (G_ "Guix is usable on '~a' (test returned ~s)~%") + name str)) + (x + (leave (G_ "failed to talk to guix-daemon on '~a' (test returned ~s)~%") + name x)))) (define %random-state (delay @@ -706,8 +701,8 @@ (define (build-machine=? m1 m2) (sockets (map build-machine-daemon-socket machines)) (sessions (map open-ssh-session machines)) (nodes (map remote-inferior sessions))) - (for-each assert-node-repl nodes names) (for-each assert-node-has-guix nodes names) + (for-each assert-node-repl nodes names) (for-each assert-node-can-import sessions nodes names sockets) (for-each assert-node-can-export sessions nodes names sockets) (for-each close-inferior nodes) @@ -727,21 +722,28 @@ (define (build-machine=? m1 m2) (info (G_ "getting status of ~a build machines defined in '~a'...~%") (length machines) machine-file) (for-each (lambda (machine) - (let* ((session (open-ssh-session machine)) - (inferior (remote-inferior session)) - (uts (inferior-eval '(uname) inferior)) - (load (node-load inferior)) - (free (node-free-disk-space inferior))) - (close-inferior inferior) - (disconnect! session) - (format #t "~a~% kernel: ~a ~a~% architecture: ~a~%\ + (define session + (open-ssh-session machine)) + + (match (remote-inferior session) + (#f + (warning (G_ "failed to run 'guix repl' on machine '~a'~%") + (build-machine-name machine))) + ((? inferior? inferior) + (let ((uts (inferior-eval '(uname) inferior)) + (load (node-load inferior)) + (free (node-free-disk-space inferior))) + (close-inferior inferior) + (format #t "~a~% kernel: ~a ~a~% architecture: ~a~%\ host name: ~a~% normalized load: ~a~% free disk space: ~,2f MiB~%" - (build-machine-name machine) - (utsname:sysname uts) (utsname:release uts) - (utsname:machine uts) - (utsname:nodename uts) - (normalized-load machine load) - (/ free (expt 2 20) 1.)))) + (build-machine-name machine) + (utsname:sysname uts) (utsname:release uts) + (utsname:machine uts) + (utsname:nodename uts) + (normalized-load machine load) + (/ free (expt 2 20) 1.))))) + + (disconnect! session)) machines))) -- cgit v1.2.3 From 7f4d102c2fff9ff60cd7bc69f5e7eb694274baae Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 26 Dec 2018 17:30:56 +0100 Subject: offload: Remove the "machine choice" lock. This lock was unnecessary and it led to a contention when many 'guix offload' processes are polling for available machines. * guix/scripts/offload.scm (machine-choice-lock-file): Remove. (choose-build-machine): Remove surrounding 'with-file-lock (machine-lock-file)'. --- guix/scripts/offload.scm | 119 ++++++++++++++++++++++------------------------- 1 file changed, 56 insertions(+), 63 deletions(-) (limited to 'guix/scripts') diff --git a/guix/scripts/offload.scm b/guix/scripts/offload.scm index dcdccc80e0..f90f9e92fa 100644 --- a/guix/scripts/offload.scm +++ b/guix/scripts/offload.scm @@ -453,10 +453,6 @@ (define (machine-lock-file machine hint) (build-machine-name machine) "." (symbol->string hint) ".lock")) -(define (machine-choice-lock-file) - "Return the name of the file used as a lock when choosing a build machine." - (string-append %state-directory "/offload/machine-choice.lock")) - (define (random-seed) (logxor (getpid) (car (gettimeofday)))) @@ -479,67 +475,64 @@ (define (choose-build-machine machines) slot (which must later be released with 'release-build-slot'), or #f and #f." ;; Proceed like this: - ;; 1. Acquire the global machine-choice lock. - ;; 2. For all MACHINES, attempt to acquire a build slot, and filter out + ;; 1. For all MACHINES, attempt to acquire a build slot, and filter out ;; those machines for which we failed. - ;; 3. Choose the best machine among those that are left. - ;; 4. Release the previously-acquired build slots of the other machines. - ;; 5. Release the global machine-choice lock. - - (with-file-lock (machine-choice-lock-file) - (define machines+slots - (filter-map (lambda (machine) - (let ((slot (acquire-build-slot machine))) - (and slot (list machine slot)))) - (shuffle machines))) - - (define (undecorate pred) - (lambda (a b) - (match a - ((machine1 slot1) - (match b - ((machine2 slot2) - (pred machine1 machine2))))))) - - (define (machine-faster? m1 m2) - ;; Return #t if M1 is faster than M2. - (> (build-machine-speed m1) - (build-machine-speed m2))) - - (let loop ((machines+slots - (sort machines+slots (undecorate machine-faster?)))) - (match machines+slots - (((best slot) others ...) - ;; Return the best machine unless it's already overloaded. - ;; Note: We call 'node-load' only as a last resort because it is - ;; too costly to call it once for every machine. - (let* ((session (false-if-exception (open-ssh-session best))) - (node (and session (remote-inferior session))) - (load (and node (normalized-load best (node-load node)))) - (space (and node (node-free-disk-space node)))) - (when node (close-inferior node)) - (when session (disconnect! session)) - (if (and node (< load 2.) (>= space %minimum-disk-space)) - (match others - (((machines slots) ...) - ;; Release slots from the uninteresting machines. - (for-each release-build-slot slots) - - ;; The caller must keep SLOT to protect it from GC and to - ;; eventually release it. - (values best slot))) - (begin - ;; BEST is unsuitable, so try the next one. - (when (and space (< space %minimum-disk-space)) - (format (current-error-port) - "skipping machine '~a' because it is low \ + ;; 2. Choose the best machine among those that are left. + ;; 3. Release the previously-acquired build slots of the other machines. + + (define machines+slots + (filter-map (lambda (machine) + (let ((slot (acquire-build-slot machine))) + (and slot (list machine slot)))) + (shuffle machines))) + + (define (undecorate pred) + (lambda (a b) + (match a + ((machine1 slot1) + (match b + ((machine2 slot2) + (pred machine1 machine2))))))) + + (define (machine-faster? m1 m2) + ;; Return #t if M1 is faster than M2. + (> (build-machine-speed m1) + (build-machine-speed m2))) + + (let loop ((machines+slots + (sort machines+slots (undecorate machine-faster?)))) + (match machines+slots + (((best slot) others ...) + ;; Return the best machine unless it's already overloaded. + ;; Note: We call 'node-load' only as a last resort because it is + ;; too costly to call it once for every machine. + (let* ((session (false-if-exception (open-ssh-session best))) + (node (and session (remote-inferior session))) + (load (and node (normalized-load best (node-load node)))) + (space (and node (node-free-disk-space node)))) + (when node (close-inferior node)) + (when session (disconnect! session)) + (if (and node (< load 2.) (>= space %minimum-disk-space)) + (match others + (((machines slots) ...) + ;; Release slots from the uninteresting machines. + (for-each release-build-slot slots) + + ;; The caller must keep SLOT to protect it from GC and to + ;; eventually release it. + (values best slot))) + (begin + ;; BEST is unsuitable, so try the next one. + (when (and space (< space %minimum-disk-space)) + (format (current-error-port) + "skipping machine '~a' because it is low \ on disk space (~,2f MiB free)~%" - (build-machine-name best) - (/ space (expt 2 20) 1.))) - (release-build-slot slot) - (loop others))))) - (() - (values #f #f)))))) + (build-machine-name best) + (/ space (expt 2 20) 1.))) + (release-build-slot slot) + (loop others))))) + (() + (values #f #f))))) (define (call-with-timeout timeout drv thunk) "Call THUNK and leave after TIMEOUT seconds. If TIMEOUT is #f, simply call -- cgit v1.2.3 From 0ef595b99689a4d80521abd87fa893695c7f75df Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 26 Dec 2018 17:42:02 +0100 Subject: offload: Remove unnecessary locking on machine slots. This extra level of locking turned out to be unnecessary. * guix/scripts/offload.scm (with-machine-lock): Remove. (machine-lock-file): Remove. (acquire-build-slot): Remove surrounding 'with-machine-lock'. --- guix/scripts/offload.scm | 50 ++++++++++++++++++------------------------------ 1 file changed, 19 insertions(+), 31 deletions(-) (limited to 'guix/scripts') diff --git a/guix/scripts/offload.scm b/guix/scripts/offload.scm index f90f9e92fa..30fe69ad6d 100644 --- a/guix/scripts/offload.scm +++ b/guix/scripts/offload.scm @@ -260,13 +260,6 @@ (define-syntax-rule (with-file-lock file exp ...) (lambda () (unlock-file port))))) -(define-syntax-rule (with-machine-lock machine hint exp ...) - "Wait to acquire MACHINE's exclusive lock for HINT, and evaluate EXP in that -context." - (with-file-lock (machine-lock-file machine hint) - exp ...)) - - (define (machine-slot-file machine slot) "Return the file name of MACHINE's file for SLOT." ;; For each machine we have a bunch of files representing each build slot. @@ -284,23 +277,25 @@ (define (acquire-build-slot machine) This mechanism allows us to set a hard limit on the number of simultaneous connections allowed to MACHINE." (mkdir-p (dirname (machine-slot-file machine 0))) - (with-machine-lock machine 'slots - (any (lambda (slot) - (let ((port (open-file (machine-slot-file machine slot) - "w0"))) - (catch 'flock-error - (lambda () - (fcntl-flock port 'write-lock #:wait? #f) - ;; Got it! - (format (current-error-port) - "process ~a acquired build slot '~a'~%" - (getpid) (port-filename port)) - port) - (lambda args - ;; PORT is already locked by another process. - (close-port port) - #f)))) - (iota (build-machine-parallel-builds machine))))) + + ;; When several 'guix offload' processes run in parallel, there's a race + ;; among them, but since they try the slots in the same order, we're fine. + (any (lambda (slot) + (let ((port (open-file (machine-slot-file machine slot) + "w0"))) + (catch 'flock-error + (lambda () + (fcntl-flock port 'write-lock #:wait? #f) + ;; Got it! + (format (current-error-port) + "process ~a acquired build slot '~a'~%" + (getpid) (port-filename port)) + port) + (lambda args + ;; PORT is already locked by another process. + (close-port port) + #f)))) + (iota (build-machine-parallel-builds machine)))) (define (release-build-slot slot) "Release SLOT, a build slot as returned as by 'acquire-build-slot'." @@ -447,12 +442,6 @@ (define (normalized-load machine load) normalized) load)) -(define (machine-lock-file machine hint) - "Return the name of MACHINE's lock file for HINT." - (string-append %state-directory "/offload/" - (build-machine-name machine) - "." (symbol->string hint) ".lock")) - (define (random-seed) (logxor (getpid) (car (gettimeofday)))) @@ -827,7 +816,6 @@ (define not-coma (leave (G_ "invalid arguments: ~{~s ~}~%") x)))) ;;; Local Variables: -;;; eval: (put 'with-machine-lock 'scheme-indent-function 2) ;;; eval: (put 'with-file-lock 'scheme-indent-function 1) ;;; eval: (put 'with-error-to-port 'scheme-indent-function 1) ;;; eval: (put 'with-timeout 'scheme-indent-function 2) -- cgit v1.2.3 From 5923102f7b58f0a0120926ec5b81ed48b26a188e Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 27 Dec 2018 11:54:55 +0100 Subject: pull: Add '--system'. * guix/scripts/pull.scm (%options): Add '--system'. (guix-pull): Honor it. * doc/guix.texi (Invoking guix pull): Document it. --- doc/guix.texi | 5 +++++ guix/scripts/pull.scm | 7 ++++++- 2 files changed, 11 insertions(+), 1 deletion(-) (limited to 'guix/scripts') diff --git a/doc/guix.texi b/doc/guix.texi index c182995b2b..20952e9a36 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -2887,6 +2887,11 @@ Use @var{profile} instead of @file{~/.config/guix/current}. Show which channel commit(s) would be used and what would be built or substituted but do not actually do it. +@item --system=@var{system} +@itemx -s @var{system} +Attempt to build for @var{system}---e.g., @code{i686-linux}---instead of +the system type of the build host. + @item --verbose Produce verbose output, writing build logs to the standard error output. diff --git a/guix/scripts/pull.scm b/guix/scripts/pull.scm index dc83729911..862556d12b 100644 --- a/guix/scripts/pull.scm +++ b/guix/scripts/pull.scm @@ -126,6 +126,10 @@ (define %options (lambda (opt name arg result) (alist-cons 'profile (canonicalize-profile arg) result))) + (option '(#\s "system") #t #f + (lambda (opt name arg result) + (alist-cons 'system arg + (alist-delete 'system result eq?)))) (option '(#\n "dry-run") #f #f (lambda (opt name arg result) (alist-cons 'dry-run? #t (alist-cons 'graft? #f result)))) @@ -505,7 +509,8 @@ (define (guix-pull . args) (else (with-store store (with-status-report print-build-event - (parameterize ((%graft? (assoc-ref opts 'graft?)) + (parameterize ((%current-system (assoc-ref opts 'system)) + (%graft? (assoc-ref opts 'graft?)) (%repository-cache-directory cache)) (set-build-options-from-command-line store opts) (honor-x509-certificates store) -- cgit v1.2.3 From c180017b6f7e9b6d23238c1fbaac986c435cd35e Mon Sep 17 00:00:00 2001 From: Efraim Flashner Date: Tue, 25 Dec 2018 16:29:12 +0200 Subject: lint: Check for unstable tarballs. * guix/scripts/lint.scm (check-source-unstable-tarball): New procedure. (%checkers): Add it. * tests/lint.scm ("source-unstable-tarball", "source-unstable-tarball: source #f", "source-unstable-tarball: valid", "source-unstable-tarball: package named archive", "source-unstable-tarball: not-github", "source-unstable-tarball: git-fetch"): New tests. * doc/guix.texi (Invoking guix lint): Document it. --- doc/guix.texi | 5 ++++ guix/scripts/lint.scm | 23 ++++++++++++++- tests/lint.scm | 80 +++++++++++++++++++++++++++++++++++++++++++++++++++ 3 files changed, 107 insertions(+), 1 deletion(-) (limited to 'guix/scripts') diff --git a/doc/guix.texi b/doc/guix.texi index 20952e9a36..fcb5b8c088 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -7704,6 +7704,11 @@ URL. Check that the source file name is meaningful, e.g.@: is not just a version number or ``git-checkout'', without a declared @code{file-name} (@pxref{origin Reference}). +@item source-unstable-tarball +Parse the @code{source} URL to determine if a tarball from GitHub is +autogenerated or if it is a release tarball. Unfortunately GitHub's +autogenerated tarballs are sometimes regenerated. + @item cve @cindex security vulnerabilities @cindex CVE, Common Vulnerabilities and Exposures diff --git a/guix/scripts/lint.scm b/guix/scripts/lint.scm index 354f6f7031..2c1c7ec669 100644 --- a/guix/scripts/lint.scm +++ b/guix/scripts/lint.scm @@ -7,7 +7,7 @@ ;;; Copyright © 2016 Hartmut Goebel ;;; Copyright © 2017 Alex Kost ;;; Copyright © 2017 Tobias Geerinckx-Rice -;;; Copyright © 2017 Efraim Flashner +;;; Copyright © 2017, 2018 Efraim Flashner ;;; Copyright © 2018 Arun Isaac ;;; ;;; This file is part of GNU Guix. @@ -76,6 +76,7 @@ (define-module (guix scripts lint) check-home-page check-source check-source-file-name + check-source-unstable-tarball check-mirror-url check-github-url check-license @@ -752,6 +753,22 @@ (define (origin-file-name-valid? origin) (G_ "the source file name should contain the package name") 'source)))) +(define (check-source-unstable-tarball package) + "Emit a warning if PACKAGE's source is an autogenerated tarball." + (define (check-source-uri uri) + (when (and (string=? (uri-host (string->uri uri)) "github.com") + (string=? (third (split-and-decode-uri-path + (uri-path (string->uri uri)))) + "archive")) + (emit-warning package + (G_ "the source URI should not be an autogenerated tarball") + 'source))) + (let ((origin (package-source package))) + (when (and (origin? origin) + (eqv? (origin-method origin) url-fetch)) + (let ((uris (origin-uris origin))) + (for-each check-source-uri uris))))) + (define (check-mirror-url package) "Check whether PACKAGE uses source URLs that should be 'mirror://'." (define (check-mirror-uri uri) ;XXX: could be optimized @@ -1098,6 +1115,10 @@ (define %checkers (name 'source-file-name) (description "Validate file names of sources") (check check-source-file-name)) + (lint-checker + (name 'source-unstable-tarball) + (description "Check for autogenerated tarballs") + (check check-source-unstable-tarball)) (lint-checker (name 'derivation) (description "Report failure to compile a package to a derivation") diff --git a/tests/lint.scm b/tests/lint.scm index d4aa7c0e8e..fe12bebd88 100644 --- a/tests/lint.scm +++ b/tests/lint.scm @@ -572,6 +572,86 @@ (define-syntax-rule (with-warnings body ...) (check-source-file-name pkg))) "file name should contain the package name")))) +(test-assert "source-unstable-tarball" + (string-contains + (with-warnings + (let ((pkg (dummy-package "x" + (source + (origin + (method url-fetch) + (uri "https://github.com/example/example/archive/v0.0.tar.gz") + (sha256 %null-sha256)))))) + (check-source-unstable-tarball pkg))) + "source URI should not be an autogenerated tarball")) + +(test-assert "source-unstable-tarball: source #f" + (not + (->bool + (string-contains + (with-warnings + (let ((pkg (dummy-package "x" + (source #f)))) + (check-source-unstable-tarball pkg))) + "source URI should not be an autogenerated tarball")))) + +(test-assert "source-unstable-tarball: valid" + (not + (->bool + (string-contains + (with-warnings + (let ((pkg (dummy-package "x" + (source + (origin + (method url-fetch) + (uri "https://github.com/example/example/releases/download/x-0.0/x-0.0.tar.gz") + (sha256 %null-sha256)))))) + (check-source-unstable-tarball pkg))) + "source URI should not be an autogenerated tarball")))) + +(test-assert "source-unstable-tarball: package named archive" + (not + (->bool + (string-contains + (with-warnings + (let ((pkg (dummy-package "x" + (source + (origin + (method url-fetch) + (uri "https://github.com/example/archive/releases/download/x-0.0/x-0.0.tar.gz") + (sha256 %null-sha256)))))) + (check-source-unstable-tarball pkg))) + "source URI should not be an autogenerated tarball")))) + +(test-assert "source-unstable-tarball: not-github" + (not + (->bool + (string-contains + (with-warnings + (let ((pkg (dummy-package "x" + (source + (origin + (method url-fetch) + (uri "https://bitbucket.org/archive/example/download/x-0.0.tar.gz") + (sha256 %null-sha256)))))) + (check-source-unstable-tarball pkg))) + "source URI should not be an autogenerated tarball")))) + +(test-assert "source-unstable-tarball: git-fetch" + (not + (->bool + (string-contains + (with-warnings + (let ((pkg (dummy-package "x" + (source + (origin + (method git-fetch) + (uri (git-reference + (url "https://github.com/archive/example.git") + (commit "0"))) + (sha256 %null-sha256)))))) + (check-source-unstable-tarball pkg))) + "source URI should not be an autogenerated tarball")))) + (test-skip (if (http-server-can-listen?) 0 1)) (test-equal "source: 200" "" -- cgit v1.2.3 From ec651f2562241064db7dd0d2a181cd85c787b541 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sat, 5 Jan 2019 00:04:12 +0100 Subject: guix build: Honor '--system' for file-like objects and gexps. Fixes a bug whereby "guix build -f file.scm -s SYSTEM" would not honor SYSTEM when 'file.scm' returns a gexp or a file-like object. * guix/scripts/build.scm (options->derivations): Pass #:system to 'run-with-store' in the 'file-like?' and 'gexp?' cases. --- guix/scripts/build.scm | 8 +++++--- 1 file changed, 5 insertions(+), 3 deletions(-) (limited to 'guix/scripts') diff --git a/guix/scripts/build.scm b/guix/scripts/build.scm index 0b7da3189e..564bdf0ced 100644 --- a/guix/scripts/build.scm +++ b/guix/scripts/build.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018 Ludovic Courtès +;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019 Ludovic Courtès ;;; Copyright © 2013 Mark H Weaver ;;; ;;; This file is part of GNU Guix. @@ -788,13 +788,15 @@ (define graft? (assoc-ref opts 'graft?)) ((? file-like? obj) (list (run-with-store store (lower-object obj system - #:target (assoc-ref opts 'target))))) + #:target (assoc-ref opts 'target)) + #:system system))) ((? gexp? gexp) (list (run-with-store store (mbegin %store-monad (set-guile-for-build (default-guile)) (gexp->derivation "gexp" gexp - #:system system)))))) + #:system system)) + #:system system)))) (map (cut transform store <>) (options->things-to-build opts)))))) -- cgit v1.2.3 From 012bf5c4c03e30633f137960bd0677e204c638a7 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sun, 6 Jan 2019 00:21:14 +0100 Subject: lint: Rename checker to 'github-url'. * guix/scripts/lint.scm (%checkers): Rename 'github-uri' to 'github-url' to match the documentation. --- guix/scripts/lint.scm | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) (limited to 'guix/scripts') diff --git a/guix/scripts/lint.scm b/guix/scripts/lint.scm index 2c1c7ec669..040480c1ac 100644 --- a/guix/scripts/lint.scm +++ b/guix/scripts/lint.scm @@ -1,7 +1,7 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2014 Cyril Roelandt ;;; Copyright © 2014, 2015 Eric Bavier -;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018 Ludovic Courtès +;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018, 2019 Ludovic Courtès ;;; Copyright © 2015, 2016 Mathieu Lirzin ;;; Copyright © 2016 Danny Milosavljevic ;;; Copyright © 2016 Hartmut Goebel @@ -1108,8 +1108,8 @@ (define %checkers (description "Suggest 'mirror://' URLs") (check check-mirror-url)) (lint-checker - (name 'github-uri) - (description "Suggest GitHub URIs") + (name 'github-url) + (description "Suggest GitHub URLs") (check check-github-url)) (lint-checker (name 'source-file-name) -- cgit v1.2.3 From 54ddb6a154082ecd41d50236d49a267697ff0f4e Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 7 Jan 2019 13:55:32 +0100 Subject: lint: Avoid 'dirname' call at the top level. * guix/scripts/lint.scm (%distro-directory): Wrap in 'mlambda'. (check-patch-file-names): Adjust accordingly. --- guix/scripts/lint.scm | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) (limited to 'guix/scripts') diff --git a/guix/scripts/lint.scm b/guix/scripts/lint.scm index 040480c1ac..9acec48577 100644 --- a/guix/scripts/lint.scm +++ b/guix/scripts/lint.scm @@ -595,7 +595,8 @@ (define (check-home-page package) 'home-page))))) (define %distro-directory - (dirname (search-path %load-path "gnu.scm"))) + (mlambda () + (dirname (search-path %load-path "gnu.scm")))) (define (check-patch-file-names package) "Emit a warning if the patches requires by PACKAGE are badly named or if the @@ -620,12 +621,12 @@ (define patches 'patch-file-names)) ;; Check whether we're reaching tar's maximum file name length. - (let ((prefix (string-length %distro-directory)) + (let ((prefix (string-length (%distro-directory))) (margin (string-length "guix-0.13.0-10-123456789/")) (max 99)) (for-each (match-lambda ((? string? patch) - (when (> (+ margin (if (string-prefix? %distro-directory + (when (> (+ margin (if (string-prefix? (%distro-directory) patch) (- (string-length patch) prefix) (string-length patch))) -- cgit v1.2.3 From 6090b0beb035e53449ea344506b76dcc2de8ca0d Mon Sep 17 00:00:00 2001 From: Julien Lepiller Date: Wed, 19 Dec 2018 22:43:43 +0100 Subject: import: opam: Add recursive option. * guix/script/import/opam.scm: Add recursive option. * guix/import/opam.scm (opam->guix-package): return two values. (opam-recursive-import): New variable. --- guix/import/opam.scm | 70 +++++++++++++++++++++++++++++--------------- guix/scripts/import/opam.scm | 27 +++++++++++++---- 2 files changed, 69 insertions(+), 28 deletions(-) (limited to 'guix/scripts') diff --git a/guix/import/opam.scm b/guix/import/opam.scm index c42a5d767d..cdf05e7d25 100644 --- a/guix/import/opam.scm +++ b/guix/import/opam.scm @@ -33,7 +33,8 @@ (define-module (guix import opam) #:use-module (guix utils) #:use-module (guix import utils) #:use-module ((guix licenses) #:prefix license:) - #:export (opam->guix-package)) + #:export (opam->guix-package + opam-recursive-import)) ;; Define a PEG parser for the opam format (define-peg-pattern SP none (or " " "\n")) @@ -128,7 +129,6 @@ (define (ocaml-name->guix-name name) (else (string-append "ocaml-" name)))) (define (metadata-ref file lookup) - (pk 'file file 'lookup lookup) (fold (lambda (record acc) (match record ((record key val) @@ -166,6 +166,21 @@ (define (dependency->native-input dependency) (('conditional-value val condition) (if (native? condition) (dependency->input val) "")))) +(define (dependency->name dependency) + (match dependency + (('string-pat str) str) + (('conditional-value val condition) + (dependency->name val)))) + +(define (dependency-list->names lst) + (filter + (lambda (name) + (not (or + (string-prefix? "conf-" name) + (equal? name "ocaml") + (equal? name "findlib")))) + (map dependency->name lst))) + (define (ocaml-names->guix-names names) (map ocaml-name->guix-name (remove (lambda (name) @@ -193,32 +208,41 @@ (define (dependency-list->inputs lst) (define (opam->guix-package name) (and-let* ((repository (get-opam-repository)) (version (find-latest-version name repository)) - (file (string-append repository "/packages/" name "/" name "." (pk 'version version) "/opam")) + (file (string-append repository "/packages/" name "/" name "." version "/opam")) (opam-content (get-metadata file)) - (url-dict (metadata-ref (pk 'metadata opam-content) "url")) + (url-dict (metadata-ref opam-content "url")) (source-url (metadata-ref url-dict "src")) (requirements (metadata-ref opam-content "depends")) + (dependencies (dependency-list->names requirements)) (inputs (dependency-list->inputs (depends->inputs requirements))) (native-inputs (dependency-list->inputs (depends->native-inputs requirements)))) (call-with-temporary-output-file (lambda (temp port) (and (url-fetch source-url temp) - `(package - (name ,(ocaml-name->guix-name name)) - (version ,(metadata-ref opam-content "version")) - (source - (origin - (method url-fetch) - (uri ,source-url) - (sha256 (base32 ,(guix-hash-url temp))))) - (build-system ocaml-build-system) - ,@(if (null? inputs) - '() - `((inputs ,(list 'quasiquote inputs)))) - ,@(if (null? native-inputs) - '() - `((native-inputs ,(list 'quasiquote native-inputs)))) - (home-page ,(metadata-ref opam-content "homepage")) - (synopsis ,(metadata-ref opam-content "synopsis")) - (description ,(metadata-ref opam-content "description")) - (license #f))))))) + (values + `(package + (name ,(ocaml-name->guix-name name)) + (version ,(metadata-ref opam-content "version")) + (source + (origin + (method url-fetch) + (uri ,source-url) + (sha256 (base32 ,(guix-hash-url temp))))) + (build-system ocaml-build-system) + ,@(if (null? inputs) + '() + `((inputs ,(list 'quasiquote inputs)))) + ,@(if (null? native-inputs) + '() + `((native-inputs ,(list 'quasiquote native-inputs)))) + (home-page ,(metadata-ref opam-content "homepage")) + (synopsis ,(metadata-ref opam-content "synopsis")) + (description ,(metadata-ref opam-content "description")) + (license #f)) + dependencies)))))) + +(define (opam-recursive-import package-name) + (recursive-import package-name #f + #:repo->guix-package (lambda (name repo) + (opam->guix-package name)) + #:guix-name ocaml-name->guix-name)) diff --git a/guix/scripts/import/opam.scm b/guix/scripts/import/opam.scm index b549878742..2d249a213f 100644 --- a/guix/scripts/import/opam.scm +++ b/guix/scripts/import/opam.scm @@ -25,6 +25,7 @@ (define-module (guix scripts import opam) #:use-module (srfi srfi-1) #:use-module (srfi srfi-11) #:use-module (srfi srfi-37) + #:use-module (srfi srfi-41) #:use-module (ice-9 match) #:use-module (ice-9 format) #:export (guix-import-opam)) @@ -43,6 +44,8 @@ (define (show-help) (display (G_ " -h, --help display this help and exit")) (display (G_ " + -r, --recursive import packages recursively")) + (display (G_ " -V, --version display version information and exit")) (newline) (show-bug-report-information)) @@ -56,6 +59,9 @@ (define %options (option '(#\V "version") #f #f (lambda args (show-version-and-exit "guix import opam"))) + (option '(#\r "recursive") #f #f + (lambda (opt name arg result) + (alist-cons 'recursive #t result))) %standard-import-options)) @@ -81,11 +87,22 @@ (define (parse-options) (reverse opts)))) (match args ((package-name) - (let ((sexp (opam->guix-package package-name))) - (unless sexp - (leave (G_ "failed to download meta-data for package '~a'~%") - package-name)) - sexp)) + (if (assoc-ref opts 'recursive) + ;; Recursive import + (map (match-lambda + ((and ('package ('name name) . rest) pkg) + `(define-public ,(string->symbol name) + ,pkg)) + (_ #f)) + (reverse + (stream->list + (opam-recursive-import package-name)))) + ;; Single import + (let ((sexp (opam->guix-package package-name))) + (unless sexp + (leave (G_ "failed to download meta-data for package '~a'~%") + package-name)) + sexp))) (() (leave (G_ "too few arguments~%"))) ((many ...) -- cgit v1.2.3 From a21a906fcd31c918431622f7ac56b21c269368fb Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 8 Jan 2019 18:17:22 +0100 Subject: pull: Document '--system'. Fixes . Reported by Alex Kost . This is a followup to 5923102f7b58f0a0120926ec5b81ed48b26a188e. * guix/scripts/pull.scm (show-help): Add '--system'. --- guix/scripts/pull.scm | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) (limited to 'guix/scripts') diff --git a/guix/scripts/pull.scm b/guix/scripts/pull.scm index 862556d12b..e7ff44c0d5 100644 --- a/guix/scripts/pull.scm +++ b/guix/scripts/pull.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2013, 2014, 2015, 2017, 2018 Ludovic Courtès +;;; Copyright © 2013, 2014, 2015, 2017, 2018, 2019 Ludovic Courtès ;;; Copyright © 2017 Marius Bakke ;;; ;;; This file is part of GNU Guix. @@ -88,6 +88,8 @@ (define (show-help) -p, --profile=PROFILE use PROFILE instead of ~/.config/guix/current")) (display (G_ " -n, --dry-run show what would be pulled and built")) + (display (G_ " + -s, --system=SYSTEM attempt to build for SYSTEM--e.g., \"i686-linux\"")) (display (G_ " --bootstrap use the bootstrap Guile to build the new Guix")) (newline) -- cgit v1.2.3 From a65177a657b0cb36d45f2e8db574ea9c10f89a1f Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sun, 6 Jan 2019 22:02:40 +0100 Subject: maint: Remove 'cond-expand' forms for Guile 2.0. Note: Leave 'cond-expand' forms used in the build-side modules that can run on %BOOTSTRAP-GUILE, which is currently Guile 2.0. * guix/build/compile.scm: Move 'use-modules' clause from 'cond-expand' to 'define-module' form. (%default-optimizations): Remove 'cond-expand'. * guix/build/download.scm (tls-wrap): Remove 'cond-expand'. * guix/build/syscalls.scm: Remove 'cond-expand' form around '%set-automatic-finalization-enabled?!' and 'without-automatic-finalization'. * guix/inferior.scm (port->inferior): Remove 'cond-expand'. * guix/scripts/pack.scm (wrapped-package)[build]: Remove 'cond-expand'. * guix/status.scm (build-event-output-port): Remove 'cond-expand'. * guix/store.scm (open-inet-socket): Remove 'cond-expand'. * guix/ui.scm (install-locale): Remove 'cond-expand'. * tests/status.scm ("current-build-output-port, UTF-8 + garbage"): Remove 'cond-expand'. * tests/store.scm ("current-build-output-port, UTF-8 + garbage"): Remove 'cond-expand'. --- guix/build/compile.scm | 18 +++++---------- guix/build/download.scm | 6 ++--- guix/build/syscalls.scm | 58 +++++++++++++++++++++---------------------------- guix/inferior.scm | 6 ++--- guix/scripts/pack.scm | 6 ++--- guix/status.scm | 6 ++--- guix/store.scm | 7 +----- guix/ui.scm | 5 ----- tests/status.scm | 6 ++--- tests/store.scm | 6 ++--- 10 files changed, 44 insertions(+), 80 deletions(-) (limited to 'guix/scripts') diff --git a/guix/build/compile.scm b/guix/build/compile.scm index 5a1363556a..215489f136 100644 --- a/guix/build/compile.scm +++ b/guix/build/compile.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2013, 2014, 2016, 2017, 2018 Ludovic Courtès +;;; Copyright © 2013, 2014, 2016, 2017, 2018, 2019 Ludovic Courtès ;;; Copyright © 2015 Taylan Ulrich Bayırlı/Kammer ;;; ;;; This file is part of GNU Guix. @@ -26,28 +26,22 @@ (define-module (guix build compile) #:use-module (system base message) #:use-module (guix modules) #:use-module (guix build utils) + #:use-module (language tree-il optimize) + #:use-module (language cps optimize) #:export (%default-optimizations %lightweight-optimizations compile-files)) ;;; Commentary: ;;; -;;; Support code to compile Guile code as efficiently as possible (both with -;;; Guile 2.0 and 2.2). +;;; Support code to compile Guile code as efficiently as possible (with 2.2). ;;; ;;; Code: -(cond-expand - (guile-2.2 (use-modules (language tree-il optimize) - (language cps optimize))) - (else #f)) - (define %default-optimizations ;; Default optimization options (equivalent to -O2 on Guile 2.2). - (cond-expand - (guile-2.2 (append (tree-il-default-optimization-options) - (cps-default-optimization-options))) - (else '()))) + (append (tree-il-default-optimization-options) + (cps-default-optimization-options))) (define %lightweight-optimizations ;; Lightweight optimizations (like -O0, but with partial evaluation). diff --git a/guix/build/download.scm b/guix/build/download.scm index 54163849a2..199702a679 100644 --- a/guix/build/download.scm +++ b/guix/build/download.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018 Ludovic Courtès +;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019 Ludovic Courtès ;;; Copyright © 2015 Mark H Weaver ;;; Copyright © 2017 Tobias Geerinckx-Rice ;;; @@ -314,9 +314,7 @@ (define (log level str) ;; Write HTTP requests line by line rather than byte by byte: ;; . This is possible with Guile >= 2.2. - (cond-expand - (guile-2.2 (setvbuf record 'line)) - (else #f)) + (setvbuf record 'line) record))) diff --git a/guix/build/syscalls.scm b/guix/build/syscalls.scm index 56a689f667..d75c11ada7 100644 --- a/guix/build/syscalls.scm +++ b/guix/build/syscalls.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2014, 2015, 2016, 2017, 2018 Ludovic Courtès +;;; Copyright © 2014, 2015, 2016, 2017, 2018, 2019 Ludovic Courtès ;;; Copyright © 2015 David Thompson ;;; Copyright © 2015 Mark H Weaver ;;; Copyright © 2017 Mathieu Othacehe @@ -699,39 +699,31 @@ (define CLONE_NEWUSER #x10000000) (define CLONE_NEWPID #x20000000) (define CLONE_NEWNET #x40000000) -(cond-expand - (guile-2.2 - (define %set-automatic-finalization-enabled?! - ;; When using a statically-linked Guile, for instance in the initrd, we - ;; cannot resolve this symbol, but most of the time we don't need it - ;; anyway. Thus, delay it. - (let ((proc (delay - (pointer->procedure int - (dynamic-func - "scm_set_automatic_finalization_enabled" - (dynamic-link)) - (list int))))) - (lambda (enabled?) - "Switch on or off automatic finalization in a separate thread. +(define %set-automatic-finalization-enabled?! + ;; When using a statically-linked Guile, for instance in the initrd, we + ;; cannot resolve this symbol, but most of the time we don't need it + ;; anyway. Thus, delay it. + (let ((proc (delay + (pointer->procedure int + (dynamic-func + "scm_set_automatic_finalization_enabled" + (dynamic-link)) + (list int))))) + (lambda (enabled?) + "Switch on or off automatic finalization in a separate thread. Turning finalization off shuts down the finalization thread as a side effect." - (->bool ((force proc) (if enabled? 1 0)))))) - - (define-syntax-rule (without-automatic-finalization exp) - "Turn off automatic finalization within the dynamic extent of EXP." - (let ((enabled? #t)) - (dynamic-wind - (lambda () - (set! enabled? (%set-automatic-finalization-enabled?! #f))) - (lambda () - exp) - (lambda () - (%set-automatic-finalization-enabled?! enabled?)))))) - - (else - (define-syntax-rule (without-automatic-finalization exp) - ;; Nothing to do here: Guile 2.0 does not have a separate finalization - ;; thread. - exp))) + (->bool ((force proc) (if enabled? 1 0)))))) + +(define-syntax-rule (without-automatic-finalization exp) + "Turn off automatic finalization within the dynamic extent of EXP." + (let ((enabled? #t)) + (dynamic-wind + (lambda () + (set! enabled? (%set-automatic-finalization-enabled?! #f))) + (lambda () + exp) + (lambda () + (%set-automatic-finalization-enabled?! enabled?))))) ;; The libc interface to sys_clone is not useful for Scheme programs, so the ;; low-level system call is wrapped instead. The 'syscall' function is diff --git a/guix/inferior.scm b/guix/inferior.scm index 973bd5264e..a6e6d2f16e 100644 --- a/guix/inferior.scm +++ b/guix/inferior.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2018 Ludovic Courtès +;;; Copyright © 2018, 2019 Ludovic Courtès ;;; ;;; This file is part of GNU Guix. ;;; @@ -137,9 +137,7 @@ (define* (port->inferior pipe #:optional (close close-port)) "Given PIPE, an input/output port, return an inferior that talks over PIPE. PIPE is closed with CLOSE when 'close-inferior' is called on the returned inferior." - (cond-expand - ((and guile-2 (not guile-2.2)) #t) - (else (setvbuf pipe 'line))) + (setvbuf pipe 'line) (match (read pipe) (('repl-version 0 rest ...) diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm index 98b06971bd..e137fb136a 100644 --- a/guix/scripts/pack.scm +++ b/guix/scripts/pack.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2015, 2017, 2018 Ludovic Courtès +;;; Copyright © 2015, 2017, 2018, 2019 Ludovic Courtès ;;; Copyright © 2017, 2018 Ricardo Wurmus ;;; Copyright © 2018 Konrad Hinsen ;;; Copyright © 2018 Chris Marusich @@ -553,9 +553,7 @@ (define (build-wrapper program) "run.c" "-o" result) (delete-file "run.c"))) - (setvbuf (current-output-port) - (cond-expand (guile-2.2 'line) - (else _IOLBF))) + (setvbuf (current-output-port) 'line) ;; Link the top-level files of PACKAGE so that search paths are ;; properly defined in PROFILE/etc/profile. diff --git a/guix/status.scm b/guix/status.scm index d4fc4ca16e..1a7cb313ea 100644 --- a/guix/status.scm +++ b/guix/status.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2017, 2018 Ludovic Courtès +;;; Copyright © 2017, 2018, 2019 Ludovic Courtès ;;; Copyright © 2018 Ricardo Wurmus ;;; ;;; This file is part of GNU Guix. @@ -636,9 +636,7 @@ (define port ;; The build port actually receives Unicode strings. (set-port-encoding! port "UTF-8") - (cond-expand - ((and guile-2 (not guile-2.2)) #t) - (else (setvbuf port 'line))) + (setvbuf port 'line) (values port (lambda () %state))) (define (call-with-status-report on-event thunk) diff --git a/guix/store.scm b/guix/store.scm index 042dfab67f..1883829231 100644 --- a/guix/store.scm +++ b/guix/store.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018 Ludovic Courtès +;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019 Ludovic Courtès ;;; Copyright © 2018 Jan Nieuwenhuizen ;;; ;;; This file is part of GNU Guix. @@ -404,11 +404,6 @@ (define %default-guix-port (define (open-inet-socket host port) "Connect to the Unix-domain socket at HOST:PORT and return it. Raise a '&nix-connection-error' upon error." - ;; Define 'TCP_NODELAY' on Guile 2.0. The value is the same on all GNU - ;; systems. - (cond-expand (guile-2.2 #t) - (else (define TCP_NODELAY 1))) - (let ((sock (with-fluids ((%default-port-encoding #f)) ;; This trick allows use of the `scm_c_read' optimization. (socket PF_UNIX SOCK_STREAM 0)))) diff --git a/guix/ui.scm b/guix/ui.scm index 4c31246920..f542cd3e3f 100644 --- a/guix/ui.scm +++ b/guix/ui.scm @@ -427,11 +427,6 @@ (define (install-locale) (lambda _ (setlocale LC_ALL "")) (lambda args - (cond-expand - ;; Guile 2.2 already emits a warning, so let's not add a second one. - (guile-2.2 #t) - (else (warning (G_ "failed to install locale: ~a~%") - (strerror (system-error-errno args))))) (display-hint (G_ "Consider installing the @code{glibc-utf8-locales} or @code{glibc-locales} package and defining @code{GUIX_LOCPATH}, along these lines: diff --git a/tests/status.scm b/tests/status.scm index 99abb41c8b..08a3153218 100644 --- a/tests/status.scm +++ b/tests/status.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2018 Ludovic Courtès +;;; Copyright © 2018, 2019 Ludovic Courtès ;;; ;;; This file is part of GNU Guix. ;;; @@ -125,9 +125,7 @@ (define-module (test-status) (test-equal "current-build-output-port, UTF-8 + garbage" ;; What about a mixture of UTF-8 + garbage? - (let ((replacement (cond-expand - ((and guile-2 (not guile-2.2)) "?") - (else "�")))) + (let ((replacement "�")) `((build-log #f ,(string-append "garbage: " replacement "lambda: λ\n")))) (let-values (((port get-status) (build-event-output-port cons '()))) (display "garbage: " port) diff --git a/tests/store.scm b/tests/store.scm index 3ff526cdcf..5ff9308d7d 100644 --- a/tests/store.scm +++ b/tests/store.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018 Ludovic Courtès +;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019 Ludovic Courtès ;;; ;;; This file is part of GNU Guix. ;;; @@ -444,9 +444,7 @@ (define (same? x y) (package-derivation %store %bootstrap-guile)))) (guard (c ((nix-protocol-error? c) #t)) (build-derivations %store (list d)))))))) - (cond-expand - (guile-2.2 "garbage: �lambda: λ") - (else "garbage: ?lambda: λ")))) + "garbage: �lambda: λ")) (test-assert "log-file, derivation" (let* ((b (add-text-to-store %store "build" "echo $foo > $out" '())) -- cgit v1.2.3 From 76832d3420594c8b5feaf7682b84b5481a49a076 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 7 Jan 2019 10:57:18 +0100 Subject: Remove most uses of the _IO*F constants. These constants, for use with 'setvbuf', were deprecated in Guile 2.2 and disappeared in Guile 3.0. Here we keep these constants in build-side code where removing them is not feasible. * guix/build/download-nar.scm (download-nar): Adjust 'setvbuf' calls to the Guile 2.2+ API. * guix/build/download.scm (open-socket-for-uri): Likewise. (open-connection-for-uri, url-fetch): Likewise. * guix/build/make-bootstrap.scm (make-stripped-libc): Likewise. * guix/build/union.scm (setvbuf) [guile-2.0]: New conditional wrapper. (union-build): Adjust to new API. * guix/ftp-client.scm (ftp-open, ftp-list, ftp-retr): Likewise. * guix/http-client.scm (http-fetch): Likewise. * guix/inferior.scm (proxy): Likewise. * guix/scripts/substitute.scm (fetch, http-multiple-get): Likewise. * guix/self.scm (compiled-modules): Likewise. * guix/ssh.scm (remote-daemon-channel, store-import-channel) (store-export-channel): Likewise. * guix/ui.scm (initialize-guix): Likewise. * tests/publish.scm (http-get-port): Likewise. * guix/store.scm (%newlines): Adjust comment. --- guix/build/download-nar.scm | 6 +++--- guix/build/download.scm | 10 +++++----- guix/build/make-bootstrap.scm | 4 ++-- guix/build/union.scm | 21 +++++++++++++++++---- guix/ftp-client.scm | 8 ++++---- guix/http-client.scm | 2 +- guix/inferior.scm | 4 ++-- guix/scripts/substitute.scm | 6 +++--- guix/self.scm | 6 +++--- guix/ssh.scm | 12 ++++++------ guix/store.scm | 2 +- guix/ui.scm | 4 ++-- tests/publish.scm | 6 +++--- 13 files changed, 52 insertions(+), 39 deletions(-) (limited to 'guix/scripts') diff --git a/guix/build/download-nar.scm b/guix/build/download-nar.scm index 13f01fb1e8..681f22238d 100644 --- a/guix/build/download-nar.scm +++ b/guix/build/download-nar.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2017 Ludovic Courtès +;;; Copyright © 2017, 2019 Ludovic Courtès ;;; ;;; This file is part of GNU Guix. ;;; @@ -93,8 +93,8 @@ (define (download-nar item) "Download and extract the normalized archive for ITEM. Return #t on success, #f otherwise." ;; Let progress reports go through. - (setvbuf (current-error-port) _IONBF) - (setvbuf (current-output-port) _IONBF) + (setvbuf (current-error-port) 'none) + (setvbuf (current-output-port) 'none) (let loop ((urls (urls-for-item item))) (match urls diff --git a/guix/build/download.scm b/guix/build/download.scm index 24b5aa378f..c08221b3b2 100644 --- a/guix/build/download.scm +++ b/guix/build/download.scm @@ -357,7 +357,7 @@ (define addresses (connect* s (addrinfo:addr ai) timeout) ;; Buffer input and output on this port. - (setvbuf s _IOFBF) + (setvbuf s 'block) ;; If we're using a proxy, make a note of that. (when http-proxy (set-http-proxy-port?! s #t)) s) @@ -401,7 +401,7 @@ (define https? (with-https-proxy (let ((s (open-socket-for-uri uri #:timeout timeout))) ;; Buffer input and output on this port. - (setvbuf s _IOFBF %http-receive-buffer-size) + (setvbuf s 'block %http-receive-buffer-size) (if https? (tls-wrap s (uri-host uri) @@ -777,11 +777,11 @@ (define content-addressed-uris hashes)) content-addressed-mirrors)) - ;; Make this unbuffered so 'progress-report/file' works as expected. _IOLBF + ;; Make this unbuffered so 'progress-report/file' works as expected. 'line ;; means '\n', not '\r', so it's not appropriate here. - (setvbuf (current-output-port) _IONBF) + (setvbuf (current-output-port) 'none) - (setvbuf (current-error-port) _IOLBF) + (setvbuf (current-error-port) 'line) (let try ((uri (append uri content-addressed-uris))) (match uri diff --git a/guix/build/make-bootstrap.scm b/guix/build/make-bootstrap.scm index 43b136248f..48799f7e90 100644 --- a/guix/build/make-bootstrap.scm +++ b/guix/build/make-bootstrap.scm @@ -1,6 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2015, 2017 Manolis Fragkiskos Ragkousis -;;; Copyright © 2015 Ludovic Courtès +;;; Copyright © 2015, 2019 Ludovic Courtès ;;; ;;; This file is part of GNU Guix. ;;; @@ -67,7 +67,7 @@ (define %libc-object-files-rx "^(crt.*|ld.*|lib(c|m|dl|rt|pthread|nsl|\ util).*\\.so(\\..*)?|lib(machuser|hurduser).so.*|(libc(rt|)|libpthread)\ _nonshared\\.a)$") - (setvbuf (current-output-port) _IOLBF) + (setvbuf (current-output-port) 'line) (let* ((libdir (string-append output "/lib"))) (mkdir-p libdir) (for-each (lambda (file) diff --git a/guix/build/union.scm b/guix/build/union.scm index fff795c4d3..961ac3298b 100644 --- a/guix/build/union.scm +++ b/guix/build/union.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2012, 2013, 2014, 2016, 2017, 2018 Ludovic Courtès +;;; Copyright © 2012, 2013, 2014, 2016, 2017, 2018, 2019 Ludovic Courtès ;;; Copyright © 2014 Mark H Weaver ;;; Copyright © 2017 Huang Ying ;;; @@ -39,6 +39,19 @@ (define-module (guix build union) ;;; ;;; Code: +;; This code can be used with the bootstrap Guile, which is Guile 2.0, so +;; provide a compatibility layer. +(cond-expand + ((and guile-2 (not guile-2.2)) + (define (setvbuf port mode . rest) + (apply (@ (guile) setvbuf) port + (match mode + ('line _IOLBF) + ('block _IOFBF) + ('none _IONBF)) + rest))) + (else #f)) + (define (files-in-directory dirname) (let ((dir (opendir dirname))) (let loop ((files '())) @@ -179,10 +192,10 @@ (define (add-to-table! file dir) (reverse dirs-with-file)))) table))) - (setvbuf (current-output-port) _IOLBF) - (setvbuf (current-error-port) _IOLBF) + (setvbuf (current-output-port) 'line) + (setvbuf (current-error-port) 'line) (when (file-port? log-port) - (setvbuf log-port _IOLBF)) + (setvbuf log-port 'line)) (union-of-directories output (delete-duplicates inputs))) diff --git a/guix/ftp-client.scm b/guix/ftp-client.scm index 0b8f61c276..8d5adcb8ed 100644 --- a/guix/ftp-client.scm +++ b/guix/ftp-client.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2010, 2011, 2012, 2013, 2014, 2015, 2016, 2017 Ludovic Courtès +;;; Copyright © 2010, 2011, 2012, 2013, 2014, 2015, 2016, 2017, 2019 Ludovic Courtès ;;; ;;; This file is part of GNU Guix. ;;; @@ -154,7 +154,7 @@ (define addresses (catch 'system-error (lambda () (connect* s (addrinfo:addr ai) timeout) - (setvbuf s _IOLBF) + (setvbuf s 'line) (let-values (((code message) (%ftp-listen s))) (if (eqv? code 220) (begin @@ -237,7 +237,7 @@ (define* (ftp-list conn #:optional directory #:key timeout) (s (socket (addrinfo:fam ai) (addrinfo:socktype ai) (addrinfo:protocol ai)))) (connect* s (address-with-port (addrinfo:addr ai) port) timeout) - (setvbuf s _IOLBF) + (setvbuf s 'line) (dynamic-wind (lambda () #t) @@ -293,7 +293,7 @@ (define (terminate) (throw 'ftp-error conn "LIST" code message)))) (connect* s (address-with-port (addrinfo:addr ai) port) timeout) - (setvbuf s _IOLBF) + (setvbuf s 'line) (%ftp-command (string-append "RETR " file) 150 (ftp-connection-socket conn)) diff --git a/guix/http-client.scm b/guix/http-client.scm index 07360e6108..067002a79a 100644 --- a/guix/http-client.scm +++ b/guix/http-client.scm @@ -97,7 +97,7 @@ (define* (http-fetch uri #:key port (text? #f) (buffered? #t) headers)) (_ headers)))) (unless (or buffered? (not (file-port? port))) - (setvbuf port _IONBF)) + (setvbuf port 'none)) (let*-values (((resp data) (http-get uri #:streaming? #t #:port port #:keep-alive? #t diff --git a/guix/inferior.scm b/guix/inferior.scm index a6e6d2f16e..ba8d00866b 100644 --- a/guix/inferior.scm +++ b/guix/inferior.scm @@ -389,8 +389,8 @@ (define (select* read write except) ;; Use buffered ports so that 'get-bytevector-some' returns up to the ;; whole buffer like read(2) would--see . - (setvbuf client _IOFBF 65536) - (setvbuf backend _IOFBF 65536) + (setvbuf client 'block 65536) + (setvbuf backend 'block 65536) (let loop () (match (select* (list client backend) '() '()) diff --git a/guix/scripts/substitute.scm b/guix/scripts/substitute.scm index 53b1777241..797a76db3f 100755 --- a/guix/scripts/substitute.scm +++ b/guix/scripts/substitute.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018 Ludovic Courtès +;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018, 2019 Ludovic Courtès ;;; Copyright © 2014 Nikita Karetnikov ;;; Copyright © 2018 Kyle Meyer ;;; @@ -219,7 +219,7 @@ (define* (fetch uri #:key (buffered? #t) (timeout? #t)) (set! port (guix:open-connection-for-uri uri #:verify-certificate? #f)) (unless (or buffered? (not (file-port? port))) - (setvbuf port _IONBF))) + (setvbuf port 'none))) (http-fetch uri #:text? #f #:port port #:verify-certificate? #f)))))) (else @@ -567,7 +567,7 @@ (define* (http-multiple-get base-uri proc seed requests verify-certificate?)))) ;; For HTTPS, P is not a file port and does not support 'setvbuf'. (when (file-port? p) - (setvbuf p _IOFBF (expt 2 16))) + (setvbuf p 'block (expt 2 16))) ;; Send REQUESTS, up to a certain number, in a row. ;; XXX: Do our own caching to work around inefficiencies when diff --git a/guix/self.scm b/guix/self.scm index e9a768bc90..a2ae441d42 100644 --- a/guix/self.scm +++ b/guix/self.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2017, 2018 Ludovic Courtès +;;; Copyright © 2017, 2018, 2019 Ludovic Courtès ;;; ;;; This file is part of GNU Guix. ;;; @@ -904,8 +904,8 @@ (define (process-directory directory files output) #:report-load report-load #:report-compilation report-compilation))) - (setvbuf (current-output-port) _IONBF) - (setvbuf (current-error-port) _IONBF) + (setvbuf (current-output-port) 'none) + (setvbuf (current-error-port) 'none) (set! %load-path (cons #+module-tree %load-path)) (set! %load-path diff --git a/guix/ssh.scm b/guix/ssh.scm index 1ed8406633..d90cb77be0 100644 --- a/guix/ssh.scm +++ b/guix/ssh.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2016, 2017, 2018 Ludovic Courtès +;;; Copyright © 2016, 2017, 2018, 2019 Ludovic Courtès ;;; ;;; This file is part of GNU Guix. ;;; @@ -140,12 +140,12 @@ (define redirect (match (select read write except) ((read write except) (select read write except 0)))))) - (setvbuf stdout _IONBF) + (setvbuf stdout 'none) ;; Use buffered ports so that 'get-bytevector-some' returns up to the ;; whole buffer like read(2) would--see . - (setvbuf stdin _IOFBF 65536) - (setvbuf sock _IOFBF 65536) + (setvbuf stdin 'block 65536) + (setvbuf sock 'block 65536) (connect sock AF_UNIX ,socket-name) @@ -218,7 +218,7 @@ (define (consume-input port) (consume-input (current-input-port)) (list 'protocol-error (nix-protocol-error-message c)))) (with-store store - (setvbuf (current-input-port) _IONBF) + (setvbuf (current-input-port) 'none) (import-paths store (current-input-port)) '(success)))) (lambda args @@ -269,7 +269,7 @@ (define export (write '(exporting)) ;we're ready (force-output) - (setvbuf (current-output-port) _IONBF) + (setvbuf (current-output-port) 'none) (export-paths store files (current-output-port) #:recursive? ,recursive?)))))) diff --git a/guix/store.scm b/guix/store.scm index 1883829231..1f88eb2b33 100644 --- a/guix/store.scm +++ b/guix/store.scm @@ -608,7 +608,7 @@ (define buffer (define %newlines ;; Newline characters triggering a flush of 'current-build-output-port'. - ;; Unlike Guile's _IOLBF, we flush upon #\return so that progress reports + ;; Unlike Guile's 'line, we flush upon #\return so that progress reports ;; that use that trick are correctly displayed. (char-set #\newline #\return)) diff --git a/guix/ui.scm b/guix/ui.scm index f542cd3e3f..1e089753e1 100644 --- a/guix/ui.scm +++ b/guix/ui.scm @@ -454,8 +454,8 @@ (define (initialize-guix) ;; notified via an EPIPE later. (sigaction SIGPIPE SIG_IGN) - (setvbuf (current-output-port) _IOLBF) - (setvbuf (current-error-port) _IOLBF)) + (setvbuf (current-output-port) 'line) + (setvbuf (current-error-port) 'line)) (define* (show-version-and-exit #:optional (command (car (command-line)))) "Display version information for COMMAND and `(exit 0)'." diff --git a/tests/publish.scm b/tests/publish.scm index 79a786e723..097ac036e0 100644 --- a/tests/publish.scm +++ b/tests/publish.scm @@ -1,6 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2015 David Thompson -;;; Copyright © 2016, 2017, 2018 Ludovic Courtès +;;; Copyright © 2016, 2017, 2018, 2019 Ludovic Courtès ;;; ;;; This file is part of GNU Guix. ;;; @@ -63,12 +63,12 @@ (define (http-get-port uri) (let ((socket (open-socket-for-uri uri))) ;; Make sure to use an unbuffered port so that we can then peek at the ;; underlying file descriptor via 'call-with-gzip-input-port'. - (setvbuf socket _IONBF) + (setvbuf socket 'none) (call-with-values (lambda () (http-get uri #:port socket #:streaming? #t)) (lambda (response port) - ;; Don't (setvbuf port _IONBF) because of + ;; Don't (setvbuf port 'none) because of ;; (PORT might be a custom binary input port). port)))) -- cgit v1.2.3 From 40fa21c22e1d11b741515fd38f5204a5fa57fbaa Mon Sep 17 00:00:00 2001 From: Arun Isaac Date: Mon, 7 Jan 2019 23:11:58 +0530 Subject: guix: lint: Warn only if GitHub URI is not same as the package URI. * guix/scripts/lint.scm (check-github-url): Warn only if the GitHub URI obtained after following redirects is not same as the original URI. * tests/lint.scm ("github-url: already the correct github url"): New test. --- guix/scripts/lint.scm | 11 ++++++----- tests/lint.scm | 13 +++++++++++-- 2 files changed, 17 insertions(+), 7 deletions(-) (limited to 'guix/scripts') diff --git a/guix/scripts/lint.scm b/guix/scripts/lint.scm index 9acec48577..0f315a9352 100644 --- a/guix/scripts/lint.scm +++ b/guix/scripts/lint.scm @@ -8,7 +8,7 @@ ;;; Copyright © 2017 Alex Kost ;;; Copyright © 2017 Tobias Geerinckx-Rice ;;; Copyright © 2017, 2018 Efraim Flashner -;;; Copyright © 2018 Arun Isaac +;;; Copyright © 2018, 2019 Arun Isaac ;;; ;;; This file is part of GNU Guix. ;;; @@ -820,10 +820,11 @@ (define (follow-redirects-to-github uri) (lambda (uri) (and=> (follow-redirects-to-github uri) (lambda (github-uri) - (emit-warning - package - (format #f (G_ "URL should be '~a'") github-uri) - 'source)))) + (unless (string=? github-uri uri) + (emit-warning + package + (format #f (G_ "URL should be '~a'") github-uri) + 'source))))) (origin-uris origin))))) (define (check-derivation package) diff --git a/tests/lint.scm b/tests/lint.scm index fe12bebd88..912a78d111 100644 --- a/tests/lint.scm +++ b/tests/lint.scm @@ -6,7 +6,7 @@ ;;; Copyright © 2016 Hartmut Goebel ;;; Copyright © 2017 Alex Kost ;;; Copyright © 2017 Efraim Flashner -;;; Copyright © 2018 Arun Isaac +;;; Copyright © 2018, 2019 Arun Isaac ;;; ;;; This file is part of GNU Guix. ;;; @@ -775,7 +775,16 @@ (define-syntax-rule (with-warnings body ...) (method url-fetch) (uri (%local-url)) (sha256 %null-sha256)))))))))) - github-url))) + github-url)) + (test-assert "github-url: already the correct github url" + (string-null? + (with-warnings + (check-github-url + (dummy-package "x" (source + (origin + (method url-fetch) + (uri github-url) + (sha256 %null-sha256))))))))) (test-assert "cve" (mock ((guix scripts lint) package-vulnerabilities (const '())) -- cgit v1.2.3 From fca43e14f70c0536668981eb1aed9e46a42de935 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 11 Jan 2019 11:44:26 +0100 Subject: refresh: Refactor option handling and '--recursive'. This allows us to combine '--recursive' with other options (-u, -m, etc.), turns off warnings when '--recursive' is used, and avoids the hazards of I/O in the presence of multithreading. * guix/scripts/refresh.scm (options->packages): New procedure, with code formerly in 'guix-refresh'. (refresh-recursive): Remove. (guix-refresh)[keep-newest, core-package?, args-packages, packages]: Remove. [warn?]: Set to #f when RECURSIVE? is true. Call 'options->packages' in monadic context. --- guix/scripts/refresh.scm | 211 +++++++++++++++++++++++------------------------ 1 file changed, 104 insertions(+), 107 deletions(-) (limited to 'guix/scripts') diff --git a/guix/scripts/refresh.scm b/guix/scripts/refresh.scm index 003c915da3..64019b6eb3 100644 --- a/guix/scripts/refresh.scm +++ b/guix/scripts/refresh.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018 Ludovic Courtès +;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018, 2019 Ludovic Courtès ;;; Copyright © 2013 Nikita Karetnikov ;;; Copyright © 2014 Eric Bavier ;;; Copyright © 2015 Alex Kost @@ -41,7 +41,6 @@ (define-module (guix scripts refresh) #:use-module (ice-9 regex) #:use-module (ice-9 vlist) #:use-module (ice-9 format) - #:use-module (ice-9 threads) ; par-for-each #:use-module (srfi srfi-1) #:use-module (srfi srfi-11) #:use-module (srfi srfi-26) @@ -172,6 +171,79 @@ (define (show-help) (newline) (show-bug-report-information)) +(define (options->packages opts) + "Return the list of packages requested by OPTS, honoring options like +'--recursive'." + (define core-package? + (let* ((input->package (match-lambda + ((name (? package? package) _ ...) package) + (_ #f))) + (final-inputs (map input->package %final-inputs)) + (core (append final-inputs + (append-map (compose (cut filter-map input->package <>) + package-transitive-inputs) + final-inputs))) + (names (delete-duplicates (map package-name core)))) + (lambda (package) + "Return true if PACKAGE is likely a \"core package\"---i.e., one whose +update would trigger a complete rebuild." + ;; Compare by name because packages in base.scm basically inherit + ;; other packages. So, even if those packages are not core packages + ;; themselves, updating them would also update those who inherit from + ;; them. + ;; XXX: Fails to catch MPFR/MPC, whose *source* is used as input. + (member (package-name package) names)))) + + (define (keep-newest package lst) + ;; If a newer version of PACKAGE is already in LST, return LST; otherwise + ;; return LST minus the other version of PACKAGE in it, plus PACKAGE. + (let ((name (package-name package))) + (match (find (lambda (p) + (string=? (package-name p) name)) + lst) + ((? package? other) + (if (version>? (package-version other) (package-version package)) + lst + (cons package (delq other lst)))) + (_ + (cons package lst))))) + + (define args-packages + ;; Packages explicitly passed as command-line arguments. + (match (filter-map (match-lambda + (('argument . spec) + ;; Take either the specified version or the + ;; latest one. + (specification->package spec)) + (('expression . exp) + (read/eval-package-expression exp)) + (_ #f)) + opts) + (() ;default to all packages + (let ((select? (match (assoc-ref opts 'select) + ('core core-package?) + ('non-core (negate core-package?)) + (_ (const #t))))) + (fold-packages (lambda (package result) + (if (select? package) + (keep-newest package result) + result)) + '()))) + (some ;user-specified packages + some))) + + (define packages + (match (assoc-ref opts 'manifest) + (#f args-packages) + ((? string? file) (packages-from-manifest file)))) + + (if (assoc-ref opts 'recursive?) + (mlet %store-monad ((edges (node-edges %bag-node-type + (all-packages)))) + (return (node-transitive-edges packages edges))) + (with-monad %store-monad + (return packages)))) + ;;; ;;; Updates. @@ -335,19 +407,6 @@ (define (full-name package) (map full-name covering)))) (return #t)))) -(define (refresh-recursive packages) - "Check all of the package inputs of PACKAGES for newer upstream versions." - (mlet %store-monad ((edges (node-edges %bag-node-type - ;; Here we don't want the -boot0 packages. - (fold-packages cons '())))) - (let ((dependent (node-transitive-edges packages edges))) - ;; par-for-each has an undefined return value, so packages which cause - ;; errors can be ignored. - (par-for-each (lambda (package) - (guix-refresh package)) - (map package-name dependent))) - (return #t))) - (define (list-transitive packages) "List all the packages that would cause PACKAGES to be rebuilt if they are changed." ;; Using %BAG-NODE-TYPE is more accurate than using %PACKAGE-NODE-TYPE @@ -414,40 +473,6 @@ (define (options->updaters opts) (lists (concatenate lists)))) - (define (keep-newest package lst) - ;; If a newer version of PACKAGE is already in LST, return LST; otherwise - ;; return LST minus the other version of PACKAGE in it, plus PACKAGE. - (let ((name (package-name package))) - (match (find (lambda (p) - (string=? (package-name p) name)) - lst) - ((? package? other) - (if (version>? (package-version other) (package-version package)) - lst - (cons package (delq other lst)))) - (_ - (cons package lst))))) - - (define core-package? - (let* ((input->package (match-lambda - ((name (? package? package) _ ...) package) - (_ #f))) - (final-inputs (map input->package %final-inputs)) - (core (append final-inputs - (append-map (compose (cut filter-map input->package <>) - package-transitive-inputs) - final-inputs))) - (names (delete-duplicates (map package-name core)))) - (lambda (package) - "Return true if PACKAGE is likely a \"core package\"---i.e., one whose -update would trigger a complete rebuild." - ;; Compare by name because packages in base.scm basically inherit - ;; other packages. So, even if those packages are not core packages - ;; themselves, updating them would also update those who inherit from - ;; them. - ;; XXX: Fails to catch MPFR/MPC, whose *source* is used as input. - (member (package-name package) names)))) - (let* ((opts (parse-options)) (update? (assoc-ref opts 'update?)) (updaters (options->updaters opts)) @@ -458,65 +483,37 @@ (define core-package? ;; Warn about missing updaters when a package is explicitly given on ;; the command line. - (warn? (or (assoc-ref opts 'argument) - (assoc-ref opts 'expression))) - (args-packages - (match (filter-map (match-lambda - (('argument . spec) - ;; Take either the specified version or the - ;; latest one. - (specification->package spec)) - (('expression . exp) - (read/eval-package-expression exp)) - (_ #f)) - opts) - (() ; default to all packages - (let ((select? (match (assoc-ref opts 'select) - ('core core-package?) - ('non-core (negate core-package?)) - (_ (const #t))))) - (fold-packages (lambda (package result) - (if (select? package) - (keep-newest package result) - result)) - '()))) - (some ; user-specified packages - some))) - (packages - (match (assoc-ref opts 'manifest) - (#f args-packages) - ((? string? file) (packages-from-manifest file))))) + (warn? (and (or (assoc-ref opts 'argument) + (assoc-ref opts 'expression)) + (not recursive?)))) (with-error-handling (with-store store (run-with-store store - (cond - (list-dependent? - (list-dependents packages)) - (list-transitive? - (list-transitive packages)) - (recursive? - (refresh-recursive packages)) - (update? - (parameterize ((%openpgp-key-server - (or (assoc-ref opts 'key-server) - (%openpgp-key-server))) - (%gpg-command - (or (assoc-ref opts 'gpg-command) - (%gpg-command))) - (current-keyring - (or (assoc-ref opts 'keyring) - (string-append (config-directory) - "/upstream/trustedkeys.kbx")))) - (for-each - (cut update-package store <> updaters - #:key-download key-download - #:warn? warn?) - packages) - (with-monad %store-monad - (return #t)))) - (else - (for-each (cut check-for-package-update <> updaters - #:warn? warn?) - packages) - (with-monad %store-monad + (mlet %store-monad ((packages (options->packages opts))) + (cond + (list-dependent? + (list-dependents packages)) + (list-transitive? + (list-transitive packages)) + (update? + (parameterize ((%openpgp-key-server + (or (assoc-ref opts 'key-server) + (%openpgp-key-server))) + (%gpg-command + (or (assoc-ref opts 'gpg-command) + (%gpg-command))) + (current-keyring + (or (assoc-ref opts 'keyring) + (string-append (config-directory) + "/upstream/trustedkeys.kbx")))) + (for-each + (cut update-package store <> updaters + #:key-download key-download + #:warn? warn?) + packages) + (return #t))) + (else + (for-each (cut check-for-package-update <> updaters + #:warn? warn?) + packages) (return #t))))))))) -- cgit v1.2.3 From 7489207ff788d6f4a9c2b9aec87c9835753dfd2f Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 11 Jan 2019 11:49:03 +0100 Subject: refresh: Turn on warnings when '--manifest' is used. * guix/scripts/refresh.scm (guix-refresh): Set WARN? when '-m' is used. --- guix/scripts/refresh.scm | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) (limited to 'guix/scripts') diff --git a/guix/scripts/refresh.scm b/guix/scripts/refresh.scm index 64019b6eb3..516e09b4ce 100644 --- a/guix/scripts/refresh.scm +++ b/guix/scripts/refresh.scm @@ -484,7 +484,8 @@ (define (options->updaters opts) ;; Warn about missing updaters when a package is explicitly given on ;; the command line. (warn? (and (or (assoc-ref opts 'argument) - (assoc-ref opts 'expression)) + (assoc-ref opts 'expression) + (assoc-ref opts 'manifest)) (not recursive?)))) (with-error-handling (with-store store -- cgit v1.2.3 From 7804c45b9ce5a8edd06452d828249e588ae26263 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 9 Jan 2019 11:25:11 +0100 Subject: status: Add 'with-status-verbosity'. * guix/status.scm (logger-for-level, call-with-status-verbosity): New procedures. (with-status-verbosity): New macro. * guix/scripts/environment.scm (guix-environment): Use 'with-status-verbosity' instead of 'with-status-report'. * guix/scripts/pack.scm (guix-pack): Likewise. * guix/scripts/package.scm (guix-package): Likewise. * guix/scripts/pull.scm (guix-pull): Likewise. * guix/scripts/system.scm (guix-system): Likewise. * build-aux/run-system-tests.scm (run-system-tests): Likewise. --- .dir-locals.el | 1 + build-aux/run-system-tests.scm | 4 ++-- guix/scripts/environment.scm | 4 ++-- guix/scripts/pack.scm | 2 +- guix/scripts/package.scm | 4 ++-- guix/scripts/pull.scm | 2 +- guix/scripts/system.scm | 7 +++---- guix/status.scm | 17 ++++++++++++++++- 8 files changed, 28 insertions(+), 13 deletions(-) (limited to 'guix/scripts') diff --git a/.dir-locals.el b/.dir-locals.el index 1a3a05f100..593c767d2b 100644 --- a/.dir-locals.el +++ b/.dir-locals.el @@ -61,6 +61,7 @@ (eval . (put 'with-derivation-narinfo 'scheme-indent-function 1)) (eval . (put 'with-derivation-substitute 'scheme-indent-function 2)) (eval . (put 'with-status-report 'scheme-indent-function 1)) + (eval . (put 'with-status-verbosity 'scheme-indent-function 1)) (eval . (put 'mlambda 'scheme-indent-function 1)) (eval . (put 'mlambdaq 'scheme-indent-function 1)) diff --git a/build-aux/run-system-tests.scm b/build-aux/run-system-tests.scm index 953ba3e221..bcd7547704 100644 --- a/build-aux/run-system-tests.scm +++ b/build-aux/run-system-tests.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2016, 2018 Ludovic Courtès +;;; Copyright © 2016, 2018, 2019 Ludovic Courtès ;;; ;;; This file is part of GNU Guix. ;;; @@ -64,7 +64,7 @@ (define tests (length tests)) (with-store store - (with-status-report print-build-event + (with-status-verbosity 2 (run-with-store store (mlet* %store-monad ((drv (mapm %store-monad system-test-value tests)) (out -> (map derivation->output-path drv))) diff --git a/guix/scripts/environment.scm b/guix/scripts/environment.scm index 86e1eb115f..9461d04976 100644 --- a/guix/scripts/environment.scm +++ b/guix/scripts/environment.scm @@ -1,6 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2014, 2015, 2018 David Thompson -;;; Copyright © 2015, 2016, 2017, 2018 Ludovic Courtès +;;; Copyright © 2015, 2016, 2017, 2018, 2019 Ludovic Courtès ;;; Copyright © 2018 Mike Gerwitz ;;; ;;; This file is part of GNU Guix. @@ -674,7 +674,7 @@ (define (guix-environment . args) (leave (G_ "'--user' cannot be used without '--container'~%"))) (with-store store - (with-status-report print-build-event + (with-status-verbosity 1 (define manifest (options/resolve-packages store opts)) diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm index e137fb136a..d9e0050159 100644 --- a/guix/scripts/pack.scm +++ b/guix/scripts/pack.scm @@ -772,7 +772,7 @@ (define (manifest-from-args store opts) (with-error-handling (with-store store - (with-status-report print-build-event + (with-status-verbosity 2 ;; Set the build options before we do anything else. (set-build-options-from-command-line store opts) diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm index 5743816324..876787fbe2 100644 --- a/guix/scripts/package.scm +++ b/guix/scripts/package.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018 Ludovic Courtès +;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019 Ludovic Courtès ;;; Copyright © 2013 Nikita Karetnikov ;;; Copyright © 2013, 2015 Mark H Weaver ;;; Copyright © 2014, 2016 Alex Kost @@ -914,7 +914,7 @@ (define verbose? (or (process-query opts) (parameterize ((%store (open-connection)) (%graft? (assoc-ref opts 'graft?))) - (with-status-report print-build-event/quiet + (with-status-verbosity 1 (set-build-options-from-command-line (%store) opts) (parameterize ((%guile-for-build (package-derivation diff --git a/guix/scripts/pull.scm b/guix/scripts/pull.scm index e7ff44c0d5..6389d5ec09 100644 --- a/guix/scripts/pull.scm +++ b/guix/scripts/pull.scm @@ -510,7 +510,7 @@ (define (guix-pull . args) (process-query opts profile)) (else (with-store store - (with-status-report print-build-event + (with-status-verbosity 2 (parameterize ((%current-system (assoc-ref opts 'system)) (%graft? (assoc-ref opts 'graft?)) (%repository-cache-directory cache)) diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm index 6cda3ccbd6..9e31baaddb 100644 --- a/guix/scripts/system.scm +++ b/guix/scripts/system.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2014, 2015, 2016, 2017, 2018 Ludovic Courtès +;;; Copyright © 2014, 2015, 2016, 2017, 2018, 2019 Ludovic Courtès ;;; Copyright © 2016 Alex Kost ;;; Copyright © 2016, 2017, 2018 Chris Marusich ;;; Copyright © 2017 Mathieu Othacehe @@ -1267,9 +1267,8 @@ (define (fail) (args (option-arguments opts)) (command (assoc-ref opts 'action))) (parameterize ((%graft? (assoc-ref opts 'graft?))) - (with-status-report (if (memq command '(init reconfigure)) - print-build-event/quiet - print-build-event) + (with-status-verbosity (if (memq command '(init reconfigure)) + 1 2) (process-command command args opts)))))) ;;; Local Variables: diff --git a/guix/status.scm b/guix/status.scm index 1a7cb313ea..2928733257 100644 --- a/guix/status.scm +++ b/guix/status.scm @@ -63,7 +63,8 @@ (define-module (guix status) print-build-event/quiet print-build-status - with-status-report)) + with-status-report + with-status-verbosity)) ;;; Commentary: ;;; @@ -649,3 +650,17 @@ (define-syntax-rule (with-status-report on-event exp ...) "Set up build status reporting to the user using the ON-EVENT procedure; evaluate EXP... in that context." (call-with-status-report on-event (lambda () exp ...))) + +(define (logger-for-level level) + "Return the logging procedure that corresponds to LEVEL." + (cond ((<= level 0) (const #t)) + ((= level 1) print-build-event/quiet) + (else print-build-event))) + +(define (call-with-status-verbosity level thunk) + (call-with-status-report (logger-for-level level) thunk)) + +(define-syntax-rule (with-status-verbosity level exp ...) + "Set up build status reporting to the user at the given LEVEL: 0 means +silent, 1 means quiet, 2 means verbose. Evaluate EXP... in that context." + (call-with-status-verbosity level (lambda () exp ...))) -- cgit v1.2.3 From f1de676ea82c2bed9a435fce37ade0186296bfc9 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 9 Jan 2019 14:17:19 +0100 Subject: guix build: Re-purpose '--verbosity' and add '--debug'. The previous '--verbosity' option was misleading and rarely what users were looking for. The new option provides a consistent way to choose whether or not to display the build log. * guix/scripts/build.scm (show-build-options-help): Remove "--verbosity" and add "--debug". (set-build-options-from-command-line): Use the 'debug key of OPTS for #:verbosity. (%standard-build-options): Change "verbosity" to "debug". Use 'string->number*' instead of 'string->number'. (%default-options): Change 'verbosity to 'debug and add a 'verbosity key. (show-help): Add '--verbosity'. (%options): Likewise, and change '--quiet' to set the 'verbosity key of RESULT. (guix-build): Use 'with-status-verbosity' instead of parameterizing CURRENT-BUILD-OUTPUT-PORT, honor the 'verbosity key of OPTS, and remove 'quiet?'. * guix/scripts/environment.scm (show-help, %options): Add '--verbosity'. (%default-options): Add 'debug'. (guix-environment): Honor the 'verbosity key of OPTS. * guix/scripts/pack.scm (%default-options): Add 'debug. (%options, show-help): Add '--verbosity'. (guix-pack): Honor the 'verbosity key of OPTS. * guix/scripts/package.scm (%default-options): Add 'debug. (show-help, %options): Add '--verbosity'. Mark '--verbose' as deprecated and change it to set 'verbosity. (guix-package): Honor the 'verbosity key of OPTS and remove 'verbose?'. * guix/scripts/pull.scm (%default-options): Add 'debug. (show-help, %options): Add '--verbosity'. (guix-pull): Honor the 'verbosity key of OPTS. * guix/scripts/system.scm (show-help, %options): Add '--verbosity'. (%default-options): Add 'debug. (guix-system): Honor the 'verbosity key of OPTS. * guix/scripts/archive.scm (%default-options): Add 'debug, 'print-build-trace?, 'print-extended-build-trace?, and 'multiplexed-build-output?. (show-help, %options): Add '--verbosity'. (export-from-store): Remove call to 'set-build-options-from-command-line'. (guix-archive): Wrap body in 'with-status-verbosity'. Add call to 'set-build-options-from-command-line. * doc/guix.texi (Common Build Options): Document '--verbosity' and '--debug'. (Additional Build Options): Adjust description of '--quiet'. --- doc/guix.texi | 28 +++++---- guix/scripts/archive.scm | 55 ++++++++++------- guix/scripts/build.scm | 140 ++++++++++++++++++++++--------------------- guix/scripts/environment.scm | 12 +++- guix/scripts/pack.scm | 12 +++- guix/scripts/package.scm | 21 ++++--- guix/scripts/pull.scm | 12 +++- guix/scripts/system.scm | 15 ++++- 8 files changed, 178 insertions(+), 117 deletions(-) (limited to 'guix/scripts') diff --git a/doc/guix.texi b/doc/guix.texi index ed7723c00b..2039ff67cf 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -2101,10 +2101,6 @@ By default, @command{guix package} reports as an error @dfn{collisions} in the profile. Collisions happen when two or more different versions or variants of a given package end up in the profile. -@item --verbose -Produce verbose output. In particular, emit the build log of the -environment on the standard error port. - @item --bootstrap Use the bootstrap Guile to build the profile. This option is only useful to distribution developers. @@ -6363,10 +6359,15 @@ Likewise, when the build or substitution process lasts for more than By default, the daemon's setting is honored (@pxref{Invoking guix-daemon, @code{--timeout}}). -@item --verbosity=@var{level} -Use the given verbosity level. @var{level} must be an integer between 0 -and 5; higher means more verbose output. Setting a level of 4 or more -may be helpful when debugging setup issues with the build daemon. +@c Note: This option is actually not part of %standard-build-options but +@c most programs honor it. +@cindex verbosity, of the command-line tools +@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. @item --cores=@var{n} @itemx -c @var{n} @@ -6379,6 +6380,11 @@ Allow at most @var{n} build jobs in parallel. @xref{Invoking guix-daemon, @code{--max-jobs}}, for details about this option and the equivalent @command{guix-daemon} option. +@item --debug=@var{level} +Produce debugging output coming from the build daemon. @var{level} must be an +integer between 0 and 5; higher means more verbose output. Setting a level of +4 or more may be helpful when debugging setup issues with the build daemon. + @end table Behind the scenes, @command{guix build} is essentially an interface to @@ -6547,9 +6553,9 @@ build}. @item --quiet @itemx -q -Build quietly, without displaying the build log. Upon completion, the -build log is kept in @file{/var} (or similar) and can always be -retrieved using the @option{--log-file} option. +Build quietly, without displaying the build log; this is equivalent to +@code{--verbosity=0}. Upon completion, the build log is kept in @file{/var} +(or similar) and can always be retrieved using the @option{--log-file} option. @item --file=@var{file} @itemx -f @var{file} diff --git a/guix/scripts/archive.scm b/guix/scripts/archive.scm index fb2f61ce30..950f0f41d8 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 Ludovic Courtès +;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2019 Ludovic Courtès ;;; ;;; This file is part of GNU Guix. ;;; @@ -23,6 +23,7 @@ (define-module (guix scripts archive) #:use-module ((guix build utils) #:select (mkdir-p)) #:use-module ((guix serialization) #:select (restore-file)) #:use-module (guix store) + #:use-module (guix status) #:use-module (guix grafts) #:use-module (guix packages) #:use-module (guix derivations) @@ -55,7 +56,11 @@ (define %default-options (substitutes? . #t) (build-hook? . #t) (graft? . #t) - (verbosity . 0))) + (print-build-trace? . #t) + (print-extended-build-trace? . #t) + (multiplexed-build-output? . #t) + (verbosity . 2) + (debug . 0))) (define (show-help) (display (G_ "Usage: guix archive [OPTION]... PACKAGE... @@ -85,6 +90,8 @@ (define (show-help) -s, --system=SYSTEM attempt to build for SYSTEM--e.g., \"i686-linux\"")) (display (G_ " --target=TRIPLET cross-build for TRIPLET--e.g., \"armel-linux-gnu\"")) + (display (G_ " + -v, --verbosity=LEVEL use the given verbosity LEVEL")) (newline) (show-build-options-help) @@ -161,6 +168,11 @@ (define %options (option '(#\e "expression") #t #f (lambda (opt name arg result) (alist-cons 'expression arg result))) + (option '(#\v "verbosity") #t #f + (lambda (opt name arg result) + (let ((level (string->number* arg))) + (alist-cons 'verbosity level + (alist-delete 'verbosity result))))) (option '(#\n "dry-run") #f #f (lambda (opt name arg result) (alist-cons 'dry-run? #t (alist-cons 'graft? #f result)))) @@ -239,7 +251,6 @@ (define (export-from-store store opts) resulting archive to the standard output port." (let-values (((drv files) (options->derivations+files store opts))) - (set-build-options-from-command-line store opts) (show-what-to-build store drv #:use-substitutes? (assoc-ref opts 'substitutes?) #:dry-run? (assoc-ref opts 'dry-run?)) @@ -329,21 +340,23 @@ (define (lines port) ((assoc-ref opts 'authorize) (authorize-key)) (else - (with-store store - (cond ((assoc-ref opts 'export) - (export-from-store store opts)) - ((assoc-ref opts 'import) - (import-paths store (current-input-port))) - ((assoc-ref opts 'missing) - (let* ((files (lines (current-input-port))) - (missing (remove (cut valid-path? store <>) - files))) - (format #t "~{~a~%~}" missing))) - ((assoc-ref opts 'extract) - => - (lambda (target) - (restore-file (current-input-port) target))) - (else - (leave - (G_ "either '--export' or '--import' \ -must be specified~%")))))))))))) + (with-status-verbosity (assoc-ref opts 'verbosity) + (with-store store + (set-build-options-from-command-line store opts) + (cond ((assoc-ref opts 'export) + (export-from-store store opts)) + ((assoc-ref opts 'import) + (import-paths store (current-input-port))) + ((assoc-ref opts 'missing) + (let* ((files (lines (current-input-port))) + (missing (remove (cut valid-path? store <>) + files))) + (format #t "~{~a~%~}" missing))) + ((assoc-ref opts 'extract) + => + (lambda (target) + (restore-file (current-input-port) target))) + (else + (leave + (G_ "either '--export' or '--import' \ +must be specified~%"))))))))))))) diff --git a/guix/scripts/build.scm b/guix/scripts/build.scm index 564bdf0ced..5a158799ae 100644 --- a/guix/scripts/build.scm +++ b/guix/scripts/build.scm @@ -449,14 +449,14 @@ (define (show-build-options-help) mark the build as failed after SECONDS of silence")) (display (G_ " --timeout=SECONDS mark the build as failed after SECONDS of activity")) - (display (G_ " - --verbosity=LEVEL use the given verbosity LEVEL")) (display (G_ " --rounds=N build N times in a row to detect non-determinism")) (display (G_ " -c, --cores=N allow the use of up to N CPU cores for the build")) (display (G_ " - -M, --max-jobs=N allow at most N build jobs"))) + -M, --max-jobs=N allow at most N build jobs")) + (display (G_ " + --debug=LEVEL produce debugging output at LEVEL"))) (define (set-build-options-from-command-line store opts) "Given OPTS, an alist as returned by 'args-fold' given @@ -479,7 +479,7 @@ (define (set-build-options-from-command-line store opts) (assoc-ref opts 'print-extended-build-trace?) #:multiplexed-build-output? (assoc-ref opts 'multiplexed-build-output?) - #:verbosity (assoc-ref opts 'verbosity))) + #:verbosity (assoc-ref opts 'debug))) (define set-build-options-from-command-line* (store-lift set-build-options-from-command-line)) @@ -553,12 +553,12 @@ (define %standard-build-options (apply values (alist-cons 'timeout (string->number* arg) result) rest))) - (option '("verbosity") #t #f + (option '("debug") #t #f (lambda (opt name arg result . rest) - (let ((level (string->number arg))) + (let ((level (string->number* arg))) (apply values - (alist-cons 'verbosity level - (alist-delete 'verbosity result)) + (alist-cons 'debug level + (alist-delete 'debug result)) rest)))) (option '(#\c "cores") #t #f (lambda (opt name arg result . rest) @@ -590,7 +590,8 @@ (define %default-options (print-build-trace? . #t) (print-extended-build-trace? . #t) (multiplexed-build-output? . #t) - (verbosity . 0))) + (verbosity . 2) + (debug . 0))) (define (show-help) (display (G_ "Usage: guix build [OPTION]... PACKAGE-OR-DERIVATION... @@ -619,6 +620,8 @@ (define (show-help) -r, --root=FILE make FILE a symlink to the result, and register it as a garbage collector root")) (display (G_ " + -v, --verbosity=LEVEL use the given verbosity LEVEL")) + (display (G_ " -q, --quiet do not show the build log")) (display (G_ " --log-file return the log file names for the given derivations")) @@ -694,9 +697,15 @@ (define %options (option '(#\r "root") #t #f (lambda (opt name arg result) (alist-cons 'gc-root arg result))) + (option '(#\v "verbosity") #t #f + (lambda (opt name arg result) + (let ((level (string->number* arg))) + (alist-cons 'verbosity level + (alist-delete 'verbosity result))))) (option '(#\q "quiet") #f #f (lambda (opt name arg result) - (alist-cons 'quiet? #t result))) + (alist-cons 'verbosity 0 + (alist-delete 'verbosity result)))) (option '("log-file") #f #f (lambda (opt name arg result) (alist-cons 'log-file? #t result))) @@ -819,66 +828,59 @@ (define opts (parse-command-line args %options (list %default-options))) - (define quiet? - (assoc-ref opts 'quiet?)) - (with-error-handling ;; Ask for absolute file names so that .drv file names passed from the ;; user to 'read-derivation' are absolute when it returns. (with-fluids ((%file-port-name-canonicalization 'absolute)) - (with-store store - ;; Set the build options before we do anything else. - (set-build-options-from-command-line store opts) - - (parameterize ((current-terminal-columns (terminal-columns)) - (current-build-output-port - (if quiet? - (%make-void-port "w") - (build-event-output-port - (build-status-updater print-build-event))))) - (let* ((mode (assoc-ref opts 'build-mode)) - (drv (options->derivations store opts)) - (urls (map (cut string-append <> "/log") - (if (assoc-ref opts 'substitutes?) - (or (assoc-ref opts 'substitute-urls) - ;; XXX: This does not necessarily match the - ;; daemon's substitute URLs. - %default-substitute-urls) - '()))) - (items (filter-map (match-lambda - (('argument . (? store-path? file)) - file) - (_ #f)) - opts)) - (roots (filter-map (match-lambda - (('gc-root . root) root) - (_ #f)) - opts))) - - (unless (or (assoc-ref opts 'log-file?) - (assoc-ref opts 'derivations-only?)) - (show-what-to-build store drv - #:use-substitutes? - (assoc-ref opts 'substitutes?) - #:dry-run? (assoc-ref opts 'dry-run?) - #:mode mode)) - - (cond ((assoc-ref opts 'log-file?) - (for-each (cut show-build-log store <> urls) - (delete-duplicates - (append (map derivation-file-name drv) - items)))) - ((assoc-ref opts 'derivations-only?) - (format #t "~{~a~%~}" (map derivation-file-name drv)) - (for-each (cut register-root store <> <>) - (map (compose list derivation-file-name) drv) - roots)) - ((not (assoc-ref opts 'dry-run?)) - (and (build-derivations store drv mode) - (for-each show-derivation-outputs drv) - (for-each (cut register-root store <> <>) - (map (lambda (drv) - (map cdr - (derivation->output-paths drv))) - drv) - roots)))))))))) + (with-status-verbosity (assoc-ref opts 'verbosity) + (with-store store + ;; Set the build options before we do anything else. + (set-build-options-from-command-line store opts) + + (parameterize ((current-terminal-columns (terminal-columns))) + (let* ((mode (assoc-ref opts 'build-mode)) + (drv (options->derivations store opts)) + (urls (map (cut string-append <> "/log") + (if (assoc-ref opts 'substitutes?) + (or (assoc-ref opts 'substitute-urls) + ;; XXX: This does not necessarily match the + ;; daemon's substitute URLs. + %default-substitute-urls) + '()))) + (items (filter-map (match-lambda + (('argument . (? store-path? file)) + file) + (_ #f)) + opts)) + (roots (filter-map (match-lambda + (('gc-root . root) root) + (_ #f)) + opts))) + + (unless (or (assoc-ref opts 'log-file?) + (assoc-ref opts 'derivations-only?)) + (show-what-to-build store drv + #:use-substitutes? + (assoc-ref opts 'substitutes?) + #:dry-run? (assoc-ref opts 'dry-run?) + #:mode mode)) + + (cond ((assoc-ref opts 'log-file?) + (for-each (cut show-build-log store <> urls) + (delete-duplicates + (append (map derivation-file-name drv) + items)))) + ((assoc-ref opts 'derivations-only?) + (format #t "~{~a~%~}" (map derivation-file-name drv)) + (for-each (cut register-root store <> <>) + (map (compose list derivation-file-name) drv) + roots)) + ((not (assoc-ref opts 'dry-run?)) + (and (build-derivations store drv mode) + (for-each show-derivation-outputs drv) + (for-each (cut register-root store <> <>) + (map (lambda (drv) + (map cdr + (derivation->output-paths drv))) + drv) + roots))))))))))) diff --git a/guix/scripts/environment.scm b/guix/scripts/environment.scm index 9461d04976..116b8dcbce 100644 --- a/guix/scripts/environment.scm +++ b/guix/scripts/environment.scm @@ -157,6 +157,8 @@ (define (show-help) (display (G_ " --expose=SPEC for containers, expose read-only host file system according to SPEC")) + (display (G_ " + -v, --verbosity=LEVEL use the given verbosity LEVEL")) (display (G_ " --bootstrap use bootstrap binaries to build the environment")) (newline) @@ -179,7 +181,8 @@ (define %default-options (print-build-trace? . #t) (print-extended-build-trace? . #t) (multiplexed-build-output? . #t) - (verbosity . 0))) + (debug . 0) + (verbosity . 2))) (define (tag-package-arg opts arg) "Return a two-element list with the form (TAG ARG) that tags ARG with either @@ -260,6 +263,11 @@ (define %options (option '(#\r "root") #t #f (lambda (opt name arg result) (alist-cons 'gc-root arg result))) + (option '(#\v "verbosity") #t #f + (lambda (opt name arg result) + (let ((level (string->number* arg))) + (alist-cons 'verbosity level + (alist-delete 'verbosity result))))) (option '("bootstrap") #f #f (lambda (opt name arg result) (alist-cons 'bootstrap? #t result))) @@ -674,7 +682,7 @@ (define (guix-environment . args) (leave (G_ "'--user' cannot be used without '--container'~%"))) (with-store store - (with-status-verbosity 1 + (with-status-verbosity (assoc-ref opts 'verbosity) (define manifest (options/resolve-packages store opts)) diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm index d9e0050159..b19a4ae1b1 100644 --- a/guix/scripts/pack.scm +++ b/guix/scripts/pack.scm @@ -598,7 +598,8 @@ (define %default-options (print-build-trace? . #t) (print-extended-build-trace? . #t) (multiplexed-build-output? . #t) - (verbosity . 0) + (debug . 0) + (verbosity . 2) (symlinks . ()) (compressor . ,(first %compressors)))) @@ -685,6 +686,11 @@ (define %options (alist-cons 'profile-name arg result)) (_ (leave (G_ "~a: unsupported profile name~%") arg))))) + (option '(#\v "verbosity") #t #f + (lambda (opt name arg result) + (let ((level (string->number* arg))) + (alist-cons 'verbosity level + (alist-delete 'verbosity result))))) (option '("bootstrap") #f #f (lambda (opt name arg result) (alist-cons 'bootstrap? #t result))) @@ -722,6 +728,8 @@ (define (show-help) (display (G_ " --profile-name=NAME populate /var/guix/profiles/.../NAME")) + (display (G_ " + -v, --verbosity=LEVEL use the given verbosity LEVEL")) (display (G_ " --bootstrap use the bootstrap binaries to build the pack")) (newline) @@ -772,7 +780,7 @@ (define (manifest-from-args store opts) (with-error-handling (with-store store - (with-status-verbosity 2 + (with-status-verbosity (assoc-ref opts 'verbosity) ;; Set the build options before we do anything else. (set-build-options-from-command-line store opts) diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm index 876787fbe2..7ff6bfd6d8 100644 --- a/guix/scripts/package.scm +++ b/guix/scripts/package.scm @@ -293,7 +293,8 @@ (define* (display-search-paths entries profiles (define %default-options ;; Alist of default option values. - `((verbosity . 0) + `((verbosity . 1) + (debug . 0) (graft? . #t) (substitutes? . #t) (build-hook? . #t) @@ -346,7 +347,7 @@ (define (show-help) (display (G_ " --bootstrap use the bootstrap Guile to build the profile")) (display (G_ " - --verbose produce verbose output")) + -v, --verbosity=LEVEL use the given verbosity LEVEL")) (newline) (display (G_ " -s, --search=REGEXP search in synopsis and description using REGEXP")) @@ -472,13 +473,21 @@ (define %options (values (alist-cons 'dry-run? #t (alist-cons 'graft? #f result)) #f))) + (option '(#\v "verbosity") #t #f + (lambda (opt name arg result arg-handler) + (let ((level (string->number* arg))) + (values (alist-cons 'verbosity level + (alist-delete 'verbosity result)) + #f)))) (option '("bootstrap") #f #f (lambda (opt name arg result arg-handler) (values (alist-cons 'bootstrap? #t result) #f))) - (option '("verbose") #f #f + (option '("verbose") #f #f ;deprecated (lambda (opt name arg result arg-handler) - (values (alist-cons 'verbose? #t result) + (values (alist-cons 'verbosity 2 + (alist-delete 'verbosity + result)) #f))) (option '("allow-collisions") #f #f (lambda (opt name arg result arg-handler) @@ -907,14 +916,12 @@ (define (handle-argument arg result arg-handler) (define opts (parse-command-line args %options (list %default-options #f) #:argument-handler handle-argument)) - (define verbose? - (assoc-ref opts 'verbose?)) (with-error-handling (or (process-query opts) (parameterize ((%store (open-connection)) (%graft? (assoc-ref opts 'graft?))) - (with-status-verbosity 1 + (with-status-verbosity (assoc-ref opts 'verbosity) (set-build-options-from-command-line (%store) opts) (parameterize ((%guile-for-build (package-derivation diff --git a/guix/scripts/pull.scm b/guix/scripts/pull.scm index 6389d5ec09..6d1914f7c2 100644 --- a/guix/scripts/pull.scm +++ b/guix/scripts/pull.scm @@ -66,7 +66,8 @@ (define %default-options (print-extended-build-trace? . #t) (multiplexed-build-output? . #t) (graft? . #t) - (verbosity . 0))) + (debug . 0) + (verbosity . 2))) (define (show-help) (display (G_ "Usage: guix pull [OPTION]... @@ -89,6 +90,8 @@ (define (show-help) (display (G_ " -n, --dry-run show what would be pulled and built")) (display (G_ " + -v, --verbosity=LEVEL use the given verbosity LEVEL")) + (display (G_ " -s, --system=SYSTEM attempt to build for SYSTEM--e.g., \"i686-linux\"")) (display (G_ " --bootstrap use the bootstrap Guile to build the new Guix")) @@ -135,6 +138,11 @@ (define %options (option '(#\n "dry-run") #f #f (lambda (opt name arg result) (alist-cons 'dry-run? #t (alist-cons 'graft? #f result)))) + (option '(#\v "verbosity") #t #f + (lambda (opt name arg result) + (let ((level (string->number* arg))) + (alist-cons 'verbosity level + (alist-delete 'verbosity result))))) (option '("bootstrap") #f #f (lambda (opt name arg result) (alist-cons 'bootstrap? #t result))) @@ -510,7 +518,7 @@ (define (guix-pull . args) (process-query opts profile)) (else (with-store store - (with-status-verbosity 2 + (with-status-verbosity (assoc-ref opts 'verbosity) (parameterize ((%current-system (assoc-ref opts 'system)) (%graft? (assoc-ref opts 'graft?)) (%repository-cache-directory cache)) diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm index 9e31baaddb..569b826acd 100644 --- a/guix/scripts/system.scm +++ b/guix/scripts/system.scm @@ -1015,6 +1015,8 @@ (define (show-help) --full-boot for 'vm', make a full boot sequence")) (display (G_ " --skip-checks skip file system and initrd module safety checks")) + (display (G_ " + -v, --verbosity=LEVEL use the given verbosity LEVEL")) (newline) (display (G_ " -h, --help display this help and exit")) @@ -1074,6 +1076,11 @@ (define %options (option '(#\n "dry-run") #f #f (lambda (opt name arg result) (alist-cons 'dry-run? #t (alist-cons 'graft? #f result)))) + (option '(#\v "verbosity") #t #f + (lambda (opt name arg result) + (let ((level (string->number* arg))) + (alist-cons 'verbosity level + (alist-delete 'verbosity result))))) (option '(#\s "system") #t #f (lambda (opt name arg result) (alist-cons 'system arg @@ -1092,7 +1099,8 @@ (define %default-options (print-extended-build-trace? . #t) (multiplexed-build-output? . #t) (graft? . #t) - (verbosity . 0) + (debug . 0) + (verbosity . #f) ;default (file-system-type . "ext4") (image-size . guess) (install-bootloader? . #t))) @@ -1267,8 +1275,9 @@ (define (fail) (args (option-arguments opts)) (command (assoc-ref opts 'action))) (parameterize ((%graft? (assoc-ref opts 'graft?))) - (with-status-verbosity (if (memq command '(init reconfigure)) - 1 2) + (with-status-verbosity (or (assoc-ref opts 'verbosity) + (if (memq command '(init reconfigure)) + 1 2)) (process-command command args opts)))))) ;;; Local Variables: -- cgit v1.2.3 From 7e634c2f530767c63d0c5773b5aad2351034ede4 Mon Sep 17 00:00:00 2001 From: Ricardo Wurmus Date: Fri, 11 Jan 2019 09:26:44 +0100 Subject: refresh: Suggest input changes when updating. * guix/upstream.scm ()[input-changes]: New field. (): New record. (upstream-input-change?, upstream-input-change-name, upstream-input-change-type, upstream-input-change-action, changed-inputs): New procedures. (package-update): Pass along input changes. * guix/script/refresh.scm (update-package): Process input changes. --- guix/scripts/refresh.scm | 23 ++++++++++++- guix/upstream.scm | 90 +++++++++++++++++++++++++++++++++++++++++++----- 2 files changed, 104 insertions(+), 9 deletions(-) (limited to 'guix/scripts') diff --git a/guix/scripts/refresh.scm b/guix/scripts/refresh.scm index 516e09b4ce..a0de9f6c10 100644 --- a/guix/scripts/refresh.scm +++ b/guix/scripts/refresh.scm @@ -6,6 +6,7 @@ ;;; Copyright © 2016 Ben Woodcroft ;;; Copyright © 2017 Mathieu Othacehe ;;; Copyright © 2018 Efraim Flashner +;;; Copyright © 2019 Ricardo Wurmus ;;; ;;; This file is part of GNU Guix. ;;; @@ -296,7 +297,7 @@ (define* (update-package store package updaters values: 'interactive' (default), 'always', and 'never'. When WARN? is true, warn about packages that have no matching updater." (if (lookup-updater package updaters) - (let-values (((version tarball) + (let-values (((version tarball changes) (package-update store package updaters #:key-download key-download)) ((loc) @@ -310,6 +311,26 @@ (define* (update-package store package updaters (location->string loc) (package-name package) (package-version package) version) + (for-each + (lambda (change) + (format (current-error-port) + (match (list (upstream-input-change-action change) + (upstream-input-change-type change)) + (('add 'regular) + (G_ "~a: consider adding this input: ~a~%")) + (('add 'native) + (G_ "~a: consider adding this native input: ~a~%")) + (('add 'propagated) + (G_ "~a: consider adding this propagated input: ~a~%")) + (('remove 'regular) + (G_ "~a: consider removing this input: ~a~%")) + (('remove 'native) + (G_ "~a: consider removing this native input: ~a~%")) + (('remove 'propagated) + (G_ "~a: consider removing this propagated input: ~a~%"))) + (package-name package) + (upstream-input-change-name change))) + (changes)) (let ((hash (call-with-input-file tarball port-sha256))) (update-package-source package version hash))) diff --git a/guix/upstream.scm b/guix/upstream.scm index 9e1056f7a7..9163478099 100644 --- a/guix/upstream.scm +++ b/guix/upstream.scm @@ -1,6 +1,7 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2010, 2011, 2012, 2013, 2014, 2015, 2016, 2017, 2018 Ludovic Courtès ;;; Copyright © 2015 Alex Kost +;;; Copyright © 2019 Ricardo Wurmus ;;; ;;; This file is part of GNU Guix. ;;; @@ -45,6 +46,7 @@ (define-module (guix upstream) upstream-source-urls upstream-source-signature-urls upstream-source-archive-types + upstream-source-input-changes url-prefix-predicate coalesce-sources @@ -56,6 +58,12 @@ (define-module (guix upstream) upstream-updater-predicate upstream-updater-latest + upstream-input-change? + upstream-input-change-name + upstream-input-change-type + upstream-input-change-action + changed-inputs + %updaters lookup-updater @@ -82,7 +90,73 @@ (define-record-type* (version upstream-source-version) ;string (urls upstream-source-urls) ;list of strings (signature-urls upstream-source-signature-urls ;#f | list of strings - (default #f))) + (default #f)) + (input-changes upstream-source-input-changes + (default '()) (thunked))) + +;; Representation of an upstream input change. +(define-record-type* + upstream-input-change make-upstream-input-change + upstream-input-change? + (name upstream-input-change-name) ;string + (type upstream-input-change-type) ;symbol: regular | native | propagated + (action upstream-input-change-action)) ;symbol: add | remove + +(define (changed-inputs package package-sexp) + "Return a list of input changes for PACKAGE based on the newly imported +S-expression PACKAGE-SEXP." + (match package-sexp + ((and expr ('package fields ...)) + (let* ((input->name (match-lambda ((name pkg . out) name))) + (new-regular + (match expr + ((path *** ('inputs + ('quasiquote ((label ('unquote sym)) ...)))) label) + (_ '()))) + (new-native + (match expr + ((path *** ('native-inputs + ('quasiquote ((label ('unquote sym)) ...)))) label) + (_ '()))) + (new-propagated + (match expr + ((path *** ('propagated-inputs + ('quasiquote ((label ('unquote sym)) ...)))) label) + (_ '()))) + (current-regular + (map input->name (package-inputs package))) + (current-native + (map input->name (package-native-inputs package))) + (current-propagated + (map input->name (package-propagated-inputs package)))) + (append-map + (match-lambda + ((action type names) + (map (lambda (name) + (upstream-input-change + (name name) + (type type) + (action action))) + names))) + `((add regular + ,(lset-difference equal? + new-regular current-regular)) + (remove regular + ,(lset-difference equal? + current-regular new-regular)) + (add native + ,(lset-difference equal? + new-native current-native)) + (remove native + ,(lset-difference equal? + current-native new-native)) + (add propagated + ,(lset-difference equal? + new-propagated current-propagated)) + (remove propagated + ,(lset-difference equal? + current-propagated new-propagated)))))) + (_ '()))) (define (url-prefix-predicate prefix) "Return a predicate that returns true when passed a package where one of its @@ -268,12 +342,12 @@ (define (find2 pred lst1 lst2) (define* (package-update store package updaters #:key (key-download 'interactive)) - "Return the new version and the file name of the new version tarball for -PACKAGE, or #f and #f when PACKAGE is up-to-date. KEY-DOWNLOAD specifies a -download policy for missing OpenPGP keys; allowed values: 'always', 'never', -and 'interactive' (default)." + "Return the new version, the file name of the new version tarball, and input +changes for PACKAGE; return #f (three values) when PACKAGE is up-to-date. +KEY-DOWNLOAD specifies a download policy for missing OpenPGP keys; allowed +values: 'always', 'never', and 'interactive' (default)." (match (package-latest-release* package updaters) - (($ _ version urls signature-urls) + (($ _ version urls signature-urls changes) (let*-values (((name) (package-name package)) ((archive-type) @@ -299,9 +373,9 @@ (define* (package-update store package updaters (or signature-urls (circular-list #f))))) (let ((tarball (download-tarball store url signature-url #:key-download key-download))) - (values version tarball)))) + (values version tarball changes)))) (#f - (values #f #f)))) + (values #f #f #f)))) (define (update-package-source package version hash) "Modify the source file that defines PACKAGE to refer to VERSION, -- cgit v1.2.3 From 60029204eebada88063c2d3e2727e255ded22159 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 14 Jan 2019 17:20:28 +0100 Subject: pull: Don't prepend "origin/" to branch names. This is a followup to 37a6cdbf1b3503d3e60840a176318284b1f7ca25. * guix/scripts/pull.scm (%options): Don't prepend "origin/" to branch names. --- guix/scripts/pull.scm | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) (limited to 'guix/scripts') diff --git a/guix/scripts/pull.scm b/guix/scripts/pull.scm index 6d1914f7c2..0339b149fa 100644 --- a/guix/scripts/pull.scm +++ b/guix/scripts/pull.scm @@ -125,8 +125,7 @@ (define %options (alist-cons 'ref `(commit . ,arg) result))) (option '("branch") #t #f (lambda (opt name arg result) - (alist-cons 'ref `(branch . ,(string-append "origin/" arg)) - result))) + (alist-cons 'ref `(branch . ,arg) result))) (option '(#\p "profile") #t #f (lambda (opt name arg result) (alist-cons 'profile (canonicalize-profile arg) -- cgit v1.2.3 From 0ee1e47edba609a614538b043befd8aa8d95ab83 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 14 Jan 2019 23:41:30 +0100 Subject: copy: Add '--verbosity'. This fixes a regression introduced in f1de676ea82c2bed9a435fce37ade0186296bfc9 since %DEFAULT-OPTIONS was missing the 'debug key that 'set-build-options-from-command-line' expects. * guix/scripts/copy.scm (show-help, %options): Add '--verbosity'. (%default-options): Rename 'verbosity' to 'debug'. Add 'print-build-trace?', 'print-extended-build-trace?', 'multiplexed-build-output?', and 'verbosity'. (guix-copy): Wrap body in 'with-status-verbosity'. --- guix/scripts/copy.scm | 23 ++++++++++++++++++----- 1 file changed, 18 insertions(+), 5 deletions(-) (limited to 'guix/scripts') diff --git a/guix/scripts/copy.scm b/guix/scripts/copy.scm index 4c85929858..be4ce4364b 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 Ludovic Courtès +;;; Copyright © 2016, 2017, 2019 Ludovic Courtès ;;; ;;; This file is part of GNU Guix. ;;; @@ -21,6 +21,7 @@ (define-module (guix scripts copy) #:use-module (guix scripts) #:use-module (guix ssh) #:use-module (guix store) + #:use-module (guix status) #:use-module (guix utils) #:use-module (guix derivations) #:use-module (guix scripts build) @@ -116,6 +117,8 @@ (define (show-help) --to=HOST send ITEMS to HOST")) (display (G_ " --from=HOST receive ITEMS from HOST")) + (display (G_ " + -v, --verbosity=LEVEL use the given verbosity LEVEL")) (newline) (show-build-options-help) (newline) @@ -134,6 +137,11 @@ (define %options (option '("from") #t #f (lambda (opt name arg result) (alist-cons 'source arg result))) + (option '(#\v "verbosity") #t #f + (lambda (opt name arg result) + (let ((level (string->number* arg))) + (alist-cons 'verbosity level + (alist-delete 'verbosity result))))) (option '(#\h "help") #f #f (lambda args (show-help) @@ -152,7 +160,11 @@ (define %default-options (substitutes? . #t) (build-hook? . #t) (graft? . #t) - (verbosity . 0))) + (print-build-trace? . #t) + (print-extended-build-trace? . #t) + (multiplexed-build-output? . #t) + (debug . 0) + (verbosity . 2))) ;;; @@ -164,6 +176,7 @@ (define (guix-copy . args) (let* ((opts (parse-command-line args %options (list %default-options))) (source (assoc-ref opts 'source)) (target (assoc-ref opts 'destination))) - (cond (target (send-to-remote-host target opts)) - (source (retrieve-from-remote-host source opts)) - (else (leave (G_ "use '--to' or '--from'~%"))))))) + (with-status-verbosity (assoc-ref opts 'verbosity) + (cond (target (send-to-remote-host target opts)) + (source (retrieve-from-remote-host source opts)) + (else (leave (G_ "use '--to' or '--from'~%")))))))) -- cgit v1.2.3 From 35225dc57996ebc7a5a55462e0e52d85239195d9 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 15 Jan 2019 11:31:16 +0100 Subject: guix package: '--upgrade' preserves package order. Fixes . Reported by Chris Marusich . * guix/scripts/package.scm (options->installable)[upgraded]: Use 'fold' instead of 'fold-right'. This reverts eca16a3d1d9e6b2c064e0105c1015258bf2755f2. * tests/guix-package-net.sh: Add 'guix package u' test. --- guix/scripts/package.scm | 12 ++++++------ tests/guix-package-net.sh | 33 ++++++++++++++++++++++++++++++++- 2 files changed, 38 insertions(+), 7 deletions(-) (limited to 'guix/scripts') diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm index 7ff6bfd6d8..5a8fd203ee 100644 --- a/guix/scripts/package.scm +++ b/guix/scripts/package.scm @@ -604,12 +604,12 @@ (define upgrade? (options->upgrade-predicate opts)) (define upgraded - (fold-right (lambda (entry transaction) - (if (upgrade? (manifest-entry-name entry)) - (transaction-upgrade-entry entry transaction) - transaction)) - transaction - (manifest-entries manifest))) + (fold (lambda (entry transaction) + (if (upgrade? (manifest-entry-name entry)) + (transaction-upgrade-entry entry transaction) + transaction)) + transaction + (manifest-entries manifest))) (define to-install (filter-map (match-lambda diff --git a/tests/guix-package-net.sh b/tests/guix-package-net.sh index 927c856b23..82c346dd4c 100644 --- a/tests/guix-package-net.sh +++ b/tests/guix-package-net.sh @@ -1,5 +1,5 @@ # GNU Guix --- Functional package management for GNU -# Copyright © 2012, 2013, 2014, 2015, 2017 Ludovic Courtès +# Copyright © 2012, 2013, 2014, 2015, 2017, 2019 Ludovic Courtès # Copyright © 2013 Nikita Karetnikov # # This file is part of GNU Guix. @@ -167,6 +167,37 @@ then false; fi guix package -p "$profile" -p "$profile_alt" --search-paths \ | grep "LIBRARY_PATH.*$profile/lib.$profile_alt/lib" +# Simulate an upgrade and make sure the package order is preserved. +module_dir="t-guix-package-net-$$" +trap 'rm -rf "$module_dir"' EXIT + +mkdir "$module_dir" +cat > "$module_dir/new.scm" < Date: Fri, 11 Jan 2019 15:17:10 +0100 Subject: guix package: Avoid 'find-newest-available-packages'. * guix/scripts/package.scm (transaction-upgrade-entry): Use 'find-best-packages-by-name' instead of 'find-newest-available-packages'. * tests/packages.scm ("transaction-upgrade-entry, zero upgrades") ("transaction-upgrade-entry, one upgrade") ("transaction-upgrade-entry, superseded package"): Adjust accordingly. --- guix/scripts/package.scm | 51 ++++++++++++++++++++++++------------------------ tests/packages.scm | 14 ++++++------- 2 files changed, 33 insertions(+), 32 deletions(-) (limited to 'guix/scripts') diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm index 5a8fd203ee..ba33790eda 100644 --- a/guix/scripts/package.scm +++ b/guix/scripts/package.scm @@ -220,31 +220,32 @@ (define (supersede old new) ('dismiss transaction) (($ name version output (? string? path)) - (match (vhash-assoc name (find-newest-available-packages)) - ((_ candidate-version pkg . rest) - (match (package-superseded pkg) - ((? package? new) - (supersede entry new)) - (#f - (case (version-compare candidate-version version) - ((>) - (manifest-transaction-install-entry - (package->manifest-entry* pkg output) - transaction)) - ((<) - transaction) - ((=) - (let ((candidate-path (derivation->output-path - (package-derivation (%store) pkg)))) - ;; XXX: When there are propagated inputs, assume we need to - ;; upgrade the whole entry. - (if (and (string=? path candidate-path) - (null? (package-propagated-inputs pkg))) - transaction - (manifest-transaction-install-entry - (package->manifest-entry* pkg output) - transaction)))))))) - (#f + (match (find-best-packages-by-name name #f) + ((pkg . rest) + (let ((candidate-version (package-version pkg))) + (match (package-superseded pkg) + ((? package? new) + (supersede entry new)) + (#f + (case (version-compare candidate-version version) + ((>) + (manifest-transaction-install-entry + (package->manifest-entry* pkg output) + transaction)) + ((<) + transaction) + ((=) + (let ((candidate-path (derivation->output-path + (package-derivation (%store) pkg)))) + ;; XXX: When there are propagated inputs, assume we need to + ;; upgrade the whole entry. + (if (and (string=? path candidate-path) + (null? (package-propagated-inputs pkg))) + transaction + (manifest-transaction-install-entry + (package->manifest-entry* pkg output) + transaction))))))))) + (() (warning (G_ "package '~a' no longer exists~%") name) transaction))))) diff --git a/tests/packages.scm b/tests/packages.scm index 237feb7aba..eb8ede3207 100644 --- a/tests/packages.scm +++ b/tests/packages.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018 Ludovic Courtès +;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019 Ludovic Courtès ;;; ;;; This file is part of GNU Guix. ;;; @@ -96,8 +96,8 @@ (define %store (test-assert "transaction-upgrade-entry, zero upgrades" (let* ((old (dummy-package "foo" (version "1"))) - (tx (mock ((gnu packages) find-newest-available-packages - (const vlist-null)) + (tx (mock ((gnu packages) find-best-packages-by-name + (const '())) ((@@ (guix scripts package) transaction-upgrade-entry) (manifest-entry (inherit (package->manifest-entry old)) @@ -109,8 +109,8 @@ (define %store (test-assert "transaction-upgrade-entry, one upgrade" (let* ((old (dummy-package "foo" (version "1"))) (new (dummy-package "foo" (version "2"))) - (tx (mock ((gnu packages) find-newest-available-packages - (const (vhash-cons "foo" (list "2" new) vlist-null))) + (tx (mock ((gnu packages) find-best-packages-by-name + (const (list new))) ((@@ (guix scripts package) transaction-upgrade-entry) (manifest-entry (inherit (package->manifest-entry old)) @@ -126,8 +126,8 @@ (define %store (let* ((old (dummy-package "foo" (version "1"))) (new (dummy-package "bar" (version "2"))) (dep (deprecated-package "foo" new)) - (tx (mock ((gnu packages) find-newest-available-packages - (const (vhash-cons "foo" (list "2" dep) vlist-null))) + (tx (mock ((gnu packages) find-best-packages-by-name + (const (list dep))) ((@@ (guix scripts package) transaction-upgrade-entry) (manifest-entry (inherit (package->manifest-entry old)) -- cgit v1.2.3 From 5fbdc9a5aa63fd51c65d30fe3d30608d01fe1bc8 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 11 Jan 2019 17:23:39 +0100 Subject: channels: Compute a package cache and use it. * gnu/packages.scm (cache-is-authoritative?, load-package-cache) (cache-lookup, generate-package-cache): New procedures. (%package-cache-file): New variable. (find-packages-by-name): Rename to... (find-packages-by-name/direct): ... this. (find-packages-by-name): Rewrite to use the package cache when 'cache-is-authoritative?' returns true. * tests/packages.scm ("find-packages-by-name + version, with cache") ("find-packages-by-name with cache"): New tests. * guix/channels.scm (package-cache-file): New procedure. (%channel-profile-hooks): New variable. (channel-instances->derivation): Use it in #:hooks. * guix/scripts/package.scm (build-and-use-profile): Add #:hooks and honor it. * guix/scripts/pull.scm (build-and-install): Pass #:hooks to UPDATE-PROFILE. --- gnu/packages.scm | 127 +++++++++++++++++++++++++++++++++++++++++++++-- guix/channels.scm | 36 +++++++++++++- guix/scripts/package.scm | 8 +-- guix/scripts/pull.scm | 1 + tests/packages.scm | 18 +++++++ 5 files changed, 181 insertions(+), 9 deletions(-) (limited to 'guix/scripts') diff --git a/gnu/packages.scm b/gnu/packages.scm index 4a85cf4b87..6796db80a4 100644 --- a/gnu/packages.scm +++ b/gnu/packages.scm @@ -28,11 +28,14 @@ (define-module (gnu packages) #:use-module (guix memoization) #:use-module ((guix build utils) #:select ((package-name->name+version - . hyphen-separated-name->name+version))) + . hyphen-separated-name->name+version) + mkdir-p)) #:autoload (guix profiles) (packages->manifest) #:use-module (guix describe) #:use-module (ice-9 vlist) #:use-module (ice-9 match) + #:autoload (ice-9 binary-ports) (put-bytevector) + #:autoload (system base compile) (compile) #:use-module (srfi srfi-1) #:use-module (srfi srfi-11) #:use-module (srfi srfi-26) @@ -56,7 +59,9 @@ (define-module (gnu packages) specification->package specification->package+output - specifications->manifest)) + specifications->manifest + + generate-package-cache)) ;;; Commentary: ;;; @@ -135,6 +140,14 @@ (define %default-package-module-path ;; Default search path for package modules. `((,%distro-root-directory . "gnu/packages"))) +(define (cache-is-authoritative?) + "Return true if the pre-computed package cache is authoritative. It is not +authoritative when entries have been added via GUIX_PACKAGE_PATH or '-L' +flags." + (equal? (%package-module-path) + (append %default-package-module-path + (package-path-entries)))) + (define %package-module-path ;; Search path for package modules. Each item must be either a directory ;; name or a pair whose car is a directory and whose cdr is a sub-directory @@ -183,7 +196,35 @@ (define* (fold-packages proc init init modules)) -(define find-packages-by-name +(define %package-cache-file + ;; Location of the package cache. + "/lib/guix/package.cache") + +(define load-package-cache + (mlambda (profile) + "Attempt to load the package cache. On success return a vhash keyed by +package names. Return #f on failure." + (match profile + (#f #f) + (profile + (catch 'system-error + (lambda () + (define lst + (load-compiled (string-append profile %package-cache-file))) + (fold (lambda (item vhash) + (match item + (#(name version module symbol outputs + supported? deprecated? + file line column) + (vhash-cons name item vhash)))) + vlist-null + lst)) + (lambda args + (if (= ENOENT (system-error-errno args)) + #f + (apply throw args)))))))) + +(define find-packages-by-name/direct ;bypass the cache (let ((packages (delay (fold-packages (lambda (p r) (vhash-cons (package-name p) p r)) @@ -202,6 +243,37 @@ (define find-packages-by-name matching) matching))))) +(define (cache-lookup cache name) + "Lookup package NAME in CACHE. Return a list sorted in increasing version +order." + (define (package-version? (vector-ref v2 1) (vector-ref v1 1))) + + (sort (vhash-fold* cons '() name cache) + package-versionbool (member (%current-system) + (package-supported-systems package))) + ,(->bool (package-superseded package)) + ,@(let ((loc (package-location package))) + (if loc + `(,(location-file loc) + ,(location-line loc) + ,(location-column loc)) + '(#f #f #f)))) + result))) + (_ + result))) + + (define exp + (fold-module-public-variables* expand-cache '() + (all-modules (%package-module-path) + #:warn + warn-about-load-error))) + + (mkdir-p (dirname cache-file)) + (call-with-output-file cache-file + (lambda (port) + ;; Store the cache as a '.go' file. This makes loading fast and reduces + ;; heap usage since some of the static data is directly mmapped. + (put-bytevector port + (compile `'(,@exp) + #:to 'bytecode + #:opts '(#:to-file? #t))))) + cache-file) + (define %sigint-prompt ;; The prompt to jump to upon SIGINT. diff --git a/guix/channels.scm b/guix/channels.scm index 6b860f3bd8..cd8a0131bd 100644 --- a/guix/channels.scm +++ b/guix/channels.scm @@ -21,6 +21,7 @@ (define-module (guix channels) #:use-module (guix git) #:use-module (guix records) #:use-module (guix gexp) + #:use-module (guix modules) #:use-module (guix discovery) #:use-module (guix monads) #:use-module (guix profiles) @@ -31,7 +32,8 @@ (define-module (guix channels) #:use-module (srfi srfi-2) #:use-module (srfi srfi-9) #:use-module (srfi srfi-11) - #:autoload (guix self) (whole-package) + #:autoload (guix self) (whole-package make-config.scm) + #:autoload (guix inferior) (gexp->derivation-in-inferior) ;FIXME: circular dep #:use-module (ice-9 match) #:export (channel channel? @@ -52,6 +54,7 @@ (define-module (guix channels) checkout->channel-instance latest-channel-derivation channel-instances->manifest + %channel-profile-hooks channel-instances->derivation)) ;;; Commentary: @@ -416,11 +419,40 @@ (define instance->entry (zip instances derivations)))) (return (manifest entries)))) +(define (package-cache-file manifest) + "Build a package cache file for the instance in MANIFEST. This is meant to +be used as a profile hook." + (mlet %store-monad ((profile (profile-derivation manifest + #:hooks '()))) + + (define build + #~(begin + (use-modules (gnu packages)) + + (if (defined? 'generate-package-cache) + (begin + ;; Delegate package cache generation to the inferior. + (format (current-error-port) + "Generating package cache for '~a'...~%" + #$profile) + (generate-package-cache #$output)) + (mkdir #$output)))) + + (gexp->derivation-in-inferior "guix-package-cache" build + profile + #:properties '((type . profile-hook) + (hook . package-cache))))) + +(define %channel-profile-hooks + ;; The default channel profile hooks. + (cons package-cache-file %default-profile-hooks)) + (define (channel-instances->derivation instances) "Return the derivation of the profile containing INSTANCES, a list of channel instances." (mlet %store-monad ((manifest (channel-instances->manifest instances))) - (profile-derivation manifest))) + (profile-derivation manifest + #:hooks %channel-profile-hooks))) (define latest-channel-instances* (store-lift latest-channel-instances)) diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm index ba33790eda..e9bed0be1e 100644 --- a/guix/scripts/package.scm +++ b/guix/scripts/package.scm @@ -120,21 +120,21 @@ (define (delete-matching-generations store profile pattern) (define* (build-and-use-profile store profile manifest #:key + (hooks %default-profile-hooks) allow-collisions? bootstrap? use-substitutes? dry-run?) "Build a new generation of PROFILE, a file name, using the packages specified in MANIFEST, a manifest object. When ALLOW-COLLISIONS? is true, -do not treat collisions in MANIFEST as an error." +do not treat collisions in MANIFEST as an error. HOOKS is a list of \"profile +hooks\" run when building the profile." (when (equal? profile %current-profile) (ensure-default-profile)) (let* ((prof-drv (run-with-store store (profile-derivation manifest #:allow-collisions? allow-collisions? - #:hooks (if bootstrap? - '() - %default-profile-hooks) + #:hooks (if bootstrap? '() hooks) #:locales? (not bootstrap?)))) (prof (derivation->output-path prof-drv))) (show-what-to-build store (list prof-drv) diff --git a/guix/scripts/pull.scm b/guix/scripts/pull.scm index 0339b149fa..513434c5f1 100644 --- a/guix/scripts/pull.scm +++ b/guix/scripts/pull.scm @@ -188,6 +188,7 @@ (define update-profile (mlet %store-monad ((manifest (channel-instances->manifest instances))) (mbegin %store-monad (update-profile profile manifest + #:hooks %channel-profile-hooks #:dry-run? dry-run?) (munless dry-run? (return (display-profile-news profile)))))) diff --git a/tests/packages.scm b/tests/packages.scm index eb8ede3207..2720ba5a15 100644 --- a/tests/packages.scm +++ b/tests/packages.scm @@ -1005,6 +1005,24 @@ (define read-at (((? (cut eq? hello <>))) #t) (wrong (pk 'find-packages-by-name wrong #f)))) +(test-equal "find-packages-by-name with cache" + (find-packages-by-name "guile") + (call-with-temporary-directory + (lambda (cache) + (generate-package-cache cache) + (mock ((guix describe) current-profile (const cache)) + (mock ((gnu packages) cache-is-authoritative? (const #t)) + (find-packages-by-name "guile")))))) + +(test-equal "find-packages-by-name + version, with cache" + (find-packages-by-name "guile" "2") + (call-with-temporary-directory + (lambda (cache) + (generate-package-cache cache) + (mock ((guix describe) current-profile (const cache)) + (mock ((gnu packages) cache-is-authoritative? (const #t)) + (find-packages-by-name "guile" "2")))))) + (test-assert "--search-paths with pattern" ;; Make sure 'guix package --search-paths' correctly reports environment ;; variables when file patterns are used (in particular, it must follow -- cgit v1.2.3 From ee8099f5b688ce5f57790db4122f0b5b91a26216 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sun, 13 Jan 2019 14:27:10 +0100 Subject: edit: Use 'specification->location' to read information from the cache. That way 'guix edit' doesn't need to load any package module. * gnu/packages.scm (find-package-locations, specification->location): New procedures. * guix/scripts/edit.scm (package->location-specification): Rename to... (location->location-specification): ... this. Expect a location object instead of a package. (guix-edit): Use 'specification->location' instead of 'specification->package'. * tests/packages.scm ("find-package-locations") ("find-package-locations with cache") ("specification->location"): New tests. --- gnu/packages.scm | 51 +++++++++++++++++++++++++++++++++++++++++++++++++++ guix/scripts/edit.scm | 29 +++++++++++------------------ tests/packages.scm | 23 +++++++++++++++++++++++ 3 files changed, 85 insertions(+), 18 deletions(-) (limited to 'guix/scripts') diff --git a/gnu/packages.scm b/gnu/packages.scm index 6796db80a4..cf655e7448 100644 --- a/gnu/packages.scm +++ b/gnu/packages.scm @@ -55,10 +55,12 @@ (define-module (gnu packages) fold-packages find-packages-by-name + find-package-locations find-best-packages-by-name specification->package specification->package+output + specification->location specifications->manifest generate-package-cache)) @@ -274,6 +276,31 @@ (define cache versions modules symbols))) (find-packages-by-name/direct name version))) +(define* (find-package-locations name #:optional version) + "Return a list of version/location pairs corresponding to each package +matching NAME and VERSION." + (define cache + (load-package-cache (current-profile))) + + (if (and cache (cache-is-authoritative?)) + (match (cache-lookup cache name) + (#f '()) + ((#(name versions modules symbols outputs + supported? deprecated? + files lines columns) ...) + (fold (lambda (version* file line column result) + (if (and file + (or (not version) + (version-prefix? version version*))) + (alist-cons version* (location file line column) + result) + result)) + '() + versions files lines columns))) + (map (lambda (package) + (cons (package-version package) (package-location package))) + (find-packages-by-name/direct name version)))) + (define (find-best-packages-by-name name version) "If version is #f, return the list of packages named NAME with the highest version numbers; otherwise, return the list of packages named NAME and at @@ -393,6 +420,30 @@ (define (specification->package spec) (let-values (((name version) (package-name->name+version spec))) (%find-package spec name version))) +(define (specification->location spec) + "Return the location of the highest-numbered package matching SPEC, a +specification such as \"guile@2\" or \"emacs\"." + (let-values (((name version) (package-name->name+version spec))) + (match (find-package-locations name version) + (() + (if version + (leave (G_ "~A: package not found for version ~a~%") name version) + (leave (G_ "~A: unknown package~%") name))) + (lst + (let* ((highest (match lst (((version . _) _ ...) version))) + (locations (take-while (match-lambda + ((version . location) + (string=? version highest))) + lst))) + (match locations + (((version . location) . rest) + (unless (null? rest) + (warning (G_ "ambiguous package specification `~a'~%") spec) + (warning (G_ "choosing ~a@~a from ~a~%") + name version + (location->string location))) + location))))))) + (define* (specification->package+output spec #:optional (output "out")) "Return the package and output specified by SPEC, or #f and #f; SPEC may optionally contain a version number and an output name, as in these examples: diff --git a/guix/scripts/edit.scm b/guix/scripts/edit.scm index 8b2b61d76a..da3d2775e8 100644 --- a/guix/scripts/edit.scm +++ b/guix/scripts/edit.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2015, 2016 Ludovic Courtès +;;; Copyright © 2015, 2016, 2019 Ludovic Courtès ;;; Copyright © 2015 Mathieu Lirzin ;;; ;;; This file is part of GNU Guix. @@ -21,7 +21,6 @@ (define-module (guix scripts edit) #:use-module (guix ui) #:use-module (guix scripts) #:use-module (guix utils) - #:use-module (guix packages) #:use-module (gnu packages) #:use-module (srfi srfi-1) #:use-module (srfi srfi-37) @@ -63,14 +62,13 @@ (define (search-path* path file) file path)) absolute-file-name)) -(define (package->location-specification package) - "Return the location specification for PACKAGE for a typical editor command +(define (location->location-specification location) + "Return the location specification for LOCATION for a typical editor command line." - (let ((loc (package-location package))) - (list (string-append "+" - (number->string - (location-line loc))) - (search-path* %load-path (location-file loc))))) + (list (string-append "+" + (number->string + (location-line location))) + (search-path* %load-path (location-file location)))) (define (guix-edit . args) @@ -83,18 +81,13 @@ (define (parse-arguments) '())) (with-error-handling - (let* ((specs (reverse (parse-arguments))) - (packages (map specification->package specs))) - (for-each (lambda (package) - (unless (package-location package) - (leave (G_ "source location of package '~a' is unknown~%") - (package-full-name package)))) - packages) + (let* ((specs (reverse (parse-arguments))) + (locations (map specification->location specs))) (catch 'system-error (lambda () - (let ((file-names (append-map package->location-specification - packages))) + (let ((file-names (append-map location->location-specification + locations))) ;; Use `system' instead of `exec' in order to sanely handle ;; possible command line arguments in %EDITOR. (exit (system (string-join (cons (%editor) file-names)))))) diff --git a/tests/packages.scm b/tests/packages.scm index 2720ba5a15..8aa117a2e7 100644 --- a/tests/packages.scm +++ b/tests/packages.scm @@ -1131,6 +1131,29 @@ (define read-at (lambda (key . args) key))) +(test-equal "find-package-locations" + (map (lambda (package) + (cons (package-version package) + (package-location package))) + (find-packages-by-name "guile")) + (find-package-locations "guile")) + +(test-equal "find-package-locations with cache" + (map (lambda (package) + (cons (package-version package) + (package-location package))) + (find-packages-by-name "guile")) + (call-with-temporary-directory + (lambda (cache) + (generate-package-cache cache) + (mock ((guix describe) current-profile (const cache)) + (mock ((gnu packages) cache-is-authoritative? (const #t)) + (find-package-locations "guile")))))) + +(test-equal "specification->location" + (package-location (specification->package "guile@2")) + (specification->location "guile@2")) + (test-end "packages") ;;; Local Variables: -- cgit v1.2.3 From 0ea939fb796fdd4f0d46d3534b2ec6135e0f3dc7 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sun, 13 Jan 2019 15:36:49 +0100 Subject: guix package: '--list-available' can use data from the cache. * gnu/packages.scm (fold-available-packages): New procedure. * guix/scripts/package.scm (process-query): Use it instead of 'fold-packages'. * tests/packages.scm ("fold-available-packages with/without cache"): New test. --- gnu/packages.scm | 45 +++++++++++++++++++++++++++++++++++++++++++++ guix/scripts/package.scm | 45 +++++++++++++++++++++++++-------------------- tests/packages.scm | 22 ++++++++++++++++++++++ 3 files changed, 92 insertions(+), 20 deletions(-) (limited to 'guix/scripts') diff --git a/gnu/packages.scm b/gnu/packages.scm index cf655e7448..a1814205f9 100644 --- a/gnu/packages.scm +++ b/gnu/packages.scm @@ -53,6 +53,7 @@ (define-module (gnu packages) %default-package-module-path fold-packages + fold-available-packages find-packages-by-name find-package-locations @@ -182,6 +183,50 @@ (define %patch-path directory)) %load-path))) +(define (fold-available-packages proc init) + "Fold PROC over the list of available packages. For each available package, +PROC is called along these lines: + + (PROC NAME VERSION RESULT + #:outputs OUTPUTS + #:location LOCATION + …) + +PROC can use #:allow-other-keys to ignore the bits it's not interested in. +When a package cache is available, this procedure does not actually load any +package module." + (define cache + (load-package-cache (current-profile))) + + (if (and cache (cache-is-authoritative?)) + (vhash-fold (lambda (name vector result) + (match vector + (#(name version module symbol outputs + supported? deprecated? + file line column) + (proc name version result + #:outputs outputs + #:location (and file + (location file line column)) + #:supported? supported? + #:deprecated? deprecated?)))) + init + cache) + (fold-packages (lambda (package result) + (proc (package-name package) + (package-version package) + result + #:outputs (package-outputs package) + #:location (package-location package) + #:supported? + (->bool + (member (%current-system) + (package-supported-systems package))) + #:deprecated? + (->bool + (package-superseded package)))) + init))) + (define* (fold-packages proc init #:optional (modules (all-modules (%package-module-path) diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm index e9bed0be1e..a633d2ee6d 100644 --- a/guix/scripts/package.scm +++ b/guix/scripts/package.scm @@ -736,29 +736,34 @@ (define (diff-profiles profile numbers) (('list-available regexp) (let* ((regexp (and regexp (make-regexp* regexp))) - (available (fold-packages - (lambda (p r) - (let ((n (package-name p))) - (if (and (supported-package? p) - (not (package-superseded p))) - (if regexp - (if (regexp-exec regexp n) - (cons p r) - r) - (cons p r)) - r))) + (available (fold-available-packages + (lambda* (name version result + #:key outputs location + supported? superseded? + #:allow-other-keys) + (if (and supported? (not superseded?)) + (if regexp + (if (regexp-exec regexp name) + (cons `(,name ,version + ,outputs ,location) + result) + result) + (cons `(,name ,version + ,outputs ,location) + result)) + result)) '()))) (leave-on-EPIPE - (for-each (lambda (p) - (format #t "~a\t~a\t~a\t~a~%" - (package-name p) - (package-version p) - (string-join (package-outputs p) ",") - (location->string (package-location p)))) + (for-each (match-lambda + ((name version outputs location) + (format #t "~a\t~a\t~a\t~a~%" + name version + (string-join outputs ",") + (location->string location)))) (sort available - (lambda (p1 p2) - (string))) #t) -- cgit v1.2.3 From 8e9ca3ea2c32c9e8c19b823a3fc5842020b00d36 Mon Sep 17 00:00:00 2001 From: Ricardo Wurmus Date: Thu, 17 Jan 2019 17:37:44 +0100 Subject: scripts: Fix typo. * guix/scripts/download.scm (show-help): Fix typo. --- guix/scripts/download.scm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'guix/scripts') diff --git a/guix/scripts/download.scm b/guix/scripts/download.scm index b9162d3449..d8fe71ce12 100644 --- a/guix/scripts/download.scm +++ b/guix/scripts/download.scm @@ -77,7 +77,7 @@ (define (show-help) (format #t (G_ " --no-check-certificate do not validate the certificate of HTTPS servers ")) - (format #f (G_ " + (format #t (G_ " -o, --output=FILE download to FILE")) (newline) (display (G_ " -- cgit v1.2.3 From 3bbd6919bd84b76686d1aa626ba861faf3fc8ceb Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 18 Jan 2019 14:59:59 +0100 Subject: pull: Suggest running 'hash guix' if needed. Fixes . Suggested by Diego Nicola Barbato . * guix/scripts/pull.scm (build-and-install): Before returning, display a hint if (which "guix") is not in PROFILE. --- guix/scripts/pull.scm | 14 ++++++++++++-- 1 file changed, 12 insertions(+), 2 deletions(-) (limited to 'guix/scripts') diff --git a/guix/scripts/pull.scm b/guix/scripts/pull.scm index 513434c5f1..d3a4401a01 100644 --- a/guix/scripts/pull.scm +++ b/guix/scripts/pull.scm @@ -34,11 +34,12 @@ (define-module (guix scripts pull) #:use-module (guix channels) #:autoload (guix inferior) (open-inferior) #:use-module (guix scripts build) + #:autoload (guix build utils) (which) #:use-module (guix git) #:use-module (git) #:use-module (gnu packages) #:use-module ((guix scripts package) #:select (build-and-use-profile)) - #:use-module (gnu packages base) + #:use-module ((gnu packages base) #:select (canonical-package)) #:use-module (gnu packages guile) #:use-module ((gnu packages bootstrap) #:select (%bootstrap-guile)) @@ -191,7 +192,16 @@ (define update-profile #:hooks %channel-profile-hooks #:dry-run? dry-run?) (munless dry-run? - (return (display-profile-news profile)))))) + (return (display-profile-news profile)) + (match (which "guix") + (#f (return #f)) + (str + (let ((command (string-append profile "/bin/guix"))) + (unless (string=? command str) + (display-hint (format #f (G_ "After setting @code{PATH}, run +@command{hash guix} to make sure your shell refers to @file{~a}.") + command))) + (return #f)))))))) (define (honor-lets-encrypt-certificates! store) "Tell Guile-Git to use the Let's Encrypt certificates." -- cgit v1.2.3 From 4e1f9a2f2c242a06221693550b1227b41bb4bd90 Mon Sep 17 00:00:00 2001 From: Efraim Flashner Date: Sun, 20 Jan 2019 11:43:16 +0200 Subject: lint: check-source-unstable-tarball: Don't assume uri length. * guix/scripts/lint.scm (check-source-unstable-tarball): Replace third with code to make sure there are enough elements to check. --- guix/scripts/lint.scm | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) (limited to 'guix/scripts') diff --git a/guix/scripts/lint.scm b/guix/scripts/lint.scm index 0f315a9352..665adcfb8d 100644 --- a/guix/scripts/lint.scm +++ b/guix/scripts/lint.scm @@ -758,9 +758,10 @@ (define (check-source-unstable-tarball package) "Emit a warning if PACKAGE's source is an autogenerated tarball." (define (check-source-uri uri) (when (and (string=? (uri-host (string->uri uri)) "github.com") - (string=? (third (split-and-decode-uri-path - (uri-path (string->uri uri)))) - "archive")) + (match (split-and-decode-uri-path + (uri-path (string->uri uri))) + ((_ _ "archive" _ ...) #t) + (_ #f))) (emit-warning package (G_ "the source URI should not be an autogenerated tarball") 'source))) -- cgit v1.2.3 From c49b45c917eff17122aea5f7a57ae4cef02f1003 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sun, 20 Jan 2019 23:53:26 +0100 Subject: pull: Add missing import. Fixes . Reported by Pierre Neidhardt . Fixes wrong-type-arg crash of "guix pull -p /does-not-exist -l". * guix/scripts/pull.scm: Use (srfi srfi-34). --- guix/scripts/pull.scm | 1 + 1 file changed, 1 insertion(+) (limited to 'guix/scripts') diff --git a/guix/scripts/pull.scm b/guix/scripts/pull.scm index d3a4401a01..41c7fb289a 100644 --- a/guix/scripts/pull.scm +++ b/guix/scripts/pull.scm @@ -46,6 +46,7 @@ (define-module (guix scripts pull) #:use-module ((gnu packages certs) #:select (le-certs)) #:use-module (srfi srfi-1) #:use-module (srfi srfi-26) + #:use-module (srfi srfi-34) #:use-module (srfi srfi-35) #:use-module (srfi srfi-37) #:use-module (ice-9 match) -- cgit v1.2.3 From f9e8a12379c6fefc9e5c3c7fc3926599bbefc013 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 21 Jan 2019 17:41:11 +0100 Subject: store: Rename '&nix-error' to '&store-error'. * guix/store.scm (&nix-error): Rename to... (&store-error): ... this, and adjust users. (&nix-connection-error): Rename to... (&store-connection-error): ... this, and adjust users. (&nix-protocol-error): Rename to... (&store-protocol-error): ... this, adjust users. (&nix-error, &nix-connection-error, &nix-protocol-error): Define these condition types and their getters as deprecrated aliases. * build-aux/run-system-tests.scm, guix/derivations.scm, guix/grafts.scm, guix/scripts/challenge.scm, guix/scripts/graph.scm, guix/scripts/lint.scm, guix/scripts/offload.scm, guix/serialization.scm, guix/ssh.scm, guix/tests.scm, guix/ui.scm, tests/derivations.scm, tests/gexp.scm, tests/guix-daemon.sh, tests/packages.scm, tests/store.scm, doc/guix.texi: Adjust to use the new names. --- build-aux/run-system-tests.scm | 2 +- doc/guix.texi | 2 +- guix/derivations.scm | 2 +- guix/grafts.scm | 2 +- guix/scripts/challenge.scm | 2 +- guix/scripts/graph.scm | 2 +- guix/scripts/lint.scm | 4 +-- guix/scripts/offload.scm | 6 ++-- guix/serialization.scm | 2 +- guix/ssh.scm | 6 ++-- guix/store.scm | 77 ++++++++++++++++++++++++++++-------------- guix/tests.scm | 2 +- guix/ui.scm | 10 +++--- tests/derivations.scm | 42 +++++++++++------------ tests/gexp.scm | 4 +-- tests/guix-daemon.sh | 8 ++--- tests/packages.scm | 2 +- tests/store.scm | 46 ++++++++++++------------- 18 files changed, 123 insertions(+), 98 deletions(-) (limited to 'guix/scripts') diff --git a/build-aux/run-system-tests.scm b/build-aux/run-system-tests.scm index bcd7547704..fd1f6653af 100644 --- a/build-aux/run-system-tests.scm +++ b/build-aux/run-system-tests.scm @@ -30,7 +30,7 @@ (define-module (run-system-tests) (define (built-derivations* drv) (lambda (store) - (guard (c ((nix-protocol-error? c) + (guard (c ((store-protocol-error? c) (values #f store))) (values (build-derivations store drv) store)))) diff --git a/doc/guix.texi b/doc/guix.texi index 245a18bc70..e70fed2f1c 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -5027,7 +5027,7 @@ Return @code{#t} when @var{path} designates a valid store item and invalid, for instance because it is the result of an aborted or failed build.) -A @code{&nix-protocol-error} condition is raised if @var{path} is not +A @code{&store-protocol-error} condition is raised if @var{path} is not prefixed by the store directory (@file{/gnu/store}). @end deffn diff --git a/guix/derivations.scm b/guix/derivations.scm index f6176a78fd..fb2fa177be 100644 --- a/guix/derivations.scm +++ b/guix/derivations.scm @@ -113,7 +113,7 @@ (define-module (guix derivations) ;;; Error conditions. ;;; -(define-condition-type &derivation-error &nix-error +(define-condition-type &derivation-error &store-error derivation-error? (derivation derivation-error-derivation)) diff --git a/guix/grafts.scm b/guix/grafts.scm index db9c6854fd..a3e12f6efd 100644 --- a/guix/grafts.scm +++ b/guix/grafts.scm @@ -189,7 +189,7 @@ (define (output-paths drv) items))) (define (references* items) - (guard (c ((nix-protocol-error? c) + (guard (c ((store-protocol-error? c) ;; As a last resort, build DRV and query the references of the ;; build result. diff --git a/guix/scripts/challenge.scm b/guix/scripts/challenge.scm index f0693ed8df..65de42053d 100644 --- a/guix/scripts/challenge.scm +++ b/guix/scripts/challenge.scm @@ -109,7 +109,7 @@ (define (query-locally-built-hash item) "Return the hash of ITEM, a store item, if ITEM was built locally. Otherwise return #f." (lambda (store) - (guard (c ((nix-protocol-error? c) + (guard (c ((store-protocol-error? c) (values #f store))) (if (locally-built? store item) (values (query-path-hash store item) store) diff --git a/guix/scripts/graph.scm b/guix/scripts/graph.scm index 145a574dba..8efeef3274 100644 --- a/guix/scripts/graph.scm +++ b/guix/scripts/graph.scm @@ -299,7 +299,7 @@ (define (references* item) information available in the local store or using information about substitutes." (lambda (store) - (guard (c ((nix-protocol-error? c) + (guard (c ((store-protocol-error? c) (match (substitutable-path-info store (list item)) ((info) (values (substitutable-references info) store)) diff --git a/guix/scripts/lint.scm b/guix/scripts/lint.scm index 665adcfb8d..ddad5b7fd0 100644 --- a/guix/scripts/lint.scm +++ b/guix/scripts/lint.scm @@ -833,11 +833,11 @@ (define (check-derivation package) (define (try system) (catch #t (lambda () - (guard (c ((nix-protocol-error? c) + (guard (c ((store-protocol-error? c) (emit-warning package (format #f (G_ "failed to create ~a derivation: ~a") system - (nix-protocol-error-message c)))) + (store-protocol-error-message c)))) ((message-condition? c) (emit-warning package (format #f (G_ "failed to create ~a derivation: ~a") diff --git a/guix/scripts/offload.scm b/guix/scripts/offload.scm index 30fe69ad6d..2116b38425 100644 --- a/guix/scripts/offload.scm +++ b/guix/scripts/offload.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2014, 2015, 2016, 2017, 2018 Ludovic Courtès +;;; Copyright © 2014, 2015, 2016, 2017, 2018, 2019 Ludovic Courtès ;;; Copyright © 2017 Ricardo Wurmus ;;; ;;; This file is part of GNU Guix. @@ -358,12 +358,12 @@ (define store (format (current-error-port) "@ build-remote ~a ~a~%" (derivation-file-name drv) (build-machine-name machine)) - (guard (c ((nix-protocol-error? c) + (guard (c ((store-protocol-error? c) (format (current-error-port) (G_ "derivation '~a' offloaded to '~a' failed: ~a~%") (derivation-file-name drv) (build-machine-name machine) - (nix-protocol-error-message c)) + (store-protocol-error-message c)) (let* ((inferior (false-if-exception (remote-inferior session))) (space (false-if-exception (node-free-disk-space inferior)))) diff --git a/guix/serialization.scm b/guix/serialization.scm index 7c0fea552d..e14b7d1b9f 100644 --- a/guix/serialization.scm +++ b/guix/serialization.scm @@ -59,7 +59,7 @@ (define-module (guix serialization) ;; Similar to serialize.cc in Nix. -(define-condition-type &nar-error &error ; XXX: inherit from &nix-error ? +(define-condition-type &nar-error &error ; XXX: inherit from &store-error ? nar-error? (file nar-error-file) ; file we were restoring, or #f (port nar-error-port)) ; port from which we read diff --git a/guix/ssh.scm b/guix/ssh.scm index 77329618d5..2b286a67b2 100644 --- a/guix/ssh.scm +++ b/guix/ssh.scm @@ -328,17 +328,17 @@ (define* (send-files local files remote missing) (('protocol-error message) (raise (condition - (&nix-protocol-error (message message) (status 42))))) + (&store-protocol-error (message message) (status 42))))) (('error key args ...) (raise (condition - (&nix-protocol-error + (&store-protocol-error (message (call-with-output-string (lambda (port) (print-exception port #f key args)))) (status 43))))) (_ (raise (condition - (&nix-protocol-error + (&store-protocol-error (message "unknown error while sending files over SSH") (status 44))))))))) diff --git a/guix/store.scm b/guix/store.scm index f8c79788b8..d079147529 100644 --- a/guix/store.scm +++ b/guix/store.scm @@ -68,6 +68,15 @@ (define-module (guix store) current-store-protocol-version ;for internal use mcached + &store-error store-error? + &store-connection-error store-connection-error? + store-connection-error-file + store-connection-error-code + &store-protocol-error store-protocol-error? + store-protocol-error-message + store-protocol-error-status + + ;; Deprecated forms for '&store-error' et al. &nix-error nix-error? &nix-connection-error nix-connection-error? nix-connection-error-file @@ -377,34 +386,50 @@ (define-deprecated/alias nix-server-minor-version (define-deprecated/alias nix-server-socket store-connection-socket) -(define-condition-type &nix-error &error - nix-error?) +(define-condition-type &store-error &error + store-error?) -(define-condition-type &nix-connection-error &nix-error - nix-connection-error? - (file nix-connection-error-file) - (errno nix-connection-error-code)) +(define-condition-type &store-connection-error &store-error + store-connection-error? + (file store-connection-error-file) + (errno store-connection-error-code)) + +(define-condition-type &store-protocol-error &store-error + store-protocol-error? + (message store-protocol-error-message) + (status store-protocol-error-status)) + +(define-deprecated/alias &nix-error &store-error) +(define-deprecated/alias nix-error? store-error?) +(define-deprecated/alias &nix-connection-error &store-connection-error) +(define-deprecated/alias nix-connection-error? store-connection-error?) +(define-deprecated/alias nix-connection-error-file + store-connection-error-file) +(define-deprecated/alias nix-connection-error-code + store-connection-error-code) +(define-deprecated/alias &nix-protocol-error &store-protocol-error) +(define-deprecated/alias nix-protocol-error? store-protocol-error?) +(define-deprecated/alias nix-protocol-error-message + store-protocol-error-message) +(define-deprecated/alias nix-protocol-error-status + store-protocol-error-status) -(define-condition-type &nix-protocol-error &nix-error - nix-protocol-error? - (message nix-protocol-error-message) - (status nix-protocol-error-status)) (define-syntax-rule (system-error-to-connection-error file exp ...) "Catch 'system-error' exceptions and translate them to -'&nix-connection-error'." +'&store-connection-error'." (catch 'system-error (lambda () exp ...) (lambda args (let ((errno (system-error-errno args))) - (raise (condition (&nix-connection-error + (raise (condition (&store-connection-error (file file) (errno errno)))))))) (define (open-unix-domain-socket file) "Connect to the Unix-domain socket at FILE and return it. Raise a -'&nix-connection-error' upon error." +'&store-connection-error' upon error." (let ((s (with-fluids ((%default-port-encoding #f)) ;; This trick allows use of the `scm_c_read' optimization. (socket PF_UNIX SOCK_STREAM 0))) @@ -420,7 +445,7 @@ (define %default-guix-port (define (open-inet-socket host port) "Connect to the Unix-domain socket at HOST:PORT and return it. Raise a -'&nix-connection-error' upon error." +'&store-connection-error' upon error." (let ((sock (with-fluids ((%default-port-encoding #f)) ;; This trick allows use of the `scm_c_read' optimization. (socket PF_UNIX SOCK_STREAM 0)))) @@ -452,7 +477,7 @@ (define addresses ;; Connection failed, so try one of the other addresses. (close s) (if (null? rest) - (raise (condition (&nix-connection-error + (raise (condition (&store-connection-error (file host) (errno (system-error-errno args))))) (loop rest)))))))))) @@ -461,7 +486,7 @@ (define (connect-to-daemon uri) "Connect to the daemon at URI, a string that may be an actual URI or a file name." (define (not-supported) - (raise (condition (&nix-connection-error + (raise (condition (&store-connection-error (file uri) (errno ENOTSUP))))) @@ -510,8 +535,8 @@ (define* (open-connection #:optional (uri (%daemon-socket-uri)) ;; One of the 'write-' or 'read-' calls below failed, but this is ;; really a connection error. (raise (condition - (&nix-connection-error (file (or port uri)) - (errno EPROTO)) + (&store-connection-error (file (or port uri)) + (errno EPROTO)) (&message (message "build daemon handshake failed")))))) (let*-values (((port) (or port (connect-to-daemon uri))) @@ -689,14 +714,14 @@ (define %stderr-error #x63787470) ; "cxtp", error reporting (not (eof-object? (lookahead-u8 p)))) (read-int p) 1))) - (raise (condition (&nix-protocol-error + (raise (condition (&store-protocol-error (message error) (status status)))))) ((= k %stderr-last) ;; The daemon is done (see `stopWork' in `nix-worker.cc'.) #t) (else - (raise (condition (&nix-protocol-error + (raise (condition (&store-protocol-error (message "invalid error code") (status k)))))))) @@ -926,7 +951,7 @@ (define-operation (valid-path? (string path)) invalid item may exist on disk but still be invalid, for instance because it is the result of an aborted or failed build.) -A '&nix-protocol-error' condition is raised if PATH is not prefixed by the +A '&store-protocol-error' condition is raised if PATH is not prefixed by the store directory (/gnu/store)." boolean) @@ -1141,7 +1166,7 @@ (define build-things (build store things mode) (if (= mode (build-mode normal)) (build/old store things) - (raise (condition (&nix-protocol-error + (raise (condition (&store-protocol-error (message "unsupported build mode") (status 1)))))))))) @@ -1201,12 +1226,12 @@ (define %reference-cache (define (references/substitutes store items) "Return the list of list of references of ITEMS; the result has the same length as ITEMS. Query substitute information for any item missing from the -store at once. Raise a '&nix-protocol-error' exception if reference +store at once. Raise a '&store-protocol-error' exception if reference information for one of ITEMS is missing." (let* ((requested items) (local-refs (map (lambda (item) (or (hash-ref %reference-cache item) - (guard (c ((nix-protocol-error? c) #f)) + (guard (c ((store-protocol-error? c) #f)) (references store item)))) items)) (missing (fold-right (lambda (item local-ref result) @@ -1222,7 +1247,7 @@ (define (references/substitutes store items) '() (substitutable-path-info store missing)))) (when (< (length substs) (length missing)) - (raise (condition (&nix-protocol-error + (raise (condition (&store-protocol-error (message "cannot determine \ the list of references") (status 1))))) @@ -1673,7 +1698,7 @@ (define (query-path-info* item) "Monadic version of 'query-path-info' that returns #f when ITEM is not in the store." (lambda (store) - (guard (c ((nix-protocol-error? c) + (guard (c ((store-protocol-error? c) ;; ITEM is not in the store; return #f. (values #f store))) (values (query-path-info store item) store)))) diff --git a/guix/tests.scm b/guix/tests.scm index f4948148c4..16a426c4f9 100644 --- a/guix/tests.scm +++ b/guix/tests.scm @@ -64,7 +64,7 @@ (define %test-substitute-urls (define* (open-connection-for-tests #:optional (uri (%daemon-socket-uri))) "Open a connection to the build daemon for tests purposes and return it." - (guard (c ((nix-error? c) + (guard (c ((store-error? c) (format (current-error-port) "warning: build daemon error: ~s~%" c) #f)) diff --git a/guix/ui.scm b/guix/ui.scm index 1e089753e1..9ff56ea85c 100644 --- a/guix/ui.scm +++ b/guix/ui.scm @@ -684,14 +684,14 @@ (define (manifest-entry-output* entry) file (or (port-filename* port) port)) (leave (G_ "corrupt input while restoring archive from ~s~%") (or (port-filename* port) port))))) - ((nix-connection-error? c) + ((store-connection-error? c) (leave (G_ "failed to connect to `~a': ~a~%") - (nix-connection-error-file c) - (strerror (nix-connection-error-code c)))) - ((nix-protocol-error? c) + (store-connection-error-file c) + (strerror (store-connection-error-code c)))) + ((store-protocol-error? c) ;; FIXME: Server-provided error messages aren't i18n'd. (leave (G_ "build failed: ~a~%") - (nix-protocol-error-message c))) + (store-protocol-error-message c))) ((derivation-missing-output-error? c) (leave (G_ "reference to invalid output '~a' of derivation '~a'~%") (derivation-missing-output c) diff --git a/tests/derivations.scm b/tests/derivations.scm index 5f294c1827..c0601c0e88 100644 --- a/tests/derivations.scm +++ b/tests/derivations.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018 Ludovic Courtès +;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019 Ludovic Courtès ;;; ;;; This file is part of GNU Guix. ;;; @@ -185,9 +185,9 @@ (define prefix-len (string-length dir)) (set-build-options %store #:use-substitutes? #f #:keep-going? #t) - (guard (c ((nix-protocol-error? c) - (and (= 100 (nix-protocol-error-status c)) - (string-contains (nix-protocol-error-message c) + (guard (c ((store-protocol-error? c) + (and (= 100 (store-protocol-error-status c)) + (string-contains (store-protocol-error-message c) (derivation-file-name d1)) (not (valid-path? %store (derivation->output-path d1))) (valid-path? %store (derivation->output-path d2))))) @@ -222,8 +222,8 @@ (define prefix-len (string-length dir)) (test-assert "unknown built-in builder" (let ((drv (derivation %store "ohoh" "builtin:does-not-exist" '()))) - (guard (c ((nix-protocol-error? c) - (string-contains (nix-protocol-error-message c) "failed"))) + (guard (c ((store-protocol-error? c) + (string-contains (store-protocol-error-message c) "failed"))) (build-derivations %store (list drv)) #f))) @@ -253,8 +253,8 @@ (define prefix-len (string-length dir)) . ,(object->string (%local-url)))) #:hash-algo 'sha256 #:hash (sha256 (random-bytevector 100))))) ;wrong - (guard (c ((nix-protocol-error? c) - (string-contains (nix-protocol-error-message c) "failed"))) + (guard (c ((store-protocol-error? c) + (string-contains (store-protocol-error-message c) "failed"))) (build-derivations %store (list drv)) #f)))) @@ -268,8 +268,8 @@ (define prefix-len (string-length dir)) . ,(object->string (%local-url)))) #:hash-algo 'sha256 #:hash (sha256 (random-bytevector 100))))) - (guard (c ((nix-protocol-error? c) - (string-contains (nix-protocol-error-message (pk c)) "failed"))) + (guard (c ((store-protocol-error? c) + (string-contains (store-protocol-error-message (pk c)) "failed"))) (build-derivations %store (list drv)) #f)))) @@ -279,8 +279,8 @@ (define prefix-len (string-length dir)) (drv (derivation %store "world" "builtin:download" '() #:env-vars `(("url" . ,(object->string url)))))) - (guard (c ((nix-protocol-error? c) - (string-contains (nix-protocol-error-message c) "failed"))) + (guard (c ((store-protocol-error? c) + (string-contains (store-protocol-error-message c) "failed"))) (build-derivations %store (list drv)) #f))) @@ -607,7 +607,7 @@ (define (deps path . deps) `("-c" ,(string-append "echo " txt "> $out")) #:inputs `((,%bash) (,txt)) #:allowed-references '()))) - (guard (c ((nix-protocol-error? c) + (guard (c ((store-protocol-error? c) ;; There's no specific error message to check for. #t)) (build-derivations %store (list drv)) @@ -625,7 +625,7 @@ (define (deps path . deps) `("-c" ,"echo $out > $out") #:inputs `((,%bash)) #:allowed-references '()))) - (guard (c ((nix-protocol-error? c) + (guard (c ((store-protocol-error? c) ;; There's no specific error message to check for. #t)) (build-derivations %store (list drv)) @@ -644,7 +644,7 @@ (define (deps path . deps) `("-c" ,(string-append "echo " txt "> $out")) #:inputs `((,%bash) (,txt)) #:disallowed-references (list txt)))) - (guard (c ((nix-protocol-error? c) + (guard (c ((store-protocol-error? c) ;; There's no specific error message to check for. #t)) (build-derivations %store (list drv)) @@ -765,8 +765,8 @@ (define %coreutils (builder '(begin (sleep 100) (mkdir %output) #t)) (drv (build-expression->derivation store "silent" builder)) (out-path (derivation->output-path drv))) - (guard (c ((nix-protocol-error? c) - (and (string-contains (nix-protocol-error-message c) + (guard (c ((store-protocol-error? c) + (and (string-contains (store-protocol-error-message c) "failed") (not (valid-path? store out-path))))) (build-derivations store (list drv)) @@ -779,8 +779,8 @@ (define %coreutils (builder '(begin (sleep 100) (mkdir %output) #t)) (drv (build-expression->derivation store "slow" builder)) (out-path (derivation->output-path drv))) - (guard (c ((nix-protocol-error? c) - (and (string-contains (nix-protocol-error-message c) + (guard (c ((store-protocol-error? c) + (and (string-contains (store-protocol-error-message c) "failed") (not (valid-path? store out-path))))) (build-derivations store (list drv)) @@ -942,11 +942,11 @@ (define (record-substitutable-path-query store paths) #f)) ; fail! (drv (build-expression->derivation %store "fail" builder)) (out-path (derivation->output-path drv))) - (guard (c ((nix-protocol-error? c) + (guard (c ((store-protocol-error? c) ;; Note that the output path may exist at this point, but it ;; is invalid. (and (string-match "build .* failed" - (nix-protocol-error-message c)) + (store-protocol-error-message c)) (not (valid-path? %store out-path))))) (build-derivations %store (list drv)) #f))) diff --git a/tests/gexp.scm b/tests/gexp.scm index c4b437cd49..cee2c96610 100644 --- a/tests/gexp.scm +++ b/tests/gexp.scm @@ -919,7 +919,7 @@ (define (multiply x) (chdir #$output) (symlink #$%bootstrap-guile "guile")) #:allowed-references '())))) - (guard (c ((nix-protocol-error? c) #t)) + (guard (c ((store-protocol-error? c) #t)) (build-derivations %store (list drv)) #f))) @@ -943,7 +943,7 @@ (define (multiply x) (chdir #$output) (symlink #$%bootstrap-guile "guile")) #:disallowed-references (list %bootstrap-guile))))) - (guard (c ((nix-protocol-error? c) #t)) + (guard (c ((store-protocol-error? c) #t)) (build-derivations %store (list drv)) #f))) diff --git a/tests/guix-daemon.sh b/tests/guix-daemon.sh index 9ae6e0b77a..4c19a55722 100644 --- a/tests/guix-daemon.sh +++ b/tests/guix-daemon.sh @@ -1,5 +1,5 @@ # GNU Guix --- Functional package management for GNU -# Copyright © 2012, 2014, 2015, 2016, 2017, 2018 Ludovic Courtès +# Copyright © 2012, 2014, 2015, 2016, 2017, 2018, 2019 Ludovic Courtès # # This file is part of GNU Guix. # @@ -109,7 +109,7 @@ guile -c " (define (build-without-failing drv) (lambda (store) - (guard (c ((nix-protocol-error? c) (values #t store))) + (guard (c ((store-protocol-error? c) (values #t store))) (build-derivations store (list drv)) (values #f store)))) @@ -177,9 +177,9 @@ client_code=' `("-e" ,build) #:inputs `((,bash) (,build)) #:env-vars `(("x" . ,(random-text)))))) - (exit (guard (c ((nix-protocol-error? c) + (exit (guard (c ((store-protocol-error? c) (->bool - (string-contains (pk (nix-protocol-error-message c)) + (string-contains (pk (store-protocol-error-message c)) "failed")))) (build-derivations store (list drv)) #f))))' diff --git a/tests/packages.scm b/tests/packages.scm index ed635d9011..29e5e4103c 100644 --- a/tests/packages.scm +++ b/tests/packages.scm @@ -570,7 +570,7 @@ (define read-at (symlink %output (string-append %output "/self")) #t))))) (d (package-derivation %store p))) - (guard (c ((nix-protocol-error? c) #t)) + (guard (c ((store-protocol-error? c) #t)) (build-derivations %store (list d)) #f))) diff --git a/tests/store.scm b/tests/store.scm index 5ff9308d7d..e28c0c5aaa 100644 --- a/tests/store.scm +++ b/tests/store.scm @@ -63,9 +63,9 @@ (define %shell (test-equal "connection handshake error" EPROTO (let ((port (%make-void-port "rw"))) - (guard (c ((nix-connection-error? c) - (and (eq? port (nix-connection-error-file c)) - (nix-connection-error-code c)))) + (guard (c ((store-connection-error? c) + (and (eq? port (store-connection-error-file c)) + (store-connection-error-code c)))) (open-connection #f #:port port) 'broken))) @@ -120,7 +120,7 @@ (define %shell (test-assert "valid-path? error" (with-store s - (guard (c ((nix-protocol-error? c) #t)) + (guard (c ((store-protocol-error? c) #t)) (valid-path? s "foo") #f))) @@ -133,7 +133,7 @@ (define %shell (with-store s (let-syntax ((true-if-error (syntax-rules () ((_ exp) - (guard (c ((nix-protocol-error? c) #t)) + (guard (c ((store-protocol-error? c) #t)) exp #f))))) (and (true-if-error (valid-path? s "foo")) (true-if-error (valid-path? s "bar")) @@ -274,7 +274,7 @@ (define %shell (test-assert "references/substitutes missing reference info" (with-store s (set-build-options s #:use-substitutes? #f) - (guard (c ((nix-protocol-error? c) #t)) + (guard (c ((store-protocol-error? c) #t)) (let* ((b (add-to-store s "bash" #t "sha256" (search-bootstrap-binary "bash" (%current-system)))) @@ -422,7 +422,7 @@ (define (same? x y) %store "foo" `(display ,s) #:guile-for-build (package-derivation s %bootstrap-guile (%current-system))))) - (guard (c ((nix-protocol-error? c) #t)) + (guard (c ((store-protocol-error? c) #t)) (build-derivations %store (list d)))))))) "Here’s a Greek letter: λ.")) @@ -442,7 +442,7 @@ (define (same? x y) (display "lambda: λ\n")) #:guile-for-build (package-derivation %store %bootstrap-guile)))) - (guard (c ((nix-protocol-error? c) #t)) + (guard (c ((store-protocol-error? c) #t)) (build-derivations %store (list d)))))))) "garbage: �lambda: λ")) @@ -620,12 +620,12 @@ (define (same? x y) #:fallback? #f #:substitute-urls (%test-substitute-urls)) (and (has-substitutes? s o) - (guard (c ((nix-protocol-error? c) + (guard (c ((store-protocol-error? c) ;; XXX: the daemon writes "hash mismatch in downloaded ;; path", but the actual error returned to the client ;; doesn't mention that. (pk 'corrupt c) - (not (zero? (nix-protocol-error-status c))))) + (not (zero? (store-protocol-error-status c))))) (build-derivations s (list d)) #f)))))) @@ -646,7 +646,7 @@ (define (same? x y) (set-build-options s #:use-substitutes? #t #:substitute-urls (%test-substitute-urls)) (and (has-substitutes? s o) - (guard (c ((nix-protocol-error? c) + (guard (c ((store-protocol-error? c) ;; The substituter failed as expected. Now make ;; sure that #:fallback? #t works correctly. (set-build-options s @@ -712,9 +712,9 @@ (define (same? x y) (dump (call-with-bytevector-output-port (cute export-paths %store (list file2) <>)))) (delete-paths %store (list file0 file1 file2)) - (guard (c ((nix-protocol-error? c) - (and (not (zero? (nix-protocol-error-status c))) - (string-contains (nix-protocol-error-message c) + (guard (c ((store-protocol-error? c) + (and (not (zero? (store-protocol-error-status c))) + (string-contains (store-protocol-error-message c) "not valid")))) ;; Here we get an exception because DUMP does not include FILE0 and ;; FILE1, which are dependencies of FILE2. @@ -816,10 +816,10 @@ (define ref-hash (bytevector-u8-set! dump index (logxor #xff byte))) (and (not (file-exists? file)) - (guard (c ((nix-protocol-error? c) + (guard (c ((store-protocol-error? c) (pk 'c c) - (and (not (zero? (nix-protocol-error-status c))) - (string-contains (nix-protocol-error-message c) + (and (not (zero? (store-protocol-error-status c))) + (string-contains (store-protocol-error-message c) "corrupt")))) (let* ((source (open-bytevector-input-port dump)) (imported (import-paths %store source))) @@ -906,10 +906,10 @@ (define ref-hash (begin (write (random-text) entropy-port) (force-output entropy-port) - (guard (c ((nix-protocol-error? c) + (guard (c ((store-protocol-error? c) (pk 'determinism-exception c) - (and (not (zero? (nix-protocol-error-status c))) - (string-contains (nix-protocol-error-message c) + (and (not (zero? (store-protocol-error-status c))) + (string-contains (store-protocol-error-message c) "deterministic")))) ;; This one will produce a different result. Since we're in ;; 'check' mode, this must fail. @@ -945,10 +945,10 @@ (define ref-hash #:guile-for-build (package-derivation store %bootstrap-guile (%current-system)))) (file (derivation->output-path drv))) - (guard (c ((nix-protocol-error? c) + (guard (c ((store-protocol-error? c) (pk 'multiple-build c) - (and (not (zero? (nix-protocol-error-status c))) - (string-contains (nix-protocol-error-message c) + (and (not (zero? (store-protocol-error-status c))) + (string-contains (store-protocol-error-message c) "deterministic")))) ;; This one will produce a different result on the second run. (current-build-output-port (current-error-port)) -- cgit v1.2.3 From 02ec889e6b8f6593dd90afcb4d60a43ea67be4b8 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 22 Jan 2019 17:37:59 +0100 Subject: offload: 'status' reports the time difference. * guix/scripts/offload.scm (check-machine-status): Report the time difference for each MACHINE. --- guix/scripts/offload.scm | 37 +++++++++++++++++++++++++------------ 1 file changed, 25 insertions(+), 12 deletions(-) (limited to 'guix/scripts') diff --git a/guix/scripts/offload.scm b/guix/scripts/offload.scm index 2116b38425..eb02672dbf 100644 --- a/guix/scripts/offload.scm +++ b/guix/scripts/offload.scm @@ -712,18 +712,31 @@ (define session (warning (G_ "failed to run 'guix repl' on machine '~a'~%") (build-machine-name machine))) ((? inferior? inferior) - (let ((uts (inferior-eval '(uname) inferior)) - (load (node-load inferior)) - (free (node-free-disk-space inferior))) - (close-inferior inferior) - (format #t "~a~% kernel: ~a ~a~% architecture: ~a~%\ - host name: ~a~% normalized load: ~a~% free disk space: ~,2f MiB~%" - (build-machine-name machine) - (utsname:sysname uts) (utsname:release uts) - (utsname:machine uts) - (utsname:nodename uts) - (normalized-load machine load) - (/ free (expt 2 20) 1.))))) + (let ((now (car (gettimeofday)))) + (match (inferior-eval '(list (uname) + (car (gettimeofday))) + inferior) + ((uts time) + (when (< time now) + ;; Build machine clocks must not be behind as this + ;; could cause timestamp issues. + (warning (G_ "machine '~a' is ~a seconds behind~%") + (build-machine-name machine) + (- now time))) + + (let ((load (node-load inferior)) + (free (node-free-disk-space inferior))) + (close-inferior inferior) + (format #t "~a~% kernel: ~a ~a~% architecture: ~a~%\ + host name: ~a~% normalized load: ~a~% free disk space: ~,2f MiB~%\ + time difference: ~a s~%" + (build-machine-name machine) + (utsname:sysname uts) (utsname:release uts) + (utsname:machine uts) + (utsname:nodename uts) + (normalized-load machine load) + (/ free (expt 2 20) 1.) + (- time now)))))))) (disconnect! session)) machines))) -- cgit v1.2.3 From 731c1a20bc7edf7612d34754a7760e8219220010 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 25 Jan 2019 10:06:32 +0100 Subject: weather: Ignore deprecated packages but not hidden packages. * guix/scripts/weather.scm (all-packages): Pass #:select? to 'fold-packages'. --- guix/scripts/weather.scm | 7 +++++-- 1 file changed, 5 insertions(+), 2 deletions(-) (limited to 'guix/scripts') diff --git a/guix/scripts/weather.scm b/guix/scripts/weather.scm index 98b7338fb9..bb326a651a 100644 --- a/guix/scripts/weather.scm +++ b/guix/scripts/weather.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2017, 2018 Ludovic Courtès +;;; Copyright © 2017, 2018, 2019 Ludovic Courtès ;;; Copyright © 2017 Ricardo Wurmus ;;; Copyright © 2018 Kyle Meyer ;;; @@ -51,7 +51,10 @@ (define (all-packages) (cons* replacement package result)) (#f (cons package result)))) - '())) + '() + + ;; Dismiss deprecated packages but keep hidden packages. + #:select? (negate package-superseded))) (define (call-with-progress-reporter reporter proc) "This is a variant of 'call-with-progress-reporter' that works with monadic -- cgit v1.2.3 From 4d6ce0f12cf3724b89876f4e911fc84f344c4215 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 25 Jan 2019 11:09:31 +0100 Subject: refresh: Fix format string that would lead '-l' to print incorrect numbers. The skip "~*" argument was misplaced, leading the number of dependents to be skipped (instead of the number of covering packages.) Thus, we'd get: $ guix refresh -l ocaml4.02-ppx-deriving@4.1 Building the following package would ensure 1 dependent packages are rebuilt: bap@1.3.0 instead of: Building the following package would ensure 26 dependent packages are rebuilt: bap@1.3.0 * guix/scripts/refresh.scm (list-dependents): Move "~*" in the right place, to skip (length covering) rather than (length dependents). --- guix/scripts/refresh.scm | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) (limited to 'guix/scripts') diff --git a/guix/scripts/refresh.scm b/guix/scripts/refresh.scm index a0de9f6c10..7292eabc47 100644 --- a/guix/scripts/refresh.scm +++ b/guix/scripts/refresh.scm @@ -419,8 +419,8 @@ (define (full-name package) (full-name x))) (lst (format (current-output-port) - (N_ "Building the following package would ensure ~d \ -dependent packages are rebuilt: ~*~{~a~^ ~}~%" + (N_ "Building the following ~*package would ensure ~d \ +dependent packages are rebuilt: ~{~a~^ ~}~%" "Building the following ~d packages would ensure ~d \ dependent packages are rebuilt: ~{~a~^ ~}~%" (length covering)) -- cgit v1.2.3 From af77219e8a59c9d04cda349b26b7f30ea5cf3ab1 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 25 Jan 2019 12:09:33 +0100 Subject: refresh: Better account for private and generated packages. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Until now, private and generated packages (e.g., those created by 'texlive-union') we missing from the list passed to 'node-back-edges', which would lead to inaccurate dependent counts. Previously we'd get: $ guix refresh -l texlive-fonts-cm Building the following 80 packages would ensure 116 dependent packages are rebuilt: … Now we have: $ Building the following 240 packages would ensure 597 dependent packages are rebuilt: … * guix/scripts/refresh.scm (list-dependents): Call 'package-closure'. --- guix/scripts/refresh.scm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'guix/scripts') diff --git a/guix/scripts/refresh.scm b/guix/scripts/refresh.scm index 7292eabc47..5b0f345cde 100644 --- a/guix/scripts/refresh.scm +++ b/guix/scripts/refresh.scm @@ -400,7 +400,7 @@ (define (full-name package) (package-version package))) (mlet %store-monad ((edges (node-back-edges %bag-node-type - (all-packages)))) + (package-closure (all-packages))))) (let* ((dependents (node-transitive-edges packages edges)) (covering (filter (lambda (node) (null? (edges node))) -- cgit v1.2.3 From bd414e273c2010132895a645b623035c218eb437 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 25 Jan 2019 13:57:38 +0100 Subject: weather: Add '--coverage'. * guix/scripts/weather.scm (show-help, %options): Add '--coverage'. (package-partition-boundary, package->output-mapping) (substitute-oracle, report-package-coverage-per-system) (report-package-coverage): New procedures. (guix-weather): Honor '--coverage'. * doc/guix.texi (Invoking guix weather): Document it. --- doc/guix.texi | 35 +++++++++- guix/scripts/weather.scm | 167 ++++++++++++++++++++++++++++++++++++++++++++++- 2 files changed, 200 insertions(+), 2 deletions(-) (limited to 'guix/scripts') diff --git a/doc/guix.texi b/doc/guix.texi index afc0ef8615..a182e1edee 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -9709,7 +9709,9 @@ key is authorized. It also reports the size of the compressed archives (``nars'') provided by the server, the size the corresponding store items occupy in the store (assuming deduplication is turned off), and the server's throughput. The second part gives continuous integration -(CI) statistics, if the server supports it. +(CI) statistics, if the server supports it. In addition, using the +@option{--coverage} option, @command{guix weather} can list ``important'' +package substitutes missing on the server (see below). To achieve that, @command{guix weather} queries over HTTP(S) meta-data (@dfn{narinfos}) for all the relevant store items. Like @command{guix @@ -9737,6 +9739,37 @@ Instead of querying substitutes for all the packages, only ask for those specified in @var{file}. @var{file} must contain a @dfn{manifest}, as with the @code{-m} option of @command{guix package} (@pxref{Invoking guix package}). + +@item --coverage[=@var{count}] +@itemx -c [@var{count}] +Report on substitute coverage for packages: list packages with at least +@var{count} dependents (zero by default) for which substitutes are +unavailable. Dependent packages themselves are not listed: if @var{b} depends +on @var{a} and @var{a} has no substitutes, only @var{a} is listed, even though +@var{b} usually lacks substitutes as well. The result looks like this: + +@example +$ guix weather --substitute-urls=https://ci.guix.info -c 10 +computing 8,983 package derivations for x86_64-linux... +looking for 9,343 store items on https://ci.guix.info... +updating substitutes from 'https://ci.guix.info'... 100.0% +https://ci.guix.info + 64.7% substitutes available (6,047 out of 9,343) +@dots{} +2502 packages are missing from 'https://ci.guix.info' for 'x86_64-linux', among which: + 58 kcoreaddons@@5.49.0 /gnu/store/@dots{}-kcoreaddons-5.49.0 + 46 qgpgme@@1.11.1 /gnu/store/@dots{}-qgpgme-1.11.1 + 37 perl-http-cookiejar@@0.008 /gnu/store/@dots{}-perl-http-cookiejar-0.008 + @dots{} +@end example + +What this example shows is that @code{kcoreaddons} and presumably the 58 +packages that depend on it have no substitutes at @code{ci.guix.info}; +likewise for @code{qgpgme} and the 46 packages that depend on it. + +If you are a Guix developer, or if you are taking care of this build farm, +you'll probably want to have a closer look at these packages: they may simply +fail to build. @end table @node Invoking guix processes diff --git a/guix/scripts/weather.scm b/guix/scripts/weather.scm index bb326a651a..4b12f9550e 100644 --- a/guix/scripts/weather.scm +++ b/guix/scripts/weather.scm @@ -32,6 +32,9 @@ (define-module (guix scripts weather) #:use-module (guix scripts substitute) #:use-module (guix http-client) #:use-module (guix ci) + #:use-module (guix sets) + #:use-module (guix graph) + #:autoload (guix scripts graph) (%bag-node-type) #:use-module (gnu packages) #:use-module (web uri) #:use-module (srfi srfi-1) @@ -41,6 +44,7 @@ (define-module (guix scripts weather) #:use-module (srfi srfi-37) #:use-module (ice-9 match) #:use-module (ice-9 format) + #:use-module (ice-9 vlist) #:export (guix-weather)) (define (all-packages) @@ -257,6 +261,10 @@ (define (show-help) -m, --manifest=MANIFEST look up substitutes for packages specified in MANIFEST")) (display (G_ " + -c, --coverage[=COUNT] + show substitute coverage for packages with at least + COUNT dependents")) + (display (G_ " -s, --system=SYSTEM consider substitutes for SYSTEM--e.g., \"i686-linux\"")) (newline) (display (G_ " @@ -289,6 +297,11 @@ (define %options (option '(#\m "manifest") #t #f (lambda (opt name arg result) (alist-cons 'manifest arg result))) + (option '(#\c "coverage") #f #t + (lambda (opt name arg result) + (alist-cons 'coverage + (if arg (string->number* arg) 0) + result))) (option '(#\s "system") #t #f (lambda (opt name arg result) (alist-cons 'system arg result))))) @@ -303,6 +316,153 @@ (define (load-manifest file) (map manifest-entry-item (manifest-transitive-entries manifest)))) + +;;; +;;; Missing package substitutes. +;;; + +(define* (package-partition-boundary pred packages + #:key (system (%current-system))) + "Return the subset of PACKAGES that are at the \"boundary\" between those +that match PRED and those that don't. The returned packages themselves do not +match PRED but they have at least one direct dependency that does. + +Note: The assumption is that, if P matches PRED, then all the dependencies of +P match PRED as well." + ;; XXX: Graph theoreticians surely have something to teach us about this... + (let loop ((packages packages) + (result (setq)) + (visited vlist-null)) + (define (visited? package) + (vhash-assq package visited)) + + (match packages + ((package . rest) + (cond ((visited? package) + (loop rest result visited)) + ((pred package) + (loop rest result (vhash-consq package #t visited))) + (else + (let* ((bag (package->bag package system)) + (deps (filter-map (match-lambda + ((label (? package? package) . _) + (and (not (pred package)) + package)) + (_ #f)) + (bag-direct-inputs bag)))) + (loop (append deps rest) + (if (null? deps) + (set-insert package result) + result) + (vhash-consq package #t visited)))))) + (() + (set->list result))))) + +(define (package->output-mapping packages system) + "Return a vhash that maps each item of PACKAGES to its corresponding output +store file names for SYSTEM." + (foldm %store-monad + (lambda (package mapping) + (mlet %store-monad ((drv (package->derivation package system + #:graft? #f))) + (return (vhash-consq package + (match (derivation->output-paths drv) + (((names . outputs) ...) + outputs)) + mapping)))) + vlist-null + packages)) + +(define (substitute-oracle server items) + "Return a procedure that, when passed a store item (one of those listed in +ITEMS), returns true if SERVER has a substitute for it, false otherwise." + (define available + (fold (lambda (narinfo set) + (set-insert (narinfo-path narinfo) set)) + (set) + (lookup-narinfos server items))) + + (cut set-contains? available <>)) + +(define* (report-package-coverage-per-system server packages system + #:key (threshold 0)) + "Report on the subset of PACKAGES that lacks SYSTEM substitutes on SERVER, +sorted by decreasing number of dependents. Do not display those with less +than THRESHOLD dependents." + (mlet* %store-monad ((packages -> (package-closure packages #:system system)) + (mapping (package->output-mapping packages system)) + (back-edges (node-back-edges %bag-node-type packages))) + (define items + (vhash-fold (lambda (package items result) + (append items result)) + '() + mapping)) + + (define substitutable? + (substitute-oracle server items)) + + (define substitutable-package? + (lambda (package) + (match (vhash-assq package mapping) + ((_ . items) + (find substitutable? items)) + (#f + #f)))) + + (define missing + (package-partition-boundary substitutable-package? packages + #:system system)) + + (define missing-count + (length missing)) + + (if (zero? threshold) + (format #t (N_ "The following ~a package is missing from '~a' for \ +'~a':~%" + "The following ~a packages are missing from '~a' for \ +'~a':~%" + missing-count) + missing-count server system) + (format #t (N_ "~a package is missing from '~a' for '~a':~%" + "~a packages are missing from '~a' for '~a', among \ +which:~%" + missing-count) + missing-count server system)) + + (for-each (match-lambda + ((package count) + (match (vhash-assq package mapping) + ((_ . items) + (when (>= count threshold) + (format #t " ~4d\t~a@~a\t~{~a ~}~%" + count + (package-name package) (package-version package) + items))) + (#f ;PACKAGE must be an internal thing + #f)))) + (sort (zip missing + (map (lambda (package) + (node-reachable-count (list package) + back-edges)) + missing)) + (match-lambda* + (((_ count1) (_ count2)) + (< count2 count1))))) + (return #t))) + +(define* (report-package-coverage server packages systems + #:key (threshold 0)) + "Report on the substitute coverage for PACKAGES, for each of SYSTEMS, on +SERVER. Display information for packages with at least THRESHOLD dependents." + (with-store store + (run-with-store store + (foldm %store-monad + (lambda (system _) + (report-package-coverage-per-system server packages system + #:threshold threshold)) + #f + systems)))) + ;;; ;;; Entry point. @@ -334,7 +494,12 @@ (define (guix-weather . args) (package-outputs packages system)) systems))))))) (for-each (lambda (server) - (report-server-coverage server items)) + (report-server-coverage server items) + (match (assoc-ref opts 'coverage) + (#f #f) + (threshold + (report-package-coverage server packages systems + #:threshold threshold)))) urls))))) ;;; Local Variables: -- cgit v1.2.3 From d1d72830f2d60b2853460c443081683ef2f7d5c4 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 28 Jan 2019 23:03:38 +0100 Subject: pull: Don't trigger 'hash guix' hint needlessly. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Previously if ~/.config/guix/current/bin was in $PATH, we'd still suggest to run 'hash guix' because we'd compare (which "guix") against /var/guix/profiles/per-user/…. * guix/scripts/pull.scm (build-and-install): Check whether (which "guix") matches PROFILE or its user-friendly variant. --- guix/scripts/pull.scm | 8 +++++--- 1 file changed, 5 insertions(+), 3 deletions(-) (limited to 'guix/scripts') diff --git a/guix/scripts/pull.scm b/guix/scripts/pull.scm index 41c7fb289a..6cecf8c2e1 100644 --- a/guix/scripts/pull.scm +++ b/guix/scripts/pull.scm @@ -197,11 +197,13 @@ (define update-profile (match (which "guix") (#f (return #f)) (str - (let ((command (string-append profile "/bin/guix"))) - (unless (string=? command str) + (let ((new (map (cut string-append <> "/bin/guix") + (list (user-friendly-profile profile) + profile)))) + (unless (member str new) (display-hint (format #f (G_ "After setting @code{PATH}, run @command{hash guix} to make sure your shell refers to @file{~a}.") - command))) + (first new)))) (return #f)))))))) (define (honor-lets-encrypt-certificates! store) -- cgit v1.2.3 From 2790b6670b60a5f541df4d01afac6bf9335a5252 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sun, 27 Jan 2019 18:16:25 +0100 Subject: pull: Default to verbosity level 1. * guix/scripts/pull.scm (%default-options): Change 'verbosity to 1. --- guix/scripts/pull.scm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'guix/scripts') diff --git a/guix/scripts/pull.scm b/guix/scripts/pull.scm index 6cecf8c2e1..683ab3f059 100644 --- a/guix/scripts/pull.scm +++ b/guix/scripts/pull.scm @@ -69,7 +69,7 @@ (define %default-options (multiplexed-build-output? . #t) (graft? . #t) (debug . 0) - (verbosity . 2))) + (verbosity . 1))) (define (show-help) (display (G_ "Usage: guix pull [OPTION]... -- cgit v1.2.3 From 35ef5bc8662b42bd8de3da1d720c12dc9e430f4e Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 1 Feb 2019 12:43:42 +0100 Subject: guix package: '-A' no longer lists deprecated packages. Fixes a regression introduced in 0ea939fb796fdd4f0d46d3534b2ec6135e0f3dc7. * guix/scripts/package.scm (process-query) <'list-available>: Change #:superseded? to #:deprecated? since that's what 'fold-available-packages' passes. --- guix/scripts/package.scm | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) (limited to 'guix/scripts') diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm index a633d2ee6d..8a71467b52 100644 --- a/guix/scripts/package.scm +++ b/guix/scripts/package.scm @@ -739,9 +739,9 @@ (define (diff-profiles profile numbers) (available (fold-available-packages (lambda* (name version result #:key outputs location - supported? superseded? + supported? deprecated? #:allow-other-keys) - (if (and supported? (not superseded?)) + (if (and supported? (not deprecated?)) (if regexp (if (regexp-exec regexp name) (cons `(,name ,version -- cgit v1.2.3