From 10a1cacb164fe0f141bd34350ec1250cef06a43c Mon Sep 17 00:00:00 2001 From: Ricardo Wurmus Date: Thu, 20 Dec 2018 09:37:58 +0100 Subject: import: cran: Try import via CRAN if package is not on Bioconductor. * guix/import/cran.scm (fetch-description): Return #F on failure. (cran->guix-package): Retry from CRAN on failure to fetch description from bioconductor. --- guix/import/cran.scm | 17 +++++++++++------ 1 file changed, 11 insertions(+), 6 deletions(-) (limited to 'guix') diff --git a/guix/import/cran.scm b/guix/import/cran.scm index 8f2c10258a..aaa1caf035 100644 --- a/guix/import/cran.scm +++ b/guix/import/cran.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2015, 2016, 2017 Ricardo Wurmus +;;; Copyright © 2015, 2016, 2017, 2018 Ricardo Wurmus ;;; Copyright © 2015, 2016, 2017 Ludovic Courtès ;;; Copyright © 2017 Mathieu Othacehe ;;; @@ -23,6 +23,7 @@ #:use-module (ice-9 regex) #:use-module ((ice-9 rdelim) #:select (read-string read-line)) #:use-module (srfi srfi-1) + #:use-module (srfi srfi-2) #:use-module (srfi srfi-26) #:use-module (srfi srfi-34) #:use-module (ice-9 receive) @@ -180,9 +181,9 @@ from ~s: ~a (~s)~%" ;; Currently, the bioconductor project does not offer a way to access a ;; package's DESCRIPTION file over HTTP, so we determine the version, ;; download the source tarball, and then extract the DESCRIPTION file. - (let* ((version (latest-bioconductor-package-version name)) - (url (car (bioconductor-uri name version))) - (tarball (with-store store (download-to-store store url)))) + (and-let* ((version (latest-bioconductor-package-version name)) + (url (car (bioconductor-uri name version))) + (tarball (with-store store (download-to-store store url)))) (call-with-temporary-directory (lambda (dir) (parameterize ((current-error-port (%make-void-port "rw+")) @@ -346,8 +347,12 @@ from the alist META, which was derived from the R package's DESCRIPTION file." (lambda* (package-name #:optional (repo 'cran)) "Fetch the metadata for PACKAGE-NAME from REPO and return the `package' s-expression corresponding to that package, or #f on failure." - (and=> (fetch-description repo package-name) - (cut description->package repo <>))))) + (let ((description (fetch-description repo package-name))) + (if (and (not description) + (eq? repo 'bioconductor)) + ;; Retry import from CRAN + (cran->guix-package package-name 'cran) + (description->package repo description)))))) (define* (cran-recursive-import package-name #:optional (repo 'gnu)) (recursive-import package-name repo -- cgit v1.2.3 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') 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 @@ MACHINE." (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 @@ slot (which must later be released with 'release-build-slot'), or #f and #f." (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 @@ machine." (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') 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 @@ hook." (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 @@ MACHINE." (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 @@ slot (which must later be released with 'release-build-slot'), or #f and #f." ;; 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 @@ slot (which must later be released with 'release-build-slot'), or #f and #f." ;; 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 @@ machine." (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') 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 @@ MACHINE." (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 bdf860c2e99077d431da0cc1db4fc14db2a35d31 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 21 Dec 2018 23:35:20 +0100 Subject: database: Use "write-ahead log" mode and set a long "busy timeout". This should avoid "database is locked" errors when there's a lot of concurrency, for instance when offloading simultaneously a lot of builds. * guix/store/database.scm (call-with-database): Add two 'sqlite-exec' calls to set 'journal_mode' and 'busy_timeout'. --- guix/store/database.scm | 9 +++++++++ 1 file changed, 9 insertions(+) (limited to 'guix') diff --git a/guix/store/database.scm b/guix/store/database.scm index e6bfbe763e..4791f49865 100644 --- a/guix/store/database.scm +++ b/guix/store/database.scm @@ -79,6 +79,15 @@ as specified by SQL-SCHEMA." create it and initialize it as a new database." (let ((new? (not (file-exists? file))) (db (sqlite-open file))) + ;; Turn DB in "write-ahead log" mode, which should avoid SQLITE_LOCKED + ;; errors when we have several readers: . + (sqlite-exec db "PRAGMA journal_mode=WAL;") + + ;; Install a busy handler such that, when the database is locked, sqlite + ;; retries until 30 seconds have passed, at which point it gives up and + ;; throws SQLITE_BUSY. + (sqlite-exec db "PRAGMA busy_timeout = 30000;") + (dynamic-wind noop (lambda () (when new? -- 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') 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 @@ machine." (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') 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 @@ #: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 @@ check-source check-source-file-name check-mirror-url + check-github-url check-license check-vulnerabilities check-for-updates @@ -773,6 +777,37 @@ descriptions maintained upstream." (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 @@ or a list thereof") (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 @@ (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') 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 @@ #: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 @@ (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 @@ specified with `--select'.\n")) (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 @@ dependent packages are rebuilt: ~{~a~^ ~}~%" (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 @@ update would trigger a complete rebuild." (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 @@ update would trigger a complete rebuild." (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 af15fe13b69d27f9902353540fd8ad0001ce8311 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 24 Dec 2018 00:55:07 +0100 Subject: ssh: Add 'remote-inferior'. * guix/inferior.scm ()[close]: New field. (port->inferior): New procedure. (open-inferior): Rewrite in terms of 'port->inferior'. (close-inferior): Honor INFERIOR's 'close' field. (inferior-eval-with-store): Add FIXME comment. * guix/ssh.scm (remote-inferior): New procedure. --- guix/inferior.scm | 28 +++++++++++++++++++--------- guix/ssh.scm | 8 ++++++++ 2 files changed, 27 insertions(+), 9 deletions(-) (limited to 'guix') diff --git a/guix/inferior.scm b/guix/inferior.scm index ccc1c27cb2..973bd5264e 100644 --- a/guix/inferior.scm +++ b/guix/inferior.scm @@ -54,6 +54,7 @@ #:use-module ((rnrs bytevectors) #:select (string->utf8)) #:export (inferior? open-inferior + port->inferior close-inferior inferior-eval inferior-eval-with-store @@ -93,10 +94,11 @@ ;; Inferior Guix process. (define-record-type - (inferior pid socket version packages table) + (inferior pid socket close version packages table) inferior? (pid inferior-pid) (socket inferior-socket) + (close inferior-close-socket) ;procedure (version inferior-version) ;REPL protocol version (packages inferior-package-promise) ;promise of inferior packages (table inferior-package-table)) ;promise of vhash @@ -131,19 +133,17 @@ it's an old Guix." ((@ (guix scripts repl) machine-repl)))))) pipe))) -(define* (open-inferior directory #:key (command "bin/guix")) - "Open the inferior Guix in DIRECTORY, running 'DIRECTORY/COMMAND repl' or -equivalent. Return #f if the inferior could not be launched." - (define pipe - (inferior-pipe directory command)) - +(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))) (match (read pipe) (('repl-version 0 rest ...) - (letrec ((result (inferior 'pipe pipe (cons 0 rest) + (letrec ((result (inferior 'pipe pipe close (cons 0 rest) (delay (%inferior-packages result)) (delay (%inferior-package-table result))))) (inferior-eval '(use-modules (guix)) result) @@ -155,9 +155,18 @@ equivalent. Return #f if the inferior could not be launched." (_ #f))) +(define* (open-inferior directory #:key (command "bin/guix")) + "Open the inferior Guix in DIRECTORY, running 'DIRECTORY/COMMAND repl' or +equivalent. Return #f if the inferior could not be launched." + (define pipe + (inferior-pipe directory command)) + + (port->inferior pipe close-pipe)) + (define (close-inferior inferior) "Close INFERIOR." - (close-pipe (inferior-socket inferior))) + (let ((close (inferior-close-socket inferior))) + (close (inferior-socket inferior)))) ;; Non-self-quoting object of the inferior. (define-record-type @@ -409,6 +418,7 @@ thus be the code of a one-argument procedure that accepts a store." ;; Create a named socket in /tmp and let INFERIOR connect to it and use it ;; as its store. This ensures the inferior uses the same store, with the ;; same options, the same per-session GC roots, etc. + ;; FIXME: This strategy doesn't work for remote inferiors (SSH). (call-with-temporary-directory (lambda (directory) (chmod directory #o700) diff --git a/guix/ssh.scm b/guix/ssh.scm index 104f4f52d6..b8bea8028a 100644 --- a/guix/ssh.scm +++ b/guix/ssh.scm @@ -18,6 +18,7 @@ (define-module (guix ssh) #:use-module (guix store) + #:use-module (guix inferior) #:use-module (guix i18n) #:use-module ((guix utils) #:select (&fix-hint)) #:use-module (ssh session) @@ -36,6 +37,7 @@ #:use-module (ice-9 match) #:use-module (ice-9 binary-ports) #:export (open-ssh-session + remote-inferior remote-daemon-channel connect-to-remote-daemon send-files @@ -94,6 +96,12 @@ Throw an error on failure." (message (format #f (G_ "SSH connection to '~a' failed: ~a~%") host (get-error session)))))))))) +(define (remote-inferior session) + "Return a remote inferior for the given SESSION." + (let ((pipe (open-remote-pipe* session OPEN_BOTH + "guix" "repl" "-t" "machine"))) + (port->inferior pipe))) + (define* (remote-daemon-channel session #:optional (socket-name -- 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') 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 @@ #: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 @@ hook." (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 @@ MACHINE." (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 @@ of free disk space on '~a'~%") (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 @@ slot (which must later be released with 'release-build-slot'), or #f and #f." ;; 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 @@ If TIMEOUT is #f, simply evaluate EXP..." (#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 @@ If TIMEOUT is #f, simply evaluate EXP..." (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 @@ If TIMEOUT is #f, simply evaluate EXP..." (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 @@ machine." (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 @@ machine." (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 @@ #: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 @@ Throw an error on failure." "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 @@ Return the list of store items actually sent." ;; 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') 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 @@ If TIMEOUT is #f, simply evaluate EXP..." 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 @@ machine." (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 @@ machine." (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') 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 @@ of free disk space on '~a'~%") (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 @@ of free disk space on '~a'~%") 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') 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 @@ instead of '~a' of type '~a'~%") (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 @@ the slot, or #f if none is available. 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 @@ of free disk space on '~a'~%") 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 @@ This tool is meant to be used internally by 'guix-daemon'.\n")) (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') 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 @@ Download and deploy the latest version of Guix.\n")) (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 @@ Use '~/.config/guix/channels.scm' instead.")) (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') 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 @@ 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 @@ descriptions maintained upstream." (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 @@ or a list thereof") (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 @@ (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 789fc77bef3601ceb49ea96d84dbe9e9286dca75 Mon Sep 17 00:00:00 2001 From: Eric Bavier Date: Wed, 19 Dec 2018 17:02:38 -0600 Subject: refresh: github: updates for origins using 'git-fetch'. * guix/import/github.scm (updated-github-url): Respond with the repository url for the 'git-fetch' fetch method. (github-package?): Simplify boolean expression. (github-repository, github-user-slash-repository): Strip trailing ".git" from project if present. (latest-release): Recognize a 'git-reference'. --- guix/import/github.scm | 30 +++++++++++++++++++----------- 1 file changed, 19 insertions(+), 11 deletions(-) (limited to 'guix') diff --git a/guix/import/github.scm b/guix/import/github.scm index af9f56e1dc..ad662e7b02 100644 --- a/guix/import/github.scm +++ b/guix/import/github.scm @@ -1,6 +1,7 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2016 Ben Woodcroft ;;; Copyright © 2017, 2018 Ludovic Courtès +;;; Copyright © 2018 Eric Bavier ;;; ;;; This file is part of GNU Guix. ;;; @@ -24,6 +25,7 @@ #:use-module (srfi srfi-34) #:use-module (guix utils) #:use-module ((guix download) #:prefix download:) + #:use-module ((guix git-download) #:prefix download:) #:use-module (guix import utils) #:use-module (guix import json) #:use-module (guix packages) @@ -52,6 +54,7 @@ false if none is recognized" (github-user-slash-repository url))) (repo (github-repository url))) (cond + ((string-suffix? ".git" url) url) ((string-suffix? (string-append "/tarball/v" version) url) (string-append prefix "/tarball/v" new-version)) ((string-suffix? (string-append "/tarball/" version) url) @@ -86,26 +89,29 @@ false if none is recognized" (#t #f))) ; Some URLs are not recognised. #f)) - (let ((source-url (and=> (package-source old-package) origin-uri)) + (let ((source-uri (and=> (package-source old-package) origin-uri)) (fetch-method (and=> (package-source old-package) origin-method))) - (if (eq? fetch-method download:url-fetch) - (match source-url - ((? string?) - (updated-url source-url)) - ((source-url ...) - (find updated-url source-url))) - #f))) + (cond + ((eq? fetch-method download:url-fetch) + (match source-uri + ((? string?) + (updated-url source-uri)) + ((source-uri ...) + (find updated-url source-uri)))) + ((eq? fetch-method download:git-fetch) + (updated-url (download:git-reference-url source-uri))) + (else #f)))) (define (github-package? package) "Return true if PACKAGE is a package from GitHub, else false." - (not (eq? #f (updated-github-url package "dummy")))) + (->bool (updated-github-url package "dummy"))) (define (github-repository url) "Return a string e.g. bedtools2 of the name of the repository, from a string URL of the form 'https://github.com/arq5x/bedtools2/archive/v2.24.0.tar.gz'" (match (string-split (uri-path (string->uri url)) #\/) ((_ owner project . rest) - (string-append project)))) + (string-append (basename project ".git"))))) (define (github-user-slash-repository url) "Return a string e.g. arq5x/bedtools2 of the owner and the name of the @@ -113,7 +119,7 @@ repository separated by a forward slash, from a string URL of the form 'https://github.com/arq5x/bedtools2/archive/v2.24.0.tar.gz'" (match (string-split (uri-path (string->uri url)) #\/) ((_ owner project . rest) - (string-append owner "/" project)))) + (string-append owner "/" (basename project ".git"))))) (define %github-token ;; Token to be passed to Github.com to avoid the 60-request per hour @@ -213,6 +219,8 @@ https://github.com/settings/tokens")) (match (origin-uri origin) ((? string? url) url) ;surely a github.com URL + ((? download:git-reference? ref) + (download:git-reference-url ref)) ((urls ...) (find (cut string-contains <> "github.com") urls)))) -- cgit v1.2.3 From b3d0617a55c62fe75af44707a3cd4138fa97e62d Mon Sep 17 00:00:00 2001 From: Ricardo Wurmus Date: Thu, 3 Jan 2019 08:31:15 +0100 Subject: import: cran: Download tarballs only once. * guix/import/cran.scm (download): New procedure. (fetch-description, description->package): Use it. --- guix/import/cran.scm | 10 ++++++++-- 1 file changed, 8 insertions(+), 2 deletions(-) (limited to 'guix') diff --git a/guix/import/cran.scm b/guix/import/cran.scm index aaa1caf035..507e77ed79 100644 --- a/guix/import/cran.scm +++ b/guix/import/cran.scm @@ -161,6 +161,12 @@ bioconductor package NAME, or #F if the package is unknown." (bioconductor-packages-list)) (cut assoc-ref <> "Version"))) +;; Little helper to download URLs only once. +(define download + (memoize + (lambda (url) + (with-store store (download-to-store store url))))) + (define (fetch-description repository name) "Return an alist of the contents of the DESCRIPTION file for the R package NAME in the given REPOSITORY, or #f in case of failure. NAME is @@ -183,7 +189,7 @@ from ~s: ~a (~s)~%" ;; download the source tarball, and then extract the DESCRIPTION file. (and-let* ((version (latest-bioconductor-package-version name)) (url (car (bioconductor-uri name version))) - (tarball (with-store store (download-to-store store url)))) + (tarball (download url))) (call-with-temporary-directory (lambda (dir) (parameterize ((current-error-port (%make-void-port "rw+")) @@ -299,7 +305,7 @@ from the alist META, which was derived from the R package's DESCRIPTION file." ((url rest ...) url) ((? string? url) url) (_ #f))) - (tarball (with-store store (download-to-store store source-url))) + (tarball (download source-url)) (sysdepends (append (if (needs-zlib? tarball) '("zlib") '()) (map string-downcase (listify meta "SystemRequirements")))) -- cgit v1.2.3 From 632ea817b88974f616e159ef7dcc174901a77aa3 Mon Sep 17 00:00:00 2001 From: Ricardo Wurmus Date: Thu, 3 Jan 2019 08:32:05 +0100 Subject: import: cran: Use HTTPS. * guix/import/cran.scm (%cran-url): Use HTTPS. --- guix/import/cran.scm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/import/cran.scm b/guix/import/cran.scm index 507e77ed79..243203928d 100644 --- a/guix/import/cran.scm +++ b/guix/import/cran.scm @@ -125,7 +125,7 @@ package definition." ((package-inputs ...) `((,type (,'quasiquote ,(format-inputs package-inputs))))))) -(define %cran-url "http://cran.r-project.org/web/packages/") +(define %cran-url "https://cran.r-project.org/web/packages/") (define %bioconductor-url "https://bioconductor.org/packages/") ;; The latest Bioconductor release is 3.8. Bioconductor packages should be -- cgit v1.2.3 From 7bb6420c5a4b1db46651f044cec9d804c1de56a3 Mon Sep 17 00:00:00 2001 From: Ricardo Wurmus Date: Thu, 3 Jan 2019 08:32:50 +0100 Subject: import: cran: Abort if no description could be fetched. * guix/import/cran.scm (cran->guix-package): Only proceed if a valid description could be fetched. --- guix/import/cran.scm | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/import/cran.scm b/guix/import/cran.scm index 243203928d..ac9097073e 100644 --- a/guix/import/cran.scm +++ b/guix/import/cran.scm @@ -358,7 +358,8 @@ s-expression corresponding to that package, or #f on failure." (eq? repo 'bioconductor)) ;; Retry import from CRAN (cran->guix-package package-name 'cran) - (description->package repo description)))))) + (and description + (description->package repo description))))))) (define* (cran-recursive-import package-name #:optional (repo 'gnu)) (recursive-import package-name repo -- cgit v1.2.3 From 2a13642b6549727e7d93be871041465cacfb167f Mon Sep 17 00:00:00 2001 From: Ricardo Wurmus Date: Thu, 3 Jan 2019 08:33:46 +0100 Subject: import: cran: Default to 'cran repo. * guix/import/cran.scm (cran-recursive-import): Default to 'cran repo. --- guix/import/cran.scm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/import/cran.scm b/guix/import/cran.scm index ac9097073e..15163bd165 100644 --- a/guix/import/cran.scm +++ b/guix/import/cran.scm @@ -361,7 +361,7 @@ s-expression corresponding to that package, or #f on failure." (and description (description->package repo description))))))) -(define* (cran-recursive-import package-name #:optional (repo 'gnu)) +(define* (cran-recursive-import package-name #:optional (repo 'cran)) (recursive-import package-name repo #:repo->guix-package cran->guix-package #:guix-name cran-guix-name)) -- cgit v1.2.3 From 9ec154f51f52ee3702c611637e96ccb0d59f543a Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sat, 5 Jan 2019 00:01:18 +0100 Subject: gexp: Lowering a honors SYSTEM and TARGET. * guix/gexp.scm (computed-file-compiler): Pass #:system and #:target to 'gexp->derivation'. * tests/gexp.scm ("lower-object, computed-file, #:system"): New test. --- guix/gexp.scm | 7 ++++--- tests/gexp.scm | 20 +++++++++++++++++++- 2 files changed, 23 insertions(+), 4 deletions(-) (limited to 'guix') diff --git a/guix/gexp.scm b/guix/gexp.scm index 88cabc8ed5..febd72a904 100644 --- a/guix/gexp.scm +++ b/guix/gexp.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 © 2018 Clément Lassieur ;;; Copyright © 2018 Jan Nieuwenhuizen ;;; @@ -388,8 +388,9 @@ This is the declarative counterpart of 'gexp->derivation'." (mlet %store-monad ((guile (lower-object guile system #:target target))) (apply gexp->derivation name gexp #:guile-for-build guile - options)) - (apply gexp->derivation name gexp options))))) + #:system system #:target target options)) + (apply gexp->derivation name gexp + #:system system #:target target options))))) (define-record-type (%program-file name gexp guile path) diff --git a/tests/gexp.scm b/tests/gexp.scm index 35a76a496e..c4b437cd49 100644 --- a/tests/gexp.scm +++ b/tests/gexp.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 ;;; ;;; This file is part of GNU Guix. ;;; @@ -1171,6 +1171,24 @@ (string=? (readlink (string-append comp "/text")) text))))))) +(test-equal "lower-object, computed-file, #:system" + '("mips64el-linux") + (run-with-store %store + (let* ((exp #~(symlink #$coreutils #$output)) + (computed (computed-file "computed" exp + #:guile %bootstrap-guile))) + ;; Make sure that the SYSTEM argument to 'lower-object' is honored. + (mlet* %store-monad ((drv (lower-object computed "mips64el-linux")) + (refs (references* (derivation-file-name drv)))) + (return (delete-duplicates + (filter-map (lambda (file) + (and (string-suffix? ".drv" file) + (let ((drv (read-derivation-from-file + file))) + (derivation-system drv)))) + (cons (derivation-file-name drv) + refs)))))))) + (test-assert "lower-object & gexp-input-error?" (guard (c ((gexp-input-error? c) (gexp-error-invalid-input c))) -- 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') 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 @@ package '~a' has no source~%") ((? 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 a173f09811baa2f368fd77dd7a7e3552e2e56040 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sat, 5 Jan 2019 00:06:04 +0100 Subject: ui: It's 2019 now! * guix/ui.scm (show-version-and-exit): Change year to 2019. --- guix/ui.scm | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) (limited to 'guix') diff --git a/guix/ui.scm b/guix/ui.scm index 44336ee8fd..4c31246920 100644 --- a/guix/ui.scm +++ b/guix/ui.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, 2018 Mark H Weaver ;;; Copyright © 2013 Nikita Karetnikov ;;; Copyright © 2014 Cyril Roelandt @@ -466,7 +466,7 @@ See the \"Application Setup\" section in the manual, for more info.\n"))))) "Display version information for COMMAND and `(exit 0)'." (simple-format #t "~a (~a) ~a~%" command %guix-package-name %guix-version) - (format #t "Copyright ~a 2018 ~a" + (format #t "Copyright ~a 2019 ~a" ;; TRANSLATORS: Translate "(C)" to the copyright symbol ;; (C-in-a-circle), if this symbol is available in the user's ;; locale. Otherwise, do not translate "(C)"; leave it as-is. */ -- cgit v1.2.3 From 18524466bb25a1926277b1111d15fb378ff7941e Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sat, 5 Jan 2019 23:04:58 +0100 Subject: git-download: 'git-fetch' really returns #f upon error. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit This allows the fallback code in (guix git-download) to actually run. Regression introduced in commit 329dabe13bf98b899b907b45565434c5140804f5. Fixes . Reported by Björn Höfling . * guix/build/git.scm (git-fetch): Guard against 'invoke-error?' and really return #f upon failure. --- guix/build/git.scm | 54 +++++++++++++++++++++++++++++++++--------------------- 1 file changed, 33 insertions(+), 21 deletions(-) (limited to 'guix') diff --git a/guix/build/git.scm b/guix/build/git.scm index 2d1700a9b9..5b90033c4d 100644 --- a/guix/build/git.scm +++ b/guix/build/git.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2014, 2016 Ludovic Courtès +;;; Copyright © 2014, 2016, 2019 Ludovic Courtès ;;; ;;; This file is part of GNU Guix. ;;; @@ -18,6 +18,8 @@ (define-module (guix build git) #:use-module (guix build utils) + #:use-module (srfi srfi-34) + #:use-module (ice-9 format) #:export (git-fetch)) ;;; Commentary: @@ -39,31 +41,41 @@ recursively. Return #t on success, #f otherwise." (mkdir-p directory) - (with-directory-excursion directory - (invoke git-command "init") - (invoke git-command "remote" "add" "origin" url) - (if (zero? (system* git-command "fetch" "--depth" "1" "origin" commit)) - (invoke git-command "checkout" "FETCH_HEAD") - (begin - (setvbuf (current-output-port) 'line) - (format #t "Failed to do a shallow fetch; retrying a full fetch...~%") - (invoke git-command "fetch" "origin") - (invoke git-command "checkout" commit))) - (when recursive? - ;; Now is the time to fetch sub-modules. - (unless (zero? (system* git-command "submodule" "update" - "--init" "--recursive")) - (error "failed to fetch sub-modules" url)) + (guard (c ((invoke-error? c) + (format (current-error-port) + "git-fetch: '~a~{ ~a~}' failed with exit code ~a~%" + (invoke-error-program c) + (invoke-error-arguments c) + (or (invoke-error-exit-status c) ;XXX: not quite accurate + (invoke-error-stop-signal c) + (invoke-error-term-signal c))) + (delete-file-recursively directory) + #f)) + (with-directory-excursion directory + (invoke git-command "init") + (invoke git-command "remote" "add" "origin" url) + (if (zero? (system* git-command "fetch" "--depth" "1" "origin" commit)) + (invoke git-command "checkout" "FETCH_HEAD") + (begin + (setvbuf (current-output-port) 'line) + (format #t "Failed to do a shallow fetch; retrying a full fetch...~%") + (invoke git-command "fetch" "origin") + (invoke git-command "checkout" commit))) + (when recursive? + ;; Now is the time to fetch sub-modules. + (unless (zero? (system* git-command "submodule" "update" + "--init" "--recursive")) + (error "failed to fetch sub-modules" url)) - ;; In sub-modules, '.git' is a flat file, not a directory, - ;; so we can use 'find-files' here. - (for-each delete-file-recursively - (find-files directory "^\\.git$"))) + ;; In sub-modules, '.git' is a flat file, not a directory, + ;; so we can use 'find-files' here. + (for-each delete-file-recursively + (find-files directory "^\\.git$"))) ;; The contents of '.git' vary as a function of the current ;; status of the Git repo. Since we want a fixed output, this ;; directory needs to be taken out. (delete-file-recursively ".git") - #t)) + #t))) ;;; git.scm ends here -- cgit v1.2.3 From c070d1423fcbdc48e749545ecdf277404ab7d77d Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sat, 5 Jan 2019 23:10:04 +0100 Subject: git-download: Use 'invoke'. * guix/build/git.scm (git-fetch): Use 'invoke' instead of 'system*' for "git submodule update". --- guix/build/git.scm | 4 +--- 1 file changed, 1 insertion(+), 3 deletions(-) (limited to 'guix') diff --git a/guix/build/git.scm b/guix/build/git.scm index 5b90033c4d..669e38cd32 100644 --- a/guix/build/git.scm +++ b/guix/build/git.scm @@ -63,9 +63,7 @@ recursively. Return #t on success, #f otherwise." (invoke git-command "checkout" commit))) (when recursive? ;; Now is the time to fetch sub-modules. - (unless (zero? (system* git-command "submodule" "update" - "--init" "--recursive")) - (error "failed to fetch sub-modules" url)) + (invoke git-command "submodule" "update" "--init" "--recursive") ;; In sub-modules, '.git' is a flat file, not a directory, ;; so we can use 'find-files' here. -- 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') 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 @@ or a list thereof") (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 b5f8c2c88543158e8aca76aa98f9009f6b9e743a Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 26 Nov 2018 17:17:45 +0100 Subject: hydra: Compute jobs in an inferior. Previously we would rely on auto-compilation of all the Guix modules. The complete evaluation would take ~15mn on berlin.guixsd.org and require lots of RAM. This approach should be faster since potentially only part of the modules are rebuilt. Furthermore, as a side-effect, it builds the derivations that 'guix pull' uses. * build-aux/hydra/gnu-system.scm: Remove 'eval-when' form. (hydra-jobs): New procedure. * gnu/ci.scm (package->alist, qemu-jobs, system-test-jobs) (tarball-jobs): Return strings for the 'license' field. * guix/self.scm (compiled-guix)[*cli-modules*]: Add (gnu ci). --- build-aux/hydra/gnu-system.scm | 73 ++++++++++++++++++++++++++---------------- gnu/ci.scm | 20 +++++++++--- guix/self.scm | 3 +- 3 files changed, 62 insertions(+), 34 deletions(-) (limited to 'guix') diff --git a/build-aux/hydra/gnu-system.scm b/build-aux/hydra/gnu-system.scm index 150c2bdf4f..775bbd9db2 100644 --- a/build-aux/hydra/gnu-system.scm +++ b/build-aux/hydra/gnu-system.scm @@ -23,39 +23,56 @@ ;;; tool. ;;; -(use-modules (system base compile)) +(use-modules (guix inferior) (guix channels) + (guix) + (guix ui) + (srfi srfi-1) + (ice-9 match)) -(eval-when (expand load eval) +;; XXX: Debugging hack: since `hydra-eval-guile-jobs' redirects the output +;; port to the bit bucket, let us write to the error port instead. +(setvbuf (current-error-port) _IOLBF) +(set-current-output-port (current-error-port)) - ;; Pre-load the compiler so we don't end up auto-compiling it. - (compile #t) +(define (hydra-jobs store arguments) + "Return a list of jobs where each job is a NAME/THUNK pair." + (define checkout + ;; Extract metadata about the 'guix' checkout. Its key in ARGUMENTS may + ;; vary, so pick up the first one that's neither 'subset' nor 'systems'. + (any (match-lambda + ((key . value) + (and (not (memq key '(systems subset))) + value))) + arguments)) - ;; Use our very own Guix modules. - (set! %fresh-auto-compile #t) + (define commit + (assq-ref checkout 'revision)) - ;; Ignore .go files except for Guile's. This is because our checkout in the - ;; store has mtime set to the epoch, and thus .go files look newer, even - ;; though they may not correspond. Use 'reverse' so that /gnu/store/…-guile - ;; comes before /run/current-system/profile. - (set! %load-compiled-path - (list - (dirname (dirname (search-path (reverse %load-compiled-path) - "ice-9/boot-9.go"))))) + (define source + (assq-ref checkout 'file-name)) - (and=> (assoc-ref (current-source-location) 'filename) - (lambda (file) - (let ((dir (canonicalize-path - (string-append (dirname file) "/../..")))) - (format (current-error-port) "prepending ~s to the load path~%" - dir) - (set! %load-path (cons dir %load-path)))))) + (define instance + (checkout->channel-instance source #:commit commit)) -(use-modules (gnu ci)) + (define derivation + ;; Compute the derivation of Guix for COMMIT. + (run-with-store store + (channel-instances->derivation (list instance)))) -;; XXX: Debugging hack: since `hydra-eval-guile-jobs' redirects the output -;; port to the bit bucket, let us write to the error port instead. -(setvbuf (current-error-port) _IOLBF) -(set-current-output-port (current-error-port)) + (show-what-to-build store (list derivation)) + (build-derivations store (list derivation)) + + ;; Open an inferior for the just-built Guix. + (let ((inferior (open-inferior (derivation->output-path derivation)))) + (inferior-eval '(use-modules (gnu ci) (ice-9 match)) inferior) -;; Return the procedure from (gnu ci). -hydra-jobs + (map (match-lambda + ((name . fields) + ;; Hydra expects a thunk, so here it is. + (cons name (lambda () fields)))) + (inferior-eval-with-store inferior store + `(lambda (store) + (map (match-lambda + ((name . thunk) + (cons name (thunk)))) + (hydra-jobs store ',arguments))))))) diff --git a/gnu/ci.scm b/gnu/ci.scm index 7db7e6062f..c071f21e0a 100644 --- a/gnu/ci.scm +++ b/gnu/ci.scm @@ -27,7 +27,8 @@ #:use-module (guix derivations) #:use-module (guix monads) #:use-module (guix ui) - #:use-module ((guix licenses) #:select (gpl3+)) + #:use-module ((guix licenses) + #:select (gpl3+ license? license-name)) #:use-module ((guix utils) #:select (%current-system)) #:use-module ((guix scripts system) #:select (read-operating-system)) #:use-module ((guix scripts pack) @@ -69,7 +70,16 @@ #:graft? #f))) (description . ,(package-synopsis package)) (long-description . ,(package-description package)) - (license . ,(package-license package)) + + ;; XXX: Hydra ignores licenses that are not a structure or a + ;; list thereof. + (license . ,(let loop ((license (package-license package))) + (match license + ((? license?) + (license-name license)) + ((lst ...) + (map loop license))))) + (home-page . ,(package-home-page package)) (maintainers . ("bug-guix@gnu.org")) (max-silent-time . ,(or (assoc-ref (package-properties package) @@ -133,7 +143,7 @@ SYSTEM." (description . "Stand-alone QEMU image of the GNU system") (long-description . "This is a demo stand-alone QEMU image of the GNU system.") - (license . ,gpl3+) + (license . ,(license-name gpl3+)) (max-silent-time . 600) (timeout . 3600) (home-page . ,%guix-home-page-url) @@ -194,7 +204,7 @@ system.") (description . ,(format #f "GuixSD '~a' system test" (system-test-name test))) (long-description . ,(system-test-description test)) - (license . ,gpl3+) + (license . ,(license-name gpl3+)) (max-silent-time . 600) (timeout . 3600) (home-page . ,%guix-home-page-url) @@ -217,7 +227,7 @@ system.") (description . "Stand-alone binary Guix tarball") (long-description . "This is a tarball containing binaries of Guix and all its dependencies, and ready to be installed on non-GuixSD distributions.") - (license . ,gpl3+) + (license . ,(license-name gpl3+)) (home-page . ,%guix-home-page-url) (maintainers . ("bug-guix@gnu.org")))) diff --git a/guix/self.scm b/guix/self.scm index f2db3dbf52..2664fd886f 100644 --- a/guix/self.scm +++ b/guix/self.scm @@ -624,7 +624,8 @@ assumed to be part of MODULES." (define *cli-modules* (scheme-node "guix-cli" - (scheme-modules* source "/guix/scripts") + (append (scheme-modules* source "/guix/scripts") + `((gnu ci))) (list *core-modules* *extra-modules* *core-package-modules* *package-modules* *system-modules*) -- cgit v1.2.3 From 46cf4cd6766d0a7186af513d33def5637ea8529c Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 7 Jan 2019 12:08:33 +0100 Subject: Remove (guix build pull). This module had been unused since commit 5f93d97005897c2d859f0be1bdff34c88467ec61 (Oct. 2017). * guix/build/pull.scm: Delete. * Makefile.am (MODULES): Remove. --- Makefile.am | 3 +- guix/build/pull.scm | 154 ---------------------------------------------------- 2 files changed, 1 insertion(+), 156 deletions(-) delete mode 100644 guix/build/pull.scm (limited to 'guix') diff --git a/Makefile.am b/Makefile.am index e74916cc0a..9f30d5b2b0 100644 --- a/Makefile.am +++ b/Makefile.am @@ -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 Andreas Enge # Copyright © 2015, 2017 Alex Kost # Copyright © 2016, 2018 Mathieu Lirzin @@ -172,7 +172,6 @@ MODULES = \ guix/build/union.scm \ guix/build/profiles.scm \ guix/build/compile.scm \ - guix/build/pull.scm \ guix/build/rpath.scm \ guix/build/cvs.scm \ guix/build/svn.scm \ diff --git a/guix/build/pull.scm b/guix/build/pull.scm deleted file mode 100644 index a011e366f6..0000000000 --- a/guix/build/pull.scm +++ /dev/null @@ -1,154 +0,0 @@ -;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2013, 2014, 2016, 2017 Ludovic Courtès -;;; Copyright © 2015 Taylan Ulrich Bayırlı/Kammer -;;; -;;; This file is part of GNU Guix. -;;; -;;; GNU Guix is free software; you can redistribute it and/or modify it -;;; under the terms of the GNU General Public License as published by -;;; the Free Software Foundation; either version 3 of the License, or (at -;;; your option) any later version. -;;; -;;; GNU Guix is distributed in the hope that it will be useful, but -;;; WITHOUT ANY WARRANTY; without even the implied warranty of -;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;;; GNU General Public License for more details. -;;; -;;; You should have received a copy of the GNU General Public License -;;; along with GNU Guix. If not, see . - -(define-module (guix build pull) - #:use-module (guix modules) - #:use-module (guix build utils) - #:use-module (guix build compile) - #:use-module (ice-9 ftw) - #:use-module (ice-9 match) - #:use-module (ice-9 format) - #:use-module (srfi srfi-1) - #:use-module (srfi srfi-11) - #:use-module (srfi srfi-26) - #:use-module (srfi srfi-34) - #:export (build-guix)) - -;;; Commentary: -;;; -;;; Helpers for the 'guix pull' command to unpack and build Guix. -;;; -;;; Code: - -(define (has-all-its-dependencies? file) - "Return true if the dependencies of the module defined in FILE are -available, false otherwise." - (let ((module (call-with-input-file file - (lambda (port) - (match (read port) - (('define-module name _ ...) - name)))))) - ;; If one of the dependencies of MODULE is missing, we get a - ;; '&missing-dependency-error'. - (guard (c ((missing-dependency-error? c) #f)) - (source-module-closure (list module) #:select? (const #t))))) - -(define (all-scheme-files directory) - "Return a sorted list of Scheme files found in DIRECTORY." - ;; Load guix/ modules before gnu/ modules to get somewhat steadier - ;; progress reporting. - (sort (filter (cut string-suffix? ".scm" <>) - (find-files directory "\\.scm")) - (let ((guix (string-append directory "/guix")) - (gnu (string-append directory "/gnu"))) - (lambda (a b) - (or (and (string-prefix? guix a) - (string-prefix? gnu b)) - (string 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') 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 @@ from ~a") '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 @@ patch could not be found." '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') 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 @@ #: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 @@ path to the repository." (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 @@ path to the repository." (('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 @@ path to the repository." (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 @@ #: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 @@ Import and convert the opam package for PACKAGE-NAME.\n")) (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 @@ Import and convert the opam package for PACKAGE-NAME.\n")) (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 @@ Import and convert the opam package for PACKAGE-NAME.\n")) (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 755e6d4a0ab32e8f854262a6c563c3662b336983 Mon Sep 17 00:00:00 2001 From: Julien Lepiller Date: Wed, 19 Dec 2018 23:20:39 +0100 Subject: import: opam: Add updater. * guix/import/opam.scm (%opam-updater): New variable. --- guix/import/opam.scm | 59 +++++++++++++++++++++++++++++++++++++++++++++++----- 1 file changed, 54 insertions(+), 5 deletions(-) (limited to 'guix') diff --git a/guix/import/opam.scm b/guix/import/opam.scm index cdf05e7d25..b30d28561b 100644 --- a/guix/import/opam.scm +++ b/guix/import/opam.scm @@ -27,14 +27,19 @@ #:use-module (srfi srfi-1) #:use-module (srfi srfi-2) #:use-module (web uri) + #:use-module (guix build-system) + #:use-module (guix build-system ocaml) #:use-module (guix http-client) #:use-module (guix git) #:use-module (guix ui) + #:use-module (guix packages) + #:use-module (guix upstream) #:use-module (guix utils) #:use-module (guix import utils) #:use-module ((guix licenses) #:prefix license:) #:export (opam->guix-package - opam-recursive-import)) + opam-recursive-import + %opam-updater)) ;; Define a PEG parser for the opam format (define-peg-pattern SP none (or " " "\n")) @@ -205,11 +210,17 @@ path to the repository." (list dependency (list 'unquote (string->symbol dependency)))) (ocaml-names->guix-names lst))) -(define (opam->guix-package name) +(define (opam-fetch name) (and-let* ((repository (get-opam-repository)) (version (find-latest-version name repository)) - (file (string-append repository "/packages/" name "/" name "." version "/opam")) - (opam-content (get-metadata file)) + (file (string-append repository "/packages/" name "/" name "." version "/opam"))) + `(("metadata" ,@(get-metadata file)) + ("version" . ,version)))) + +(define (opam->guix-package name) + (and-let* ((opam-file (opam-fetch name)) + (version (assoc-ref opam-file "version")) + (opam-content (assoc-ref opam-file "metadata")) (url-dict (metadata-ref opam-content "url")) (source-url (metadata-ref url-dict "src")) (requirements (metadata-ref opam-content "depends")) @@ -222,7 +233,7 @@ path to the repository." (values `(package (name ,(ocaml-name->guix-name name)) - (version ,(metadata-ref opam-content "version")) + (version ,version) (source (origin (method url-fetch) @@ -246,3 +257,41 @@ path to the repository." #:repo->guix-package (lambda (name repo) (opam->guix-package name)) #:guix-name ocaml-name->guix-name)) + +(define (guix-package->opam-name package) + "Given an OCaml PACKAGE built from OPAM, return the name of the +package in OPAM." + (let ((upstream-name (assoc-ref + (package-properties package) + 'upstream-name)) + (name (package-name package))) + (cond + (upstream-name upstream-name) + ((string-prefix? "ocaml-" name) (substring name 6)) + (else name)))) + +(define (opam-package? package) + "Return true if PACKAGE is an OCaml package from OPAM" + (and + (equal? (build-system-name (package-build-system package)) 'ocaml) + (not (string-prefix? "ocaml4" (package-name package))))) + +(define (latest-release package) + "Return an for the latest release of PACKAGE." + (and-let* ((opam-name (guix-package->opam-name package)) + (opam-file (opam-fetch opam-name)) + (version (assoc-ref opam-file "version")) + (opam-content (assoc-ref opam-file "metadata")) + (url-dict (metadata-ref opam-content "url")) + (source-url (metadata-ref url-dict "src"))) + (upstream-source + (package (package-name package)) + (version version) + (urls (list source-url))))) + +(define %opam-updater + (upstream-updater + (name 'opam) + (description "Updater for OPAM packages") + (pred opam-package?) + (latest latest-release))) -- cgit v1.2.3 From f31ce9ecf1ecb4eeab4fc37792684b3fa03ec95f Mon Sep 17 00:00:00 2001 From: Julien Lepiller Date: Wed, 19 Dec 2018 23:55:44 +0100 Subject: import: opam: Parse comments. * guix/import/opam.scm: Add comment support in parser. --- guix/import/opam.scm | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/import/opam.scm b/guix/import/opam.scm index b30d28561b..c254db5f2c 100644 --- a/guix/import/opam.scm +++ b/guix/import/opam.scm @@ -42,7 +42,8 @@ %opam-updater)) ;; Define a PEG parser for the opam format -(define-peg-pattern SP none (or " " "\n")) +(define-peg-pattern comment none (and "#" (* STRCHR) "\n")) +(define-peg-pattern SP none (or " " "\n" comment)) (define-peg-pattern SP2 body (or " " "\n")) (define-peg-pattern QUOTE none "\"") (define-peg-pattern QUOTE2 body "\"") -- cgit v1.2.3 From 49c35bbb71f80bdd7c01b4d74e08335c3ec5331c Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 7 Jan 2019 22:57:34 +0100 Subject: self: Move all modules into a single directory. This halves the number of elements in %LOAD-PATH and %LOAD-COMPILED-PATH and halves the number of 'stat' calls as reported by: env -i $(type -P guix) build -e '(@ (gnu packages base) coreutils)' -nd * guix/self.scm (node-source+compiled, guile-module-union): New procedures. (guix-command): Remove 'compiled-modules' parameter. Remove 'source-directories' and 'object-directories' variables and add 'module-directory'. Change command so that it adds nothing but MODULE-DIRECTORY to %LOAD-PATH and %LOAD-COMPILED-PATH. (whole-package): Remove #:compiled-modules. Assume MODULES contains 'share/guile/site' and 'lib/guile' and adjust code accordingly. (compiled-guix): When PULL-VERSION is 1, use 'node-source+compiled' only. Remove #:compiled-modules argument to 'whole-package'. * guix/channels.scm (whole-package-for-legacy): Add 'module+compiled' and pass it to 'whole-package'. --- guix/channels.scm | 24 ++++++++++- guix/self.scm | 125 ++++++++++++++++++++++++++++++++++-------------------- 2 files changed, 100 insertions(+), 49 deletions(-) (limited to 'guix') diff --git a/guix/channels.scm b/guix/channels.scm index 75503bb0ae..6b860f3bd8 100644 --- a/guix/channels.scm +++ b/guix/channels.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2018 Ludovic Courtès +;;; Copyright © 2018, 2019 Ludovic Courtès ;;; Copyright © 2018 Ricardo Wurmus ;;; ;;; This file is part of GNU Guix. @@ -335,6 +335,26 @@ modules in the old ~/.config/guix/latest style." (define packages (resolve-interface '(gnu packages guile))) + (define modules+compiled + ;; Since MODULES contains both .scm and .go files at its root, re-bundle + ;; it so that it has share/guile/site and lib/guile, which is what + ;; 'whole-package' expects. + (computed-file (derivation-name modules) + (with-imported-modules '((guix build utils)) + #~(begin + (use-modules (guix build utils)) + + (define version + (effective-version)) + (define share + (string-append #$output "/share/guile/site")) + (define lib + (string-append #$output "/lib/guile/" version)) + + (mkdir-p share) (mkdir-p lib) + (symlink #$modules (string-append share "/" version)) + (symlink #$modules (string-append lib "/site-ccache")))))) + (letrec-syntax ((list (syntax-rules (->) ((_) '()) @@ -346,7 +366,7 @@ modules in the old ~/.config/guix/latest style." ((_ variable rest ...) (cons (module-ref packages 'variable) (list rest ...)))))) - (whole-package name modules + (whole-package name modules+compiled ;; In the "old style", %SELF-BUILD-FILE would simply return a ;; derivation that builds modules. We have to infer what the diff --git a/guix/self.scm b/guix/self.scm index 2664fd886f..1e9d5b70e5 100644 --- a/guix/self.scm +++ b/guix/self.scm @@ -133,6 +133,30 @@ GUILE-VERSION (\"2.0\" or \"2.2\"), or #f if none of the packages matches." #:name (file-mapping-name mapping) #:system system)) +(define (node-source+compiled node) + "Return a \"bundle\" containing both the source code and object files for +NODE's modules, under their FHS directories: share/guile/site and lib/guile." + (define build + (with-imported-modules '((guix build utils)) + #~(begin + (use-modules (guix build utils)) + + (define source + (string-append #$output "/share/guile/site/" + (effective-version))) + + (define object + (string-append #$output "/lib/guile/" (effective-version) + "/site-ccache")) + + (mkdir-p (dirname source)) + (symlink #$(node-source node) source) + (mkdir-p (dirname object)) + (symlink #$(node-compiled node) object)))) + + (computed-file (string-append (node-name node) "-modules") + build)) + (define (node-fold proc init nodes) (let loop ((nodes nodes) (visited (setq)) @@ -364,36 +388,53 @@ DOMAIN, a gettext domain." (computed-file "guix-manual" build)) -(define* (guix-command modules #:optional compiled-modules +(define* (guile-module-union things #:key (name "guix-module-union")) + "Return the union of the subset of THINGS (packages, computed files, etc.) +that provide Guile modules." + (define build + (with-imported-modules '((guix build union)) + #~(begin + (use-modules (guix build union)) + + (define (modules directory) + (string-append directory "/share/guile/site")) + + (define (objects directory) + (string-append directory "/lib/guile")) + + (union-build #$output + (filter (lambda (directory) + (or (file-exists? (modules directory)) + (file-exists? (objects directory)))) + '#$things) + + #:log-port (%make-void-port "w"))))) + + (computed-file name build)) + +(define* (guix-command modules #:key source (dependencies '()) guile (guile-version (effective-version))) "Return the 'guix' command such that it adds MODULES and DEPENDENCIES in its load path." - (define source-directories - (map (lambda (package) - (file-append package "/share/guile/site/" - guile-version)) - dependencies)) - - (define object-directories - (map (lambda (package) - (file-append package "/lib/guile/" - guile-version "/site-ccache")) - dependencies)) + (define module-directory + ;; To minimize the number of 'stat' calls needed to locate a module, + ;; create the union of all the module directories. + (guile-module-union (cons modules dependencies))) (program-file "guix-command" #~(begin (set! %load-path - (append (filter file-exists? '#$source-directories) - %load-path)) - - (set! %load-compiled-path - (append (filter file-exists? '#$object-directories) - %load-compiled-path)) + (cons (string-append #$module-directory + "/share/guile/site/" + (effective-version)) + %load-path)) - (set! %load-path (cons #$modules %load-path)) (set! %load-compiled-path - (cons (or #$compiled-modules #$modules) + (cons (string-append #$module-directory + "/lib/guile/" + (effective-version) + "/site-ccache") %load-compiled-path)) (let ((guix-main (module-ref (resolve-interface '(guix ui)) @@ -436,7 +477,6 @@ load path." (define* (whole-package name modules dependencies #:key (guile-version (effective-version)) - compiled-modules info daemon miscellany guile (command (guix-command modules @@ -444,10 +484,9 @@ load path." #:guile guile #:guile-version guile-version))) "Return the whole Guix package NAME that uses MODULES, a derivation of all -the modules, and DEPENDENCIES, a list of packages depended on. COMMAND is the -'guix' program to use; INFO is the Info manual. When COMPILED-MODULES is -true, it is linked as 'lib/guile/X.Y/site-ccache'; otherwise, .go files are -assumed to be part of MODULES." +the modules (under share/guile/site and lib/guile), and DEPENDENCIES, a list +of packages depended on. COMMAND is the 'guix' program to use; INFO is the +Info manual." (computed-file name (with-imported-modules '((guix build utils)) #~(begin @@ -461,28 +500,22 @@ assumed to be part of MODULES." (symlink (string-append #$daemon "/bin/guix-daemon") (string-append #$output "/bin/guix-daemon"))) - (let ((modules (string-append #$output - "/share/guile/site/" - (effective-version))) - (info #$info)) - (mkdir-p (dirname modules)) - (symlink #$modules modules) + (let ((share (string-append #$output "/share")) + (lib (string-append #$output "/lib")) + (info #$info)) + (mkdir-p share) + (symlink #$(file-append modules "/share/guile") + (string-append share "/guile")) (when info - (symlink #$info - (string-append #$output - "/share/info")))) + (symlink #$info (string-append share "/info"))) + + (mkdir-p lib) + (symlink #$(file-append modules "/lib/guile") + (string-append lib "/guile"))) (when #$miscellany (copy-recursively #$miscellany #$output - #:log (%make-void-port "w"))) - - ;; Object files. - (when #$compiled-modules - (let ((modules (string-append #$output "/lib/guile/" - (effective-version) - "/site-ccache"))) - (mkdir-p (dirname modules)) - (symlink #$compiled-modules modules))))))) + #:log (%make-void-port "w"))))))) (define* (compiled-guix source #:key (version %guix-version) (pull-version 1) @@ -681,15 +714,13 @@ assumed to be part of MODULES." ;; Version 1 is when we return the full package. (cond ((= 1 pull-version) ;; The whole package, with a standard file hierarchy. - (let* ((modules (built-modules (compose list node-source))) - (compiled (built-modules (compose list node-compiled))) - (command (guix-command modules compiled + (let* ((modules (built-modules (compose list node-source+compiled))) + (command (guix-command modules #:source source #:dependencies dependencies #:guile guile-for-build #:guile-version guile-version))) (whole-package name modules dependencies - #:compiled-modules compiled #:command command #:guile guile-for-build -- cgit v1.2.3 From efff32452a050e2cd715c38717dd03cad5511bc0 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 7 Jan 2019 23:45:15 +0100 Subject: gexp: 'gexp->script' does not emit load-path expression when unnecessary. This removes two elements from %LOAD-PATH and %LOAD-COMPILED-PATH of the 'guix' command and thus further reduces the number of 'stat' calls it makes. * guix/gexp.scm (load-path-expression): Return #f when MODULES and EXTENSIONS are both empty. (gexp->script): Don't emit anything when SET-LOAD-PATH is #f. --- guix/gexp.scm | 57 ++++++++++++++++++++++++++++++++------------------------- 1 file changed, 32 insertions(+), 25 deletions(-) (limited to 'guix') diff --git a/guix/gexp.scm b/guix/gexp.scm index febd72a904..f7c064297b 100644 --- a/guix/gexp.scm +++ b/guix/gexp.scm @@ -1315,30 +1315,33 @@ they can refer to each other." #:key (extensions '())) "Return as a monadic value a gexp that sets '%load-path' and '%load-compiled-path' to point to MODULES, a list of module names. MODULES -are searched for in PATH." - (mlet %store-monad ((modules (imported-modules modules - #:module-path path)) - (compiled (compiled-modules modules - #:extensions extensions - #:module-path path))) - (return (gexp (eval-when (expand load eval) - (set! %load-path - (cons (ungexp modules) - (append (map (lambda (extension) - (string-append extension - "/share/guile/site/" - (effective-version))) - '((ungexp-native-splicing extensions))) - %load-path))) - (set! %load-compiled-path - (cons (ungexp compiled) - (append (map (lambda (extension) - (string-append extension - "/lib/guile/" - (effective-version) - "/site-ccache")) - '((ungexp-native-splicing extensions))) - %load-compiled-path)))))))) +are searched for in PATH. Return #f when MODULES and EXTENSIONS are empty." + (if (and (null? modules) (null? extensions)) + (with-monad %store-monad + (return #f)) + (mlet %store-monad ((modules (imported-modules modules + #:module-path path)) + (compiled (compiled-modules modules + #:extensions extensions + #:module-path path))) + (return (gexp (eval-when (expand load eval) + (set! %load-path + (cons (ungexp modules) + (append (map (lambda (extension) + (string-append extension + "/share/guile/site/" + (effective-version))) + '((ungexp-native-splicing extensions))) + %load-path))) + (set! %load-compiled-path + (cons (ungexp compiled) + (append (map (lambda (extension) + (string-append extension + "/lib/guile/" + (effective-version) + "/site-ccache")) + '((ungexp-native-splicing extensions))) + %load-compiled-path))))))))) (define* (gexp->script name exp #:key (guile (default-guile)) @@ -1362,7 +1365,11 @@ imported modules in its search path. Look up EXP's modules in MODULE-PATH." "#!~a/bin/guile --no-auto-compile~%!#~%" (ungexp guile)) - (write '(ungexp set-load-path) port) + (ungexp-splicing + (if set-load-path + (gexp ((write '(ungexp set-load-path) port))) + (gexp ()))) + (write '(ungexp exp) port) (chmod port #o555)))) #:module-path module-path))) -- cgit v1.2.3 From 08fdee39110a51cd76afac7a9adf10c794a4c272 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 8 Jan 2019 18:07:16 +0100 Subject: self: Compress Info files. Fixes . Reported by Adonay Felipe Nogueira . * guix/self.scm (info-manual): Compress Info files. --- guix/self.scm | 9 ++++++++- 1 file changed, 8 insertions(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/self.scm b/guix/self.scm index 1e9d5b70e5..e9a768bc90 100644 --- a/guix/self.scm +++ b/guix/self.scm @@ -384,7 +384,14 @@ DOMAIN, a gettext domain." (basename texi ".texi") ".info"))) (cons "guix.texi" - (find-files "." "^guix\\.[a-z]{2}\\.texi$")))))) + (find-files "." "^guix\\.[a-z]{2}\\.texi$"))) + + ;; Compress Info files. + (setenv "PATH" + #+(file-append (specification->package "gzip") "/bin")) + (for-each (lambda (file) + (invoke "gzip" "-9n" file)) + (find-files #$output "\\.info(-[0-9]+)?$"))))) (computed-file "guix-manual" build)) -- 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') 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 @@ Download and deploy the latest version of Guix.\n")) -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') 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 @@ #: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 @@ host name without trailing dot." ;; 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 @@ mounted at FILE." (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 @@ it's an old Guix." "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 @@ please email '~a'~%") "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 @@ The second return value is a thunk to retrieve the current state." ;; 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 (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 @@ report them in a user-friendly way." (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 @@ (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 @@ (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 c3d9bca48a95a535a26eda38707dcd9798400ff3 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 7 Jan 2019 10:42:26 +0100 Subject: download: Remove Guile 2.0 workaround. * guix/build/download.scm: Remove Guile 2.0 workaround. --- guix/build/download.scm | 12 ------------ 1 file changed, 12 deletions(-) (limited to 'guix') diff --git a/guix/build/download.scm b/guix/build/download.scm index 199702a679..24b5aa378f 100644 --- a/guix/build/download.scm +++ b/guix/build/download.scm @@ -504,18 +504,6 @@ port if PORT is a TLS session record port." (module-set! (resolve-module '(web http)) 'parse-rfc-822-date parse-rfc-822-date)) -;; XXX: Work around , present in Guile -;; up to 2.0.11. -(unless (or (> (string->number (major-version)) 2) - (> (string->number (minor-version)) 0) - (> (string->number (micro-version)) 11)) - (let ((var (module-variable (resolve-module '(web http)) - 'declare-relative-uri-header!))) - ;; If 'declare-relative-uri-header!' doesn't exist, forget it. - (when (and var (variable-bound? var)) - (let ((declare-relative-uri-header! (variable-ref var))) - (declare-relative-uri-header! "Location"))))) - ;; XXX: Work around broken proxy handling on Guile 2.2 <= 2.2.2, fixed in ;; Guile commits 7d0d9e2c25c1e872cfc7d14ab5139915f1813d56 and ;; 6ad28ae3bc6a6d9e95ab7d70510d12c97673a143. See bug report at -- 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') 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 @@ 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 @@ ETIMEDOUT error is raised." (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 @@ VERIFY-CERTIFICATE? is true, verify HTTPS server certificates." (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 @@ otherwise simply ignore them." 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 @@ when producing a bootstrap libc." 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 @@ ;;; ;;; 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 @@ returns #f, skip the faulty file altogether." (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 @@ TIMEOUT, an ETIMEDOUT error is raised." (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 @@ TIMEOUT, an ETIMEDOUT error is raised." (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 @@ must be closed before CONN can be used for other purposes." (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 @@ Raise an '&http-get-error' condition if downloading fails." 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 @@ input/output ports.)" ;; 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 @@ provide." (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 @@ initial connection on which HTTP requests are sent." 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 @@ containing MODULE-FILES and possibly other files as well." #: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 @@ right away." (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 @@ can be written." (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 @@ be read. When RECURSIVE? is true, the closure of FILES is exported." (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 @@ to OUT, using chunks of BUFFER-SIZE bytes." (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 @@ See the \"Application Setup\" section in the manual, for more info.\n"))))) ;; 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 @@ (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 6e54e488c6bbeca48f633b03333d856651f24077 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 7 Jan 2019 11:38:53 +0100 Subject: self: Drop support for Guix < 0.15 on Guile 2.0. * guix/self.scm (false-if-wrong-guile, package-for-guile): Remove. (specification->package): Remove "guile2.0-" variants. (compiled-guix): #:guile-for-build defaults to (default-guile). Use 'specification->package' instead of 'package-for-guile'. (guile-for-build): Remove. (guix-derivation): Use 'default-guile' instead of 'guile-for-build'. Check whether we're running on Guile 2.0 with PULL-VERSION < 1. --- guix/self.scm | 89 +++++++++++++---------------------------------------------- 1 file changed, 19 insertions(+), 70 deletions(-) (limited to 'guix') diff --git a/guix/self.scm b/guix/self.scm index a2ae441d42..cf6110613c 100644 --- a/guix/self.scm +++ b/guix/self.scm @@ -31,6 +31,7 @@ #:use-module ((guix build compile) #:select (%lightweight-optimizations)) #:use-module (srfi srfi-1) #:use-module (srfi srfi-9) + #:use-module (srfi srfi-35) #:use-module (ice-9 match) #:export (make-config.scm whole-package ;for internal use in 'guix pull' @@ -43,35 +44,6 @@ ;;; Dependency handling. ;;; -(define* (false-if-wrong-guile package - #:optional (guile-version (effective-version))) - "Return #f if PACKAGE depends on the \"wrong\" major version of Guile (e.g., -2.0 instead of 2.2), otherwise return PACKAGE." - (let ((guile (any (match-lambda - ((label (? package? dep) _ ...) - (and (string=? (package-name dep) "guile") - dep))) - (package-direct-inputs package)))) - (and (or (not guile) - (string-prefix? guile-version - (package-version guile))) - package))) - -(define (package-for-guile guile-version . names) - "Return the package with one of the given NAMES that depends on -GUILE-VERSION (\"2.0\" or \"2.2\"), or #f if none of the packages matches." - (let loop ((names names)) - (match names - (() - #f) - ((name rest ...) - (match (specification->package name) - (#f - (loop rest)) - ((? package? package) - (or (false-if-wrong-guile package guile-version) - (loop rest)))))))) - (define specification->package ;; Use our own variant of that procedure because that of (gnu packages) ;; would traverse all the .scm files, which is wasteful. @@ -89,12 +61,7 @@ GUILE-VERSION (\"2.0\" or \"2.2\"), or #f if none of the packages matches." ("gzip" (ref '(gnu packages compression) 'gzip)) ("bzip2" (ref '(gnu packages compression) 'bzip2)) ("xz" (ref '(gnu packages compression) 'xz)) - ("guile2.0-json" (ref '(gnu packages guile) 'guile2.0-json)) - ("guile2.0-ssh" (ref '(gnu packages ssh) 'guile2.0-ssh)) - ("guile2.0-git" (ref '(gnu packages guile) 'guile2.0-git)) - ;; XXX: No "guile2.0-sqlite3". - ("guile2.0-gnutls" (ref '(gnu packages tls) 'gnutls/guile-2.0)) - (_ #f)))) ;no such package + (_ #f)))) ;no such package ;;; @@ -528,7 +495,7 @@ Info manual." (pull-version 1) (name (string-append "guix-" version)) (guile-version (effective-version)) - (guile-for-build (guile-for-build guile-version)) + (guile-for-build (default-guile)) (zlib (specification->package "zlib")) (gzip (specification->package "gzip")) (bzip2 (specification->package "bzip2")) @@ -536,32 +503,22 @@ Info manual." (guix (specification->package "guix"))) "Return a file-like object that contains a compiled Guix." (define guile-json - (package-for-guile guile-version - "guile-json" - "guile2.0-json")) + (specification->package "guile-json")) (define guile-ssh - (package-for-guile guile-version - "guile-ssh" - "guile2.0-ssh")) + (specification->package "guile-ssh")) (define guile-git - (package-for-guile guile-version - "guile-git" - "guile2.0-git")) + (specification->package "guile-git")) (define guile-sqlite3 - (package-for-guile guile-version - "guile-sqlite3" - "guile2.0-sqlite3")) + (specification->package "guile-sqlite3")) (define guile-gcrypt - (package-for-guile guile-version - "guile-gcrypt")) + (specification->package "guile-gcrypt")) (define gnutls - (package-for-guile guile-version - "gnutls" "guile2.0-gnutls")) + (specification->package "gnutls")) (define dependencies (match (append-map (lambda (package) @@ -950,21 +907,6 @@ containing MODULE-FILES and possibly other files as well." ;;; Building. ;;; -(define (guile-for-build version) - "Return a derivation for Guile 2.0 or 2.2, whichever matches the currently -running Guile." - (define canonical-package ;soft reference - (module-ref (resolve-interface '(gnu packages base)) - 'canonical-package)) - - (match version - ("2.2" - (canonical-package (module-ref (resolve-interface '(gnu packages guile)) - 'guile-2.2))) - ("2.0" - (module-ref (resolve-interface '(gnu packages guile)) - 'guile-2.0)))) - (define* (guix-derivation source version #:optional (guile-version (effective-version)) #:key (pull-version 0)) @@ -981,9 +923,16 @@ is not supported." (define guile ;; When PULL-VERSION >= 1, produce a self-contained Guix and use Guile 2.2 ;; unconditionally. - (guile-for-build (if (>= pull-version 1) - "2.2" - guile-version))) + (default-guile)) + + (when (and (< pull-version 1) + (not (string=? (package-version guile) guile-version))) + ;; Guix < 0.15.0 has PULL-VERSION = 0, where the host Guile is reused and + ;; can be any version. When that happens and Guile is not current (e.g., + ;; it's Guile 2.0), just bail out. + (raise (condition + (&message + (message "Guix is too old and cannot be upgraded"))))) (mbegin %store-monad (set-guile-for-build guile) -- cgit v1.2.3 From 804b9b18ac9188ffb6c6891cbb9241c6a80ed7c8 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 9 Jan 2019 15:01:40 +0100 Subject: build-system/asdf: 'package-with-build-system' accesses inputs lazily. Fixes a bug whereby we would, at the top-level (while evaluation lisp.scm package definitions), attempt to access package inputs. Because of circular dependencies, this could lead to unbound variables as reported by Arun Isaac at . * guix/build-system/asdf.scm (package-with-build-system)[transform] (new-propagated-inputs): Turn into a procedure. Adjust user accordingly. --- guix/build-system/asdf.scm | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) (limited to 'guix') diff --git a/guix/build-system/asdf.scm b/guix/build-system/asdf.scm index 57e294d74d..af04084c86 100644 --- a/guix/build-system/asdf.scm +++ b/guix/build-system/asdf.scm @@ -172,7 +172,7 @@ set up using CL source package conventions." ;; Special considerations for source packages: CL inputs become ;; propagated, and un-handled arguments are removed. - (define new-propagated-inputs + (define (new-propagated-inputs) (if target-is-source? (map rewrite (append @@ -218,7 +218,7 @@ set up using CL source package conventions." (substitute-keyword-arguments base-arguments ((#:phases phases) (list phases-transformer phases)))) (inputs (new-inputs package-inputs)) - (propagated-inputs new-propagated-inputs) + (propagated-inputs (new-propagated-inputs)) (native-inputs (new-inputs package-native-inputs)) (outputs (if target-is-source? '("out") -- 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') 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 @@ descriptions maintained upstream." (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 @@ (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 787da810a03b8113448dc5d9032a71dee51cb0bf Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 10 Jan 2019 14:45:12 +0100 Subject: Add (guix deprecation). * guix/deprecation.scm: New file. * Makefile.am (MODULES): Add it. * po/guix/POTFILES.in: Add it. --- Makefile.am | 1 + guix/deprecation.scm | 89 ++++++++++++++++++++++++++++++++++++++++++++++++++++ po/guix/POTFILES.in | 1 + 3 files changed, 91 insertions(+) create mode 100644 guix/deprecation.scm (limited to 'guix') diff --git a/Makefile.am b/Makefile.am index 9f30d5b2b0..0590c51519 100644 --- a/Makefile.am +++ b/Makefile.am @@ -64,6 +64,7 @@ MODULES = \ guix/base64.scm \ guix/ci.scm \ guix/cpio.scm \ + guix/deprecation.scm \ guix/docker.scm \ guix/records.scm \ guix/pki.scm \ diff --git a/guix/deprecation.scm b/guix/deprecation.scm new file mode 100644 index 0000000000..453aad7106 --- /dev/null +++ b/guix/deprecation.scm @@ -0,0 +1,89 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2019 Ludovic Courtès +;;; +;;; This file is part of GNU Guix. +;;; +;;; GNU Guix is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; GNU Guix is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with GNU Guix. If not, see . + +(define-module (guix deprecation) + #:use-module (guix i18n) + #:use-module (ice-9 format) + #:export (define-deprecated + without-deprecation-warnings + deprecation-warning-port)) + +;;; Commentary: +;;; +;;; Provide a mechanism to mark bindings as deprecated. +;;; +;;; We don't reuse (guix ui) mostly to avoid pulling in too many things. +;;; +;;; Code: + +(define deprecation-warning-port + ;; Port where deprecation warnings go. + (make-parameter (current-warning-port))) + +(define (source-properties->location-string properties) + "Return a human-friendly, GNU-standard representation of PROPERTIES, a +source property alist." + (let ((file (assq-ref properties 'filename)) + (line (assq-ref properties 'line)) + (column (assq-ref properties 'column))) + (if (and file line column) + (format #f "~a:~a:~a" file (+ 1 line) column) + (G_ "")))) + +(define* (warn-about-deprecation variable properties + #:key replacement) + (format (deprecation-warning-port) + (G_ "~a: warning: '~a' is deprecated~@[, use '~a' instead~]~%") + (source-properties->location-string properties) + variable replacement)) + +(define-syntax define-deprecated + (lambda (s) + "Define a deprecated variable or procedure, along these lines: + + (define-deprecated foo bar 42) + (define-deprecated (baz x y) qux (qux y x)) + +This will write a deprecation warning to DEPRECATION-WARNING-PORT." + (syntax-case s () + ((_ (proc formals ...) replacement body ...) + #'(define-deprecated proc replacement + (lambda* (formals ...) body ...))) + ((_ variable replacement exp) + (identifier? #'variable) + (with-syntax ((real (datum->syntax + #'variable + (symbol-append '% + (syntax->datum #'variable) + '/deprecated)))) + #`(begin + (define real + (begin + (lambda () replacement) ;just to ensure it's bound + exp)) + + (define-syntax variable + (lambda (s) + (warn-about-deprecation 'variable (syntax-source s) + #:replacement 'replacement) + (syntax-case s () + ((_ args (... ...)) + #'(real args (... ...))) + (id + (identifier? #'id) + #'real)))))))))) diff --git a/po/guix/POTFILES.in b/po/guix/POTFILES.in index c432973f9e..f7360489c6 100644 --- a/po/guix/POTFILES.in +++ b/po/guix/POTFILES.in @@ -45,4 +45,5 @@ guix/nar.scm guix/channels.scm guix/profiles.scm guix/git.scm +guix/deprecation.scm nix/nix-daemon/guix-daemon.cc -- cgit v1.2.3 From d4d9a1ece0dbf0bc65cc98e971e88a1406bb9c27 Mon Sep 17 00:00:00 2001 From: Ricardo Wurmus Date: Thu, 10 Jan 2019 22:30:54 +0100 Subject: gnu: Update texlive packages. * guix/build-system/texlive.scm (%texlive-tag, %texlive-revision): Update to texlive-2018.2, revision 49435. * gnu/packages/tex.scm (texlive-dvips, texlive-generic-unicode-data, texlive-generic-dehyph-exptl, texlive-generic-hyph-utf8, texlive-fontname, texlive-fonts-cm, texlive-tex-plain, texlive-latex-base, texlive-latex-graphics, texlive-latex-graphics, texlive-latex-oberdiek, texlive-latex-tools, texlive-latex-l3kernel, texlive-latex-l3packages, texlive-latex-fontspec, texlive-latex-amsmath, texlive-latex-amscls, texlive-latex-babel, texlive-latex-cyrillic, texlive-latex-eqparbox, texlive-latex-ifplatform, texlive-latex-etoolbox, texlive-latex-galois, texlive-latex-polyglossia, texlive-tex-texinfo, texlive-latex-changebar, texlive-latex-fancyhdr, texlive-latex-overpic, texlive-latex-parskip, texlive-metapost, texlive-latex-ucs, texlive-generic-pdftex, texlive-latex-media9, texlive-latex-ocgx2, texlive-latex-koma-script, texlive-generic-listofitems, texlive-bibtex, texlive-context-base): Update hashes. (texlive-latex-fontspec)[arguments]: Remove custom build target. (texlive-latex-dinbrief)[arguments]: Add build phase "fix-encoding-error". (texlive-latex-xkeyval): New variable. (texlive-latex-pstool)[source]: Fetch from new location. [build-system]: Use trivial-build-system. [arguments]: Write simple builder. [propagated-inputs]: Add texlive-latex-l3kernel, texlive-latex-tools, and texlive-latex-xkeyval. [synopsis]: Fix typo. --- gnu/packages/tex.scm | 150 +++++++++++++++++++++++++++--------------- guix/build-system/texlive.scm | 7 +- 2 files changed, 100 insertions(+), 57 deletions(-) (limited to 'guix') diff --git a/gnu/packages/tex.scm b/gnu/packages/tex.scm index 3bfde1d714..7aa83e4404 100644 --- a/gnu/packages/tex.scm +++ b/gnu/packages/tex.scm @@ -255,7 +255,7 @@ This package contains the binaries.") (file-name (string-append name "-" version "-checkout")) (sha256 (base32 - "0fcy2hpapbj01ncpjj3v39yhr0jjxb6rm13qaxjjw66s3vydxls1")))) + "1ky6wc173jhf0b33lhyb4r3bx1d4bmiqkn6y1hxn92kwjdzl42p7")))) (build-system trivial-build-system) (arguments `(#:modules ((guix build utils)) @@ -286,7 +286,7 @@ This package contains the binaries.") (file-name (string-append "dvips-font-maps-" version "-checkout")) (sha256 (base32 - "09hply3nmy24ilnc6cl8q70jcqxvq6bwri572kms008ini3h9vqh")))) + "0nxvfbb5vsvakiw0iviicghdc2sxk05cj056ilqnpa62fffc36a6")))) ("dvips-base-enc" ,(origin (method svn-fetch) @@ -322,7 +322,7 @@ to PostScript.") (file-name (string-append name "-" version "-checkout")) (sha256 (base32 - "0ivrhp6jz31pl4z841g4ws41lmvdiwz4sslmhf02inlib79gz6r2")))) + "0r1v16jyfpz6dwqsgm6b9jcj4kf2pkzc9hg07s6fx9g8ba8qglih")))) (build-system trivial-build-system) (arguments `(#:modules ((guix build utils)) @@ -361,7 +361,7 @@ out to date by @code{unicode-letters.tex}. ") (file-name (string-append name "-" version "-checkout")) (sha256 (base32 - "1l9wgv99qq0ysvlxqpj4g8bl0dywbzra4g8m2kmpg2fb0i0hczap")))) + "03yj1di9py92drp6gpfva6q69vk2iixr79r7cp7ja570s3pr0m33")))) (build-system trivial-build-system) (arguments `(#:modules ((guix build utils)) @@ -432,7 +432,7 @@ to adapt the plain e-TeX source file to work with XeTeX and LuaTeX.") (file-name (string-append name "-" version "-checkout")) (sha256 (base32 - "0ghizcz7ps16dzfqf66wwg5i181assc6qsm0g7g5dbmp909931vi")))) + "1alnn9cd60m2c12vym9f9q22ap1ngywxpkjl9dk472why44g1dmy")))) (build-system trivial-build-system) (arguments `(#:modules ((guix build utils)) @@ -541,7 +541,7 @@ build fonts using the Metafont system.") (file-name (string-append name "-" version "-checkout")) (sha256 (base32 - "0cssbzcx15221dynp5sii72qh4l18mwkr14n8w1xb19j8pbaqasz")))) + "05rbn7z30xawd3n6w7c3ijp2yc67ga220jgqmkla9pd9wx185rzq")))) (build-system trivial-build-system) (arguments `(#:modules ((guix build utils)) @@ -575,7 +575,7 @@ documents.") (file-name (string-append name "-" version "-checkout")) (sha256 (base32 - "045k5b9rdmbxpy1a3006l1x96z1rd18vg3cwrvnld9bqybw5qz44")))) + "0vfjhidr9pha613h8mfhnpcpvld6ahdfb449918fpsfs93cppkyj")))) (build-system gnu-build-system) (arguments `(#:modules ((guix build gnu-build-system) @@ -916,7 +916,7 @@ individual symbols defined in @code{amssymb.sty}.") (file-name (string-append name "-" version "-checkout")) (sha256 (base32 - "0mjgl3gscn3ps29yjambz1j9fg81ynnncb96vpprwx4xsijhsns0")))) + "1xknlb3gcw6jjqh97bhghxi594bzpj1zfzzfsrr9pvr9s1bx7dnf")))) (build-system trivial-build-system) (arguments `(#:modules ((guix build utils)) @@ -961,7 +961,7 @@ book).") (file-name (string-append name "-" version "-checkout")) (sha256 (base32 - "1h9pir2hz6i9avc4lrl733p3zf4rpkg8537x1zdbhs91hvhikw9k")))) + "17bqrzzjz16k52sc7ydl4vw7ddy2z3g0p1xsk2c35h1ynq9h3wwm")))) (build-system gnu-build-system) (arguments `(#:modules ((guix build gnu-build-system) @@ -1082,7 +1082,7 @@ book).") "1cfwdg2rhbayl3w0x1xqd36d45zbc96f029myp13s7cb6kbmbppv")) ("texlive-generic-config" ,(texlive-dir "tex/generic/config/" - "19vj088p4kkp6xll0141m4kl6ssgdzhs3g10i232khb07aqiag8s")) + "1v90iihy112q93zdpblpdk8zv8rf99fgslsg06s1sxm27zjm9nap")) ("texlive-latex-base-support-files" ,(origin (method svn-fetch) @@ -1094,7 +1094,7 @@ book).") (file-name (string-append name "-" version "-checkout")) (sha256 (base32 - "16bs9pi3nq407xhg59glklqv43v102cg3yim6k3zcri5d9nkbv3a")))) + "18wy8dlcw8adl6jzqwbg54pdwlhs8hilnfvqbw6ikj6y3zhqkj7q")))) ("texlive-tex-plain" ,texlive-tex-plain) ("texlive-fonts-cm" ,texlive-fonts-cm) ("texlive-fonts-latex" ,texlive-fonts-latex) @@ -1233,7 +1233,7 @@ verbatim source).") (file-name (string-append name "-" version "-checkout")) (sha256 (base32 - "07azyn0b1s49vbdlr6dmygrminxp72ndl24j1091hiiccvrjq3xc")))) + "0nlfhn55ax89rcvpkrl9570671b62kcr4c9l5ch3w5zw9vmi00dz")))) (build-system texlive-build-system) (arguments '(#:tex-directory "latex/graphics" @@ -1282,7 +1282,7 @@ verbatim source).") "-checkout")) (sha256 (base32 - "0gi4qv6378nl84s8n1yx3hjqvv7r4lza7hpbymbl5rzwgw8qrnyb")))))) + "17zpcgrfsr29g1dkz9np1qi63kjv7gb12rg979c6dai6qksbr3vq")))))) (home-page "https://www.ctan.org/pkg/latex-graphics") (synopsis "LaTeX standard graphics bundle") (description @@ -1358,7 +1358,7 @@ pdf and HTML backends. The package is distributed with the @code{backref} and (file-name (string-append name "-" version "-checkout")) (sha256 (base32 - "0aswvsxgsn709xmvpcg50d2xl7vcy1ckdxb9c1cligqqfjjvviqf")))) + "1m9fg8ddhpsl1212igr9a9fmj012lv780aghjn6fpidg2wqrffmn")))) (build-system texlive-build-system) (arguments '(#:tex-directory "latex/oberdiek" @@ -1389,7 +1389,7 @@ arrows; record information about document class(es) used; and many more.") (file-name (string-append name "-" version "-checkout")) (sha256 (base32 - "052a0pch2k5zls5jlay9xxcf93rw3i60a2x28y3ip3rhbsv3xgiz")))) + "0vj7h1fgf1396h4qjdc2m07y08i54gbbfrxl8y327cn3r1n093s6")))) (build-system texlive-build-system) (arguments '(#:tex-directory "latex/tools" @@ -1455,7 +1455,7 @@ of file names.") (file-name (string-append name "-" version "-checkout")) (sha256 (base32 - "0r0wfk594j8wkdqhh21haimwsfq8x5jch4ldm21hkzk5dnmvpbg6")))) + "0p3fsxap1ilwjz356aq4s5ygwvdscis8bh93g8klf8mhrd8cr2jy")))) (build-system texlive-build-system) (arguments '(#:tex-directory "latex/l3kernel")) @@ -1479,7 +1479,7 @@ that the LaTeX3 conventions can be used with regular LaTeX 2e packages.") (file-name (string-append name "-" version "-checkout")) (sha256 (base32 - "16jplkvzdysfssijq9l051nsks65c2nrarsl17k8gjhc28yznj8y")))) + "0pyx0hffiyss363vv7fkrcdiaf7p099xnq0mngzqc7v8v9q849hs")))) (build-system texlive-build-system) (arguments '(#:tex-directory "latex/l3packages" @@ -1534,11 +1534,10 @@ programming tools and kernel sup­port. Packages provided in this release are: (file-name (string-append name "-" version "-checkout")) (sha256 (base32 - "1rx43y5xmjqvc27pjdnmqwp4pcw3czcfd6nfpmzc1gnqfl1hlc0q")))) + "1p0mkn6iywl0k4m9cx3hnhylpi499inisff3f72pcf349baqsnvq")))) (build-system texlive-build-system) (arguments - '(#:tex-directory "latex/fontspec" - #:build-targets '("fontspec.dtx"))) + '(#:tex-directory "latex/fontspec")) (inputs `(("texlive-latex-l3kernel" ,texlive-latex-l3kernel))) (home-page "https://www.ctan.org/pkg/fontspec") @@ -1598,7 +1597,7 @@ this bundle for use independent of ConTeXt.") (file-name (string-append name "-" version "-checkout")) (sha256 (base32 - "178ywjpdlv78qmfzqdyn6gy14620zjsn2q9wap76fbr9s4hw6dba")))) + "0arvk7gn32mshnfdad5qkgf3i1arxq77k3vq7wnpm4nwnrzclxal")))) (build-system texlive-build-system) (arguments '(#:tex-directory "latex/amsmath")) (home-page "https://www.ctan.org/pkg/amsmath") @@ -1627,7 +1626,7 @@ definitions.") (file-name (string-append name "-" version "-checkout")) (sha256 (base32 - "0jmcr37mcdi7drczppvr6lmz5d5yd9m67ii79gp2nglg1xpw934j")))) + "0c2j9xh4qpi0x1vvcxdjxq6say0zhyr569fryi5cmhp8bclh4kca")))) (build-system texlive-build-system) (arguments `(#:tex-directory "latex/amscls")) @@ -1651,7 +1650,7 @@ distribution.") (file-name (string-append name "-" version "-checkout")) (sha256 (base32 - "1n3i5adsyy7jw0imnzrm2i8wkf73i3mjk9h3ic8cb9cd19i4r9r3")))) + "0yhlfiz3fjc8jd46f1zrjj4jig48l8rrzh8cmd8ammml8z9a01z6")))) (build-system texlive-build-system) (arguments '(#:tex-directory "generic/babel" @@ -1708,7 +1707,7 @@ for Canadian and USA text.") (file-name (string-append name "-" version "-checkout")) (sha256 (base32 - "1mdhl35hwas68ki56qqngzar37dwv4mm64l2canihr255bz34lbv")))) + "083xbwg7hrnlv47fkwvz8yjb830bhxx7y0mq7z7nz2f96y2ldr6b")))) (build-system texlive-build-system) (arguments '(#:tex-directory "latex/cyrillic")) @@ -1942,6 +1941,13 @@ ipsum\" text, see the @code{lipsum} package).") (add-after 'unpack 'remove-generated-file (lambda _ (delete-file "dinbrief.drv") + #t)) + (add-after 'unpack 'fix-encoding-error + (lambda _ + (with-fluids ((%default-port-encoding "ISO-8859-1")) + (substitute* "dinbrief.dtx" + (("zur Verf.+ung. In der Pr\"aambel") + "zur Verf\"ung. In der Pr\"aambel"))) #t))))) (home-page "https://www.ctan.org/pkg/dinbrief") (synopsis "German letter DIN style") @@ -2012,7 +2018,7 @@ define a new author interface to creating new environments.") (file-name (string-append name "-" version "-checkout")) (sha256 (base32 - "0pvmhsd4xmpil0m3c7qcgwilbk266mlkzv03g0jr8r3zd8jxlyzq")))) + "1ib5xdwcj5wk23wgk41m2hdcjr1dzrs4l3wwnpink9mlapz12wjs")))) (build-system texlive-build-system) (arguments '(#:tex-directory "latex/eqparbox")) (home-page "https://www.ctan.org/pkg/eqparbox") @@ -2110,7 +2116,7 @@ but non-expandable ones.") (file-name (string-append name "-" version "-checkout")) (sha256 (base32 - "11gvvjvmdfs9b7mm19yf80zwkx49jqcbq6g8qb9y5ns1r1qvnixp")))) + "157pplavvm2z97b3jl4x41w11k6q9wgy074mfg0dwmsx5lm328jy")))) (build-system texlive-build-system) (arguments '(#:tex-directory "latex/ifplatform")) (home-page "https://www.ctan.org/pkg/ifplatform") @@ -2174,34 +2180,70 @@ with a user specified LaTeX construction, properly aligned, scaled, and/or rotated.") (license (license:fsf-free "file://psfrag.dtx")))) +(define-public texlive-latex-xkeyval + (package + (name "texlive-latex-xkeyval") + (version (number->string %texlive-revision)) + (source (origin + (method svn-fetch) + (uri (texlive-ref "latex" "xkeyval")) + (file-name (string-append name "-" version "-checkout")) + (sha256 + (base32 + "0wancavix39j240pd8m9cgmwsijwx6jd6n54v8wg0x2rk5m44myp")))) + (build-system texlive-build-system) + (arguments '(#:tex-directory "latex/xkeyval")) + (home-page "https://www.ctan.org/pkg/xkeyval") + (synopsis "Macros for defining and setting keys") + (description + "This package is an extension of the @code{keyval} package and offers +more flexible macros for defining and setting keys. The package provides a +pointer and a preset system. Furthermore, it supplies macros to allow class +and package options to contain options of the @code{key=value} form. A LaTeX +kernel patch is provided to avoid premature expansions of macros in class or +package options. A specialized system for setting @code{PSTricks} keys is +provided by the @code{pst-xkey} package.") + (license license:lppl1.3+))) + (define-public texlive-latex-pstool (package (name "texlive-latex-pstool") (version (number->string %texlive-revision)) (source (origin (method svn-fetch) - (uri (texlive-ref "latex" "pstool")) + (uri (svn-reference + (url (string-append "svn://www.tug.org/texlive/tags/" + %texlive-tag "/Master/texmf-dist/" + "/tex/latex/pstool")) + (revision %texlive-revision))) (file-name (string-append name "-" version "-checkout")) (sha256 (base32 - "1kwlk1x67lad4xb7gpkxqgdlxwpi6nvq1r9wika7m92abmyf18h3")))) - (build-system texlive-build-system) + "1h816jain8c9nky75kk8pmmwj5b4yf9dpqvdvi2l6jhfj5iqkzr8")))) + (build-system trivial-build-system) (arguments - '(#:tex-directory "latex/pstool" - #:tex-format "latex")) - (inputs - `(("texlive-fonts-cm" ,texlive-fonts-cm) - ("texlive-latex-filecontents" ,texlive-latex-filecontents))) + `(#:modules ((guix build utils)) + #:builder + (begin + (use-modules (guix build utils)) + (let ((target (string-append (assoc-ref %outputs "out") + "/share/texmf-dist/tex/latex/pstool"))) + (mkdir-p target) + (copy-recursively (assoc-ref %build-inputs "source") target) + #t)))) (propagated-inputs - `(("texlive-latex-bigfoot" ,texlive-latex-bigfoot) + `(("texlive-latex-bigfoot" ,texlive-latex-bigfoot) ; for suffix ("texlive-latex-filemod" ,texlive-latex-filemod) ("texlive-latex-graphics" ,texlive-latex-graphics) ("texlive-latex-ifplatform" ,texlive-latex-ifplatform) + ("texlive-latex-l3kernel" ,texlive-latex-l3kernel) ; for expl3 ("texlive-latex-oberdiek" ,texlive-latex-oberdiek) ("texlive-latex-psfrag" ,texlive-latex-psfrag) - ("texlive-latex-trimspaces" ,texlive-latex-trimspaces))) + ("texlive-latex-tools" ,texlive-latex-tools) ; for shellesc + ("texlive-latex-trimspaces" ,texlive-latex-trimspaces) + ("texlive-latex-xkeyval" ,texlive-latex-xkeyval))) (home-page "https://www.ctan.org/pkg/pstool") - (synopsis "Process PostScript graphisc within pdfLaTeX documents") + (synopsis "Process PostScript graphics within pdfLaTeX documents") (description "This is a package for processing PostScript graphics with @code{psfrag} labels within pdfLaTeX documents. Every graphic is compiled individually, @@ -2356,7 +2398,7 @@ hyperlink to the target of the DOI.") (file-name (string-append name "-" version "-checkout")) (sha256 (base32 - "0016bscnpima9krrg2569mva78xzwnygzlvg87dznsm6gf8g589v")))) + "1agmq6bf8wzcd77n20ng8bl4kh69cg5f6sjniii7bcw4llhd3nc8")))) (build-system trivial-build-system) (arguments `(#:modules ((guix build utils)) @@ -2538,7 +2580,7 @@ BibLaTeX, and is considered experimental.") (file-name (string-append name "-" version "-checkout")) (sha256 (base32 - "1r2kfcwclg33yk5z8mvlagwxj7nr1mc3w4bdpmhrwv6dn8mrbvw8")))) + "0yw6bjfgsli3s1dldsgb7mkr7lnk329cgdjbgs8z2xn59pmmdsn4")))) (build-system texlive-build-system) (arguments '(#:tex-directory "latex/geometry")) (home-page "https://www.ctan.org/pkg/geometry") @@ -2587,7 +2629,7 @@ array environments; verbatim handling; and syntax diagrams.") (file-name (string-append name "-" version "-checkout")) (sha256 (base32 - "09mvszd5qgqg4cfglpj5qxyzjz190ppb9p8gnsnjydwp1akvhayf")))) + "03ma58z3ypsbp7zgkzb1ylpn2ygr27cxzkf042ns0rif4g8s491f")))) (build-system texlive-build-system) (arguments '(#:tex-directory "latex/polyglossia")) (home-page "https://www.ctan.org/pkg/polyglossia") @@ -2633,7 +2675,7 @@ situations where longtable has problems.") (file-name (string-append name "-" version "-checkout")) (sha256 (base32 - "09zj2w3lx0y6i2syfjjgizahf86z301dw8p37ln6syfhqhzqdz46")))) + "06cf821y1j7jdg93pb41ayigrfwgn0y49d7w1025zlijjxi6bvjp")))) (build-system trivial-build-system) (arguments `(#:modules ((guix build utils)) @@ -2750,7 +2792,7 @@ command.") (file-name (string-append name "-" version "-checkout")) (sha256 (base32 - "1ik4m8pzfsn1grlda6fniqqfwmgj7rfxwg63jdw0p0qv002vc7ik")))) + "05x15ilynqrl448h8l6qiraygamdldlngz89a2bw7kg74fym14ch")))) (build-system texlive-build-system) (arguments '(#:tex-directory "latex/changebar")) (home-page "https://www.ctan.org/pkg/changebar") @@ -2866,7 +2908,7 @@ floats, center, flushleft, and flushright, lists, and pages.") (file-name (string-append name "-" version "-checkout")) (sha256 (base32 - "04h430agf8aj7ziwyb46xpk95c605rjk1wzhr63m6ylipihidlgw")))) + "1xsnzx7vgdfh9zh2m7bjz6bgdpxsgb1kyc19p50vhs34x5nbgsnr")))) (build-system trivial-build-system) (arguments `(#:modules ((guix build utils)) @@ -3284,7 +3326,7 @@ entry at the \"natural\" width of its text.") (file-name (string-append name "-" version "-checkout")) (sha256 (base32 - "0m29q9qdb00558b7g2i7iw6w62n5s46yx81j8m99qkv77magk4fm")))) + "1rpx4ibjncj5416rg19v0xjbj3z9avhfdfn2gzp8r8sz9vz25c6g")))) (build-system trivial-build-system) (arguments `(#:modules ((guix build utils)) @@ -3350,7 +3392,7 @@ designed class) helps alleviate this untidiness.") (file-name (string-append name "-" version "-checkout")) (sha256 (base32 - "06p5smfq66559ppdnmkl3hp8534x84ywbscimsiir4gllpya3i9h")))) + "0s4izcah7im67889qz4d26pcfpasmm35sj1rw4ragkkdk3rlbbbd")))) (build-system texlive-build-system) (arguments '(#:tex-directory "latex/pdfpages")) (home-page "https://www.ctan.org/pkg/pdfpages") @@ -3764,7 +3806,7 @@ OT2 encoded fonts, CM bright shaped fonts and Concrete shaped fonts.") (file-name (string-append name "-" version "-checkout")) (sha256 (base32 - "03nvjddffiz796wll6axzmgfvynyciy2mqamv20qx252w71vwkwd")))) + "0sf18pc6chgy26p9bxxn44xcqhzjrfb53jxjr2y7l3jb6xllhblq")))) (build-system trivial-build-system) (arguments `(#:modules ((guix build utils)) @@ -3944,7 +3986,7 @@ package of that name now exists.") (file-name (string-append name "-" version "-checkout")) (sha256 (base32 - "0j6fff6q0ca96nwfdgay2jm55792z4q9aa0rczmiw2qccyg5n2dv")))) + "1hpsk4yp08qvbl43kqiv0hhwxv3gcqqxcpahyv6ch2b38pbj4bh6")))) (build-system texlive-build-system) (arguments '(#:tex-directory "latex/preview" @@ -4031,7 +4073,7 @@ e-TeX.") (file-name (string-append name "-map-" version "-checkout")) (sha256 (base32 - "197z9kx3bpnz58f5xrn5szyvmb3fxqq12y5sc4dw4jnm3xll8ji2")))))) + "18jvcm0vwpg6wwzijvnb92xx78la45kkh71k6l44425krp2vnwm0")))))) (home-page "https://www.ctan.org/pkg/pdftex") (synopsis "TeX extension for direct creation of PDF") (description @@ -4511,7 +4553,7 @@ required: automatic sectioning and pagination, spell checking and so forth.") (file-name (string-append name "-" version "-checkout")) (sha256 (base32 - "01ysky8h8s6q12dxfahkzwhbkc9j5wl50xzcczy0cbjx9f6aj9kv")))) + "0lhb2h5hxjq9alpk4r3gvg21pwyifs4ah6hqzp92k55mkp1xv73j")))) (build-system trivial-build-system) (arguments `(#:modules ((guix build utils)) @@ -4551,7 +4593,7 @@ specification. It replaces the now obsolete @code{movie15} package.") (file-name (string-append name "-" version "-checkout")) (sha256 (base32 - "12kkl7n534j0p4frwyrlw22dc3ik50kxv97cxp4xpmji13m0hxpf")))) + "0zp00jg058djx8xp0xqwas92y3j97clkyd8z6pqr890yqy06myqb")))) (build-system trivial-build-system) (arguments `(#:modules ((guix build utils)) @@ -4781,7 +4823,7 @@ produce either PostScript or PDF output.") (file-name (string-append name "-" version "-checkout")) (sha256 (base32 - "1g8qg796hc6s092islnybaxs115ldsqwp2vxkk3gpy6vh7wc9r50")))) + "0nqwf0sr4mf3v9gqa6apv6ml2xhcdwax0vgyf12a672g7rpdyvgm")))) (build-system trivial-build-system) (arguments `(#:modules ((guix build utils) @@ -4841,7 +4883,7 @@ typearea (which are the main parts of the bundle).") (file-name (string-append name "-" version "-checkout")) (sha256 (base32 - "1k50z6ixgwwzy84mi0dr5vcjah5p7wvgq66y45bilm91a4m8sgla")))) + "0hs28fc0v2l92ad9las9b8xcckyrdrwmyhcx1yzmbr6s7s6nvsx8")))) (build-system trivial-build-system) (arguments `(#:modules ((guix build utils)) @@ -5107,7 +5149,7 @@ TeX).") (file-name (string-append name "-" version "-checkout")) (sha256 (base32 - "1gk9q22fcb2fa1ql6cf9yw505x6a6axdzzfxbsya7nkrph860af8")))) + "0hnbs0s1znbn32hfcsyijl39z81sdb00jf092a4blqz421qs2mbv")))) (build-system trivial-build-system) (arguments `(#:modules ((guix build utils)) @@ -5211,7 +5253,7 @@ for use with LaTeX is available in @code{freenfss}, part of (file-name (string-append name "-" version "-checkout")) (sha256 (base32 - "0zwl0cg6pka13i26dpqh137391f3j9sk69cpvwrm4ivsa0rqnw6g")))) + "0rlx4qqijms1n64gjx475kvip8l322fh7v17zkmwp1l1g0w3vlyz")))) (build-system trivial-build-system) (arguments `(#:modules ((guix build utils)) diff --git a/guix/build-system/texlive.scm b/guix/build-system/texlive.scm index 80882b144b..b6a86a1c62 100644 --- a/guix/build-system/texlive.scm +++ b/guix/build-system/texlive.scm @@ -39,9 +39,10 @@ ;; ;; Code: -;; These variables specify the SVN tag and the matching SVN revision. -(define %texlive-tag "texlive-2017.1") -(define %texlive-revision 44591) +;; These variables specify the SVN tag and the matching SVN revision. They +;; are taken from https://www.tug.org/svn/texlive/tags/ +(define %texlive-tag "texlive-2018.2") +(define %texlive-revision 49435) (define (texlive-ref component id) "Return a object for the package ID, which is part of the -- cgit v1.2.3 From ac5c9f6ba6e80f9e7255442a4e0f0f3aeb2960d5 Mon Sep 17 00:00:00 2001 From: Ricardo Wurmus Date: Thu, 10 Jan 2019 22:41:23 +0100 Subject: build-system: texlive: Do not truncate lines. * guix/build/texlive-build-system.scm (configure): Set environment variables to prevent build output lines from being truncated. --- guix/build/texlive-build-system.scm | 7 ++++++- 1 file changed, 6 insertions(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/build/texlive-build-system.scm b/guix/build/texlive-build-system.scm index 1c393ecd9d..a7cb8dd1ad 100644 --- a/guix/build/texlive-build-system.scm +++ b/guix/build/texlive-build-system.scm @@ -60,7 +60,12 @@ (("^TEXMF = .*") "TEXMF = $TEXMFROOT/share/texmf-dist\n")) (setenv "TEXMFCNF" (dirname texmf.cnf)) - (setenv "TEXMF" (string-append out "/share/texmf-dist"))) + (setenv "TEXMF" (string-append out "/share/texmf-dist")) + + ;; Don't truncate lines. + (setenv "error_line" "254") ; must be less than 255 + (setenv "half_error_line" "238") ; must be less than error_line - 15 + (setenv "max_print_line" "1000")) (mkdir "build") #t) -- cgit v1.2.3 From bf6fb59a3372a23244f84298e8432195cb8f729b Mon Sep 17 00:00:00 2001 From: Ricardo Wurmus Date: Thu, 10 Jan 2019 22:42:17 +0100 Subject: build-system: texlive: Do not hide build output. * guix/build/texlive-build-system.scm (compile-with-latex): Use "nonstopmode" instead of "batchmode". --- guix/build/texlive-build-system.scm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/build/texlive-build-system.scm b/guix/build/texlive-build-system.scm index a7cb8dd1ad..841c631dae 100644 --- a/guix/build/texlive-build-system.scm +++ b/guix/build/texlive-build-system.scm @@ -35,7 +35,7 @@ (define (compile-with-latex format file) (invoke format - "-interaction=batchmode" + "-interaction=nonstopmode" "-output-directory=build" (string-append "&" format) file)) -- 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') 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 @@ #: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 @@ specified with `--select'.\n")) (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 @@ dependent packages are rebuilt: ~{~a~^ ~}~%" (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 @@ all are dependent packages: ~{~a~^ ~}~%") (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 @@ update would trigger a complete rebuild." ;; 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') 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 @@ all are dependent packages: ~{~a~^ ~}~%") ;; 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') 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 @@ (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 @@ message if any test fails." (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 @@ Create a bundle of PACKAGE.\n")) (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 @@ processed, #f otherwise." (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 @@ Use '~/.config/guix/channels.scm' instead.")) (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 @@ argument list and OPTS is the option alist." (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 @@ print-build-event/quiet print-build-status - with-status-report)) + with-status-report + with-status-verbosity)) ;;; Commentary: ;;; @@ -649,3 +650,17 @@ The second return value is a thunk to retrieve the current state." "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') 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 @@ #: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 @@ (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 @@ Export/import one or more packages from/to the store.\n")) -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 @@ Export/import one or more packages from/to the store.\n")) (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 @@ build and a list of store files to transfer." 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 @@ the input 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 @@ options handled by 'set-build-options-from-command-line', and listed in 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 @@ options handled by 'set-build-options-from-command-line', and listed in (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 @@ options handled by 'set-build-options-from-command-line', and listed in (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 @@ options handled by 'set-build-options-from-command-line', and listed in (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 @@ Build the given PACKAGE-OR-DERIVATION and return their output paths.\n")) -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 @@ must be one of 'package', 'all', or 'transitive'~%") (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 @@ needed." (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 @@ COMMAND or an interactive shell in that environment.\n")) (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 @@ COMMAND or an interactive shell in that environment.\n")) (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 @@ COMMAND or an interactive shell in that environment.\n")) (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 @@ message if any test fails." (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 @@ please email '~a'~%") (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 @@ please email '~a'~%") (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 @@ Create a bundle of PACKAGE.\n")) (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 @@ Create a bundle of PACKAGE.\n")) (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 @@ ENTRIES, a list of manifest entries, in the context of PROFILE." (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 @@ Install, remove, or upgrade packages in a single transaction.\n")) (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 @@ kind of search path~%") (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 @@ processed, #f otherwise." (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 @@ (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 @@ Download and deploy the latest version of Guix.\n")) (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 @@ Download and deploy the latest version of Guix.\n")) (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 @@ Use '~/.config/guix/channels.scm' instead.")) (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 @@ Some ACTIONS support additional ARGS.\n")) --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 @@ Some ACTIONS support additional ARGS.\n")) (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 @@ Some ACTIONS support additional ARGS.\n")) (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 @@ argument list and OPTS is the option alist." (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') 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 @@ KEY-DOWNLOAD specifies a download policy for missing OpenPGP keys; allowed 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 @@ warn about packages that have no matching updater." (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 @@ upstream-source-urls upstream-source-signature-urls upstream-source-archive-types + upstream-source-input-changes url-prefix-predicate coalesce-sources @@ -56,6 +58,12 @@ 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 @@ (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 @@ values: the item from LST1 and the item from LST2 that match PRED." (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 @@ and 'interactive' (default)." (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 91e05559bdf21b49686cc2629c44a6d0a6db0a61 Mon Sep 17 00:00:00 2001 From: Ricardo Wurmus Date: Fri, 11 Jan 2019 09:27:21 +0100 Subject: import: cran: Suggest input changes. * guix/import/cran.scm (latest-cran-release, latest-bioconductor-release): Return input-changes. --- guix/import/cran.scm | 29 ++++++++++++++++++----------- 1 file changed, 18 insertions(+), 11 deletions(-) (limited to 'guix') diff --git a/guix/import/cran.scm b/guix/import/cran.scm index 15163bd165..b287be6941 100644 --- a/guix/import/cran.scm +++ b/guix/import/cran.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2015, 2016, 2017, 2018 Ricardo Wurmus +;;; Copyright © 2015, 2016, 2017, 2018, 2019 Ricardo Wurmus ;;; Copyright © 2015, 2016, 2017 Ludovic Courtès ;;; Copyright © 2017 Mathieu Othacehe ;;; @@ -390,11 +390,11 @@ s-expression corresponding to that package, or #f on failure." (_ #f))) (_ #f))))) -(define (latest-cran-release package) - "Return an for the latest release of PACKAGE." +(define (latest-cran-release pkg) + "Return an for the latest release of the package PKG." (define upstream-name - (package->upstream-name package)) + (package->upstream-name pkg)) (define meta (fetch-description 'cran upstream-name)) @@ -403,15 +403,18 @@ s-expression corresponding to that package, or #f on failure." (let ((version (assoc-ref meta "Version"))) ;; CRAN does not provide signatures. (upstream-source - (package (package-name package)) + (package (package-name pkg)) (version version) - (urls (cran-uri upstream-name version)))))) + (urls (cran-uri upstream-name version)) + (input-changes + (changed-inputs pkg + (description->package 'cran meta))))))) -(define (latest-bioconductor-release package) - "Return an for the latest release of PACKAGE." +(define (latest-bioconductor-release pkg) + "Return an for the latest release of the package PKG." (define upstream-name - (package->upstream-name package)) + (package->upstream-name pkg)) (define version (latest-bioconductor-package-version upstream-name)) @@ -419,9 +422,13 @@ s-expression corresponding to that package, or #f on failure." (and version ;; Bioconductor does not provide signatures. (upstream-source - (package (package-name package)) + (package (package-name pkg)) (version version) - (urls (bioconductor-uri upstream-name version))))) + (urls (bioconductor-uri upstream-name version)) + (input-changes + (changed-inputs + pkg + (cran->guix-package upstream-name 'bioconductor)))))) (define (cran-package? package) "Return true if PACKAGE is an R package from CRAN." -- 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') 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 @@ Download and deploy the latest version of Guix.\n")) (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') 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 @@ #: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 @@ Copy ITEMS to or from the specified host over SSH.\n")) --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 @@ Copy ITEMS to or from the specified host over SSH.\n")) (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 @@ Copy ITEMS to or from the specified host over SSH.\n")) (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 @@ Copy ITEMS to or from the specified host over SSH.\n")) (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') 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 @@ and upgrades." (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: Tue, 15 Jan 2019 11:47:25 +0100 Subject: status: Spin only on TTYs. * guix/status.scm (isatty?*): New procedure. (spin!): Do nothing when port matches ISATTY?*. (color-output?): Use ISATTY?*. --- guix/status.scm | 20 +++++++++++++------- 1 file changed, 13 insertions(+), 7 deletions(-) (limited to 'guix') diff --git a/guix/status.scm b/guix/status.scm index 2928733257..478c475f8c 100644 --- a/guix/status.scm +++ b/guix/status.scm @@ -27,6 +27,7 @@ #:select (nar-uri-abbreviation)) #:use-module (guix store) #:use-module (guix derivations) + #:use-module (guix memoization) #:use-module (srfi srfi-1) #:use-module (srfi srfi-9) #:use-module (srfi srfi-19) @@ -229,22 +230,27 @@ build-log\" traces." (and (current-store-protocol-version) (>= (current-store-protocol-version) #x163))) +(define isatty?* + (mlambdaq (port) + (isatty? port))) + (define spin! (let ((steps (circular-list "\\" "|" "/" "-"))) (lambda (port) "Display a spinner on PORT." - (match steps - ((first . rest) - (set! steps rest) - (display "\r\x1b[K" port) - (display first port) - (force-output port)))))) + (when (isatty?* port) + (match steps + ((first . rest) + (set! steps rest) + (display "\r\x1b[K" port) + (display first port) + (force-output port))))))) (define (color-output? port) "Return true if we should write colored output to PORT." (and (not (getenv "INSIDE_EMACS")) (not (getenv "NO_COLOR")) - (isatty? port))) + (isatty?* port))) (define-syntax color-rules (syntax-rules () -- cgit v1.2.3 From 743497b5650713e082f4775a3b7dfd03babc8191 Mon Sep 17 00:00:00 2001 From: Ricardo Wurmus Date: Tue, 15 Jan 2019 13:03:48 +0100 Subject: guix: Add profile hook to build TeX live configuration. * guix/profiles.scm (texlive-configuration): New procedure. (%default-profile-hooks): Add it. * guix/status.scm (hook-message): Handle "texlive-configuration" hook type. --- guix/profiles.scm | 47 ++++++++++++++++++++++++++++++++++++++++++++++- guix/status.scm | 4 +++- 2 files changed, 49 insertions(+), 2 deletions(-) (limited to 'guix') diff --git a/guix/profiles.scm b/guix/profiles.scm index 8142e5e8e2..d22539bdb2 100644 --- a/guix/profiles.scm +++ b/guix/profiles.scm @@ -4,7 +4,7 @@ ;;; Copyright © 2014, 2016 Alex Kost ;;; Copyright © 2015 Mark H Weaver ;;; Copyright © 2015 Sou Bunnbu -;;; Copyright © 2016, 2018 Ricardo Wurmus +;;; Copyright © 2016, 2018, 2019 Ricardo Wurmus ;;; Copyright © 2016 Chris Marusich ;;; Copyright © 2017 Huang Ying ;;; Copyright © 2017 Maxim Cournoyer @@ -1338,6 +1338,50 @@ the entries in MANIFEST." `((type . profile-hook) (hook . manual-database)))) +(define (texlive-configuration manifest) + "Return a derivation that builds a TeXlive configuration for the entries in +MANIFEST." + (define entry->texlive-input + (match-lambda + (($ name version output thing deps) + (if (string-prefix? "texlive-" name) + (cons (gexp-input thing output) + (append-map entry->texlive-input deps)) + '())))) + (define build + (with-imported-modules '((guix build utils) + (guix build union)) + #~(begin + (use-modules (guix build utils) + (guix build union)) + + ;; Build a modifiable union of all texlive inputs. We do this so + ;; that TeX live can resolve the parent and grandparent directories + ;; correctly. There might be a more elegant way to accomplish this. + (union-build #$output + '#$(append-map entry->texlive-input + (manifest-entries manifest)) + #:create-all-directories? #t + #:log-port (%make-void-port "w")) + (substitute* (string-append #$output + "/share/texmf-dist/web2c/texmf.cnf") + (("^TEXMFROOT = .*") + (string-append "TEXMFROOT = " #$output "/share\n")) + (("^TEXMF = .*") + "TEXMF = $TEXMFROOT/share/texmf-dist\n")) + #t))) + + (with-monad %store-monad + (if (any (cut string-prefix? "texlive-" <>) + (map manifest-entry-name (manifest-entries manifest))) + (gexp->derivation "texlive-configuration" build + #:substitutable? #f + #:local-build? #t + #:properties + `((type . profile-hook) + (hook . texlive-configuration))) + (return #f)))) + (define %default-profile-hooks ;; This is the list of derivation-returning procedures that are called by ;; default when making a non-empty profile. @@ -1349,6 +1393,7 @@ the entries in MANIFEST." glib-schemas gtk-icon-themes gtk-im-modules + texlive-configuration xdg-desktop-database xdg-mime-database)) diff --git a/guix/status.scm b/guix/status.scm index 478c475f8c..67bb9e338e 100644 --- a/guix/status.scm +++ b/guix/status.scm @@ -1,6 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2017, 2018, 2019 Ludovic Courtès -;;; Copyright © 2018 Ricardo Wurmus +;;; Copyright © 2018, 2019 Ricardo Wurmus ;;; ;;; This file is part of GNU Guix. ;;; @@ -318,6 +318,8 @@ on." (G_ "building XDG MIME database...")) ('fonts-dir (G_ "building fonts directory...")) + ('texlive-configuration + (G_ "building TeX Live configuration...")) ('manual-database (G_ "building database for manual pages...")) (_ #f))) -- cgit v1.2.3 From b96909c5c186a40907e47f84179072949abe41e9 Mon Sep 17 00:00:00 2001 From: Ricardo Wurmus Date: Tue, 15 Jan 2019 18:15:07 +0100 Subject: guix: scons: Fix module reference. * guix/build-system/scons.scm (default-scons): Find "scons" package in (gnu packages python-xyz) instead of (gnu packages python). --- guix/build-system/scons.scm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/build-system/scons.scm b/guix/build-system/scons.scm index da09cc7ded..5e76d64180 100644 --- a/guix/build-system/scons.scm +++ b/guix/build-system/scons.scm @@ -43,7 +43,7 @@ (define (default-scons) "Return the default SCons package." ;; Lazily resolve the binding to avoid a circular dependency. - (let ((python (resolve-interface '(gnu packages python)))) + (let ((python (resolve-interface '(gnu packages python-xyz)))) (module-ref python 'scons))) (define* (lower name -- cgit v1.2.3 From 461d6c2effb8520ecb088854efd517e2efd28d30 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 11 Jan 2019 14:56:40 +0100 Subject: profiling: Add a "gc" profiling component. * guix/profiling.scm (show-gc-stats): New procedure. : Call 'register-profiling-hook!'. --- guix/profiling.scm | 25 ++++++++++++++++++++++++- 1 file changed, 24 insertions(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/profiling.scm b/guix/profiling.scm index 753fc6c22e..e1c205a543 100644 --- a/guix/profiling.scm +++ b/guix/profiling.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. ;;; @@ -18,6 +18,7 @@ (define-module (guix profiling) #:use-module (ice-9 match) + #:autoload (ice-9 format) (format) #:export (profiled? register-profiling-hook!)) @@ -50,3 +51,25 @@ (for-each (lambda (hook) (add-hook! hook thunk)) %profiling-hooks))) + +(define (show-gc-stats) + "Display garbage collection statistics." + (define MiB (* 1024 1024.)) + (define stats (gc-stats)) + + (format (current-error-port) "Garbage collection statistics: + heap size: ~,2f MiB + allocated: ~,2f MiB + GC times: ~a + time spent in GC: ~,2f seconds (~d% of user time)~%" + (/ (assq-ref stats 'heap-size) MiB) + (/ (assq-ref stats 'heap-total-allocated) MiB) + (assq-ref stats 'gc-times) + (/ (assq-ref stats 'gc-time-taken) + internal-time-units-per-second 1.) + (inexact->exact + (round (* (/ (assq-ref stats 'gc-time-taken) + (tms:utime (times)) 1.) + 100))))) + +(register-profiling-hook! "gc" show-gc-stats) -- cgit v1.2.3 From 465a0d65ae371cd6ae85a5f4f356c8989a863e9f Mon Sep 17 00:00:00 2001 From: Ludovic Courtès 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') 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 @@ of relevance scores." ('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 @@ (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 @@ (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 @@ (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 ae927822409b220e0e9a006df5912c617973c736 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sat, 12 Jan 2019 18:19:13 +0100 Subject: inferior: Add 'gexp->derivation-in-inferior'. * guix/inferior.scm (gexp->derivation-in-inferior): New procedure. --- guix/inferior.scm | 26 ++++++++++++++++++++++++++ 1 file changed, 26 insertions(+) (limited to 'guix') diff --git a/guix/inferior.scm b/guix/inferior.scm index ba8d00866b..4dfb242e44 100644 --- a/guix/inferior.scm +++ b/guix/inferior.scm @@ -81,6 +81,8 @@ inferior-package->manifest-entry + gexp->derivation-in-inferior + %inferior-cache-directory inferior-for-channels)) @@ -484,6 +486,30 @@ PACKAGE must be live." ;; Compile PACKAGE for SYSTEM, optionally cross-building for TARGET. (inferior-package->derivation package system #:target target)) +(define* (gexp->derivation-in-inferior name exp guix + #:rest rest) + "Return a derivation that evaluates EXP with GUIX, an instance of Guix as +returned for example by 'channel-instances->derivation'. Other arguments are +passed as-is to 'gexp->derivation'." + (define trampoline + ;; This is a crude way to run EXP on GUIX. TODO: use 'raw-derivation' and + ;; make 'guix repl' the "builder"; this will require "opening up" the + ;; mechanisms behind 'gexp->derivation', and adding '-l' to 'guix repl'. + #~(begin + (use-modules (ice-9 popen)) + + (let ((pipe (open-pipe* OPEN_WRITE + #+(file-append guix "/bin/guix") + "repl" "-t" "machine"))) + ;; Unquote EXP right here so that its references to #$output + ;; propagate to the surrounding gexp. + (write '#$exp pipe) ;XXX: load path for EXP? + + (unless (zero? (close-pipe pipe)) + (error "inferior failed" #+guix))))) + + (apply gexp->derivation name trampoline rest)) + ;;; ;;; Manifest entries. -- cgit v1.2.3 From 1d90e9d7c906b1e9e94d1642bfd60c51609fd0df Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sat, 12 Jan 2019 22:26:01 +0100 Subject: discovery: Add 'fold-module-public-variables*'. * guix/discovery.scm (fold-module-public-variables*): New procedure. --- guix/discovery.scm | 28 ++++++++++++++++++++++++++-- 1 file changed, 26 insertions(+), 2 deletions(-) (limited to 'guix') diff --git a/guix/discovery.scm b/guix/discovery.scm index 3fc6e2c9e7..ef5ae73973 100644 --- a/guix/discovery.scm +++ b/guix/discovery.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. ;;; @@ -30,7 +30,8 @@ scheme-modules* fold-modules all-modules - fold-module-public-variables)) + fold-module-public-variables + fold-module-public-variables*)) ;;; Commentary: ;;; @@ -147,10 +148,33 @@ search. Entries in PATH can be directory names (strings) or (DIRECTORY SUB-DIRECTORY." (fold-modules cons '() path #:warn warn)) +(define (fold-module-public-variables* proc init modules) + "Call (PROC MODULE SYMBOL VARIABLE) for each variable exported by one of MODULES, +using INIT as the initial value of RESULT. It is guaranteed to never traverse +the same object twice." + ;; Here SEEN is populated by variables; if two different variables refer to + ;; the same object, we still let them through. + (identity ;discard second return value + (fold2 (lambda (module result seen) + (fold2 (lambda (sym+var result seen) + (match sym+var + ((sym . var) + (if (not (vhash-assq var seen)) + (values (proc module sym var result) + (vhash-consq var #t seen)) + (values result seen))))) + result + seen + (module-map cons module))) + init + vlist-null + modules))) + (define (fold-module-public-variables proc init modules) "Call (PROC OBJECT RESULT) for each variable exported by one of MODULES, using INIT as the initial value of RESULT. It is guaranteed to never traverse the same object twice." + ;; Note: here SEEN is populated by objects, not by variables. (identity ; discard second return value (fold2 (lambda (module result seen) (fold2 (lambda (var result seen) -- 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') 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 @@ #: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 @@ specification->package specification->package+output - specifications->manifest)) + specifications->manifest + + generate-package-cache)) ;;; Commentary: ;;; @@ -135,6 +140,14 @@ for system '~a'") ;; 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 @@ is guaranteed to never traverse the same package twice." 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 @@ decreasing version order." 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 @@ #: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 @@ #: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 @@ checkout->channel-instance latest-channel-derivation channel-instances->manifest + %channel-profile-hooks channel-instances->derivation)) ;;; Commentary: @@ -416,11 +419,40 @@ channel instances." (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 @@ denote ranges as interpreted by 'matching-generations'." (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 @@ true, display what would be built without actually building it." (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 @@ (((? (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') 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 @@ 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 @@ decreasing version order." 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 @@ present, return the preferred newest version." (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 @@ #: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 @@ Start $VISUAL or $EDITOR to edit the definitions of PACKAGE...\n")) 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 @@ line." '())) (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 @@ (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') 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 @@ %default-package-module-path fold-packages + fold-available-packages find-packages-by-name find-package-locations @@ -182,6 +183,50 @@ flags." 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 @@ processed, #f otherwise." (('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 b9da4b931d6bfe097420a4727ddb432565c3337a Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sun, 13 Jan 2019 16:11:11 +0100 Subject: status: Distinguish 'package-cache' profile hook. * guix/status.scm (hook-message): Handle 'package-cache'. --- guix/status.scm | 2 ++ 1 file changed, 2 insertions(+) (limited to 'guix') diff --git a/guix/status.scm b/guix/status.scm index 67bb9e338e..93e119bed1 100644 --- a/guix/status.scm +++ b/guix/status.scm @@ -322,6 +322,8 @@ on." (G_ "building TeX Live configuration...")) ('manual-database (G_ "building database for manual pages...")) + ('package-cache ;package cache generated by 'guix pull' + (G_ "building package cache...")) (_ #f))) (define* (print-build-event event old-status status -- cgit v1.2.3 From 9a5091d0c181453d0f31ce97f96a4e577a25e796 Mon Sep 17 00:00:00 2001 From: Arun Isaac Date: Wed, 16 Jan 2019 15:21:06 +0530 Subject: import: github: Do not update URI for packages using git-fetch. * guix/import/github.scm (updated-github-url): Return the unchanged source URI for packages using git-fetch. [updated-url]: Do not handle URIs which end with ".git". --- guix/import/github.scm | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) (limited to 'guix') diff --git a/guix/import/github.scm b/guix/import/github.scm index ad662e7b02..b287313d98 100644 --- a/guix/import/github.scm +++ b/guix/import/github.scm @@ -2,6 +2,7 @@ ;;; Copyright © 2016 Ben Woodcroft ;;; Copyright © 2017, 2018 Ludovic Courtès ;;; Copyright © 2018 Eric Bavier +;;; Copyright © 2019 Arun Isaac ;;; ;;; This file is part of GNU Guix. ;;; @@ -54,7 +55,6 @@ false if none is recognized" (github-user-slash-repository url))) (repo (github-repository url))) (cond - ((string-suffix? ".git" url) url) ((string-suffix? (string-append "/tarball/v" version) url) (string-append prefix "/tarball/v" new-version)) ((string-suffix? (string-append "/tarball/" version) url) @@ -99,7 +99,7 @@ false if none is recognized" ((source-uri ...) (find updated-url source-uri)))) ((eq? fetch-method download:git-fetch) - (updated-url (download:git-reference-url source-uri))) + (download:git-reference-url source-uri)) (else #f)))) (define (github-package? package) -- cgit v1.2.3 From 16006a05a1019c4d898ec22333bb2ba3d0784e96 Mon Sep 17 00:00:00 2001 From: Mathieu Othacehe Date: Fri, 23 Nov 2018 11:22:35 +0900 Subject: guix: self: Do not install (gnu system install). As we do not want to add a dependency to newt and the graphical installer in (guix self), do not install (gnu system install). * guix/self.scm (*system-modules*): Remove (gnu system install) from "guix-system" scheme-node. --- guix/self.scm | 7 +++++-- 1 file changed, 5 insertions(+), 2 deletions(-) (limited to 'guix') diff --git a/guix/self.scm b/guix/self.scm index cf6110613c..2698596387 100644 --- a/guix/self.scm +++ b/guix/self.scm @@ -604,7 +604,11 @@ Info manual." (scheme-node "guix-system" `((gnu system) (gnu services) - ,@(scheme-modules* source "gnu/system") + ,@(filter-map + (match-lambda + (('gnu 'system 'install) #f) + (name name)) + (scheme-modules* source "gnu/system")) ,@(scheme-modules* source "gnu/services")) (list *core-package-modules* *package-modules* *extra-modules* *core-modules*) @@ -806,7 +810,6 @@ Info manual." ;; made relative to a nonexistent anonymous module. #:splice? #t)) - ;;; ;;; Building. -- cgit v1.2.3 From a49d633c0c65975263270f5ac0050482ca6a5513 Mon Sep 17 00:00:00 2001 From: Mathieu Othacehe Date: Sat, 24 Nov 2018 12:25:03 +0900 Subject: installer: Move everything to the build side. * gnu/installer.scm: Rename to ... * gnu/installer/record.scm: ... this. * gnu/installer/build-installer.scm: Move everything to the build side and rename to gnu/installer.scm. * gnu/installer/newt.scm: Remove all the gexps and add depencies to newt modules as this code will only be used on the build side by now. * gnu/local.mk (GNU_SYSTEM_MODULES): Adapt it, (dist_installer_DATA): New rule to install installer's aux-files. * gnu/system/install.scm (%installation-services): Use only 'installer-program' from (gnu installer). The installer is now choosen on the build side. * guix/self.scm (*system-modules*): Restore previous behaviour and add all installer files to #:extra-files field of the scheme-node. * po/guix/POTFILES.in: Adapt it. --- gnu/installer.scm | 363 +++++++++++++++++++++++++++++--------- gnu/installer/build-installer.scm | 322 --------------------------------- gnu/installer/newt.scm | 94 +++++----- gnu/installer/record.scm | 75 ++++++++ gnu/local.mk | 7 +- gnu/system/install.scm | 6 +- guix/self.scm | 10 +- po/guix/POTFILES.in | 2 +- 8 files changed, 409 insertions(+), 470 deletions(-) delete mode 100644 gnu/installer/build-installer.scm create mode 100644 gnu/installer/record.scm (limited to 'guix') diff --git a/gnu/installer.scm b/gnu/installer.scm index f3323ea3bc..9e773ee8f0 100644 --- a/gnu/installer.scm +++ b/gnu/installer.scm @@ -17,95 +17,282 @@ ;;; along with GNU Guix. If not, see . (define-module (gnu installer) - #:use-module (guix discovery) - #:use-module (guix records) + #:use-module (guix packages) + #:use-module (guix gexp) + #:use-module (guix modules) + #:use-module (guix utils) #:use-module (guix ui) + #:use-module ((guix self) #:select (make-config.scm)) + #:use-module (gnu packages admin) + #:use-module (gnu packages base) + #:use-module (gnu packages bash) + #:use-module (gnu packages connman) + #:use-module (gnu packages guile) + #:autoload (gnu packages gnupg) (guile-gcrypt) + #:use-module (gnu packages iso-codes) + #:use-module (gnu packages linux) + #:use-module (gnu packages ncurses) + #:use-module (gnu packages package-management) + #:use-module (gnu packages xorg) + #:use-module (ice-9 match) #:use-module (srfi srfi-1) - #:export ( - installer - make-installer - installer? - installer-name - installer-modules - installer-init - installer-exit - installer-exit-error - installer-keymap-page - installer-locale-page - installer-menu-page - installer-network-page - installer-timezone-page - installer-hostname-page - installer-user-page - installer-welcome-page - - %installers - lookup-installer-by-name)) - - -;;; -;;; Installer record. -;;; + #:export (installer-program)) -;; The record contains pages that will be run to prompt the user -;; for the system configuration. The goal of the installer is to produce a -;; complete record and install it. - -(define-record-type* - installer make-installer - installer? - ;; symbol - (name installer-name) - ;; list of installer modules - (modules installer-modules) - ;; procedure: void -> void - (init installer-init) - ;; procedure: void -> void - (exit installer-exit) - ;; procedure (key arguments) -> void - (exit-error installer-exit-error) - ;; procedure (#:key models layouts) -> (list model layout variant) - (keymap-page installer-keymap-page) - ;; procedure: (#:key supported-locales iso639-languages iso3166-territories) - ;; -> glibc-locale - (locale-page installer-locale-page) - ;; procedure: (steps) -> step-id - (menu-page installer-menu-page) - ;; procedure void -> void - (network-page installer-network-page) - ;; procedure (zonetab) -> posix-timezone - (timezone-page installer-timezone-page) - ;; procedure void -> void - (hostname-page installer-hostname-page) - ;; procedure void -> void - (user-page installer-user-page) - ;; procedure (logo) -> void - (welcome-page installer-welcome-page)) - - -;;; -;;; Installers. -;;; +(define not-config? + ;; Select (guix …) and (gnu …) modules, except (guix config). + (match-lambda + (('guix 'config) #f) + (('guix rest ...) #t) + (('gnu rest ...) #t) + (rest #f))) + +(define* (build-compiled-file name locale-builder) + "Return a file-like object that evalutes the gexp LOCALE-BUILDER and store +its result in the scheme file NAME. The derivation will also build a compiled +version of this file." + (define set-utf8-locale + #~(begin + (setenv "LOCPATH" + #$(file-append glibc-utf8-locales "/lib/locale/" + (version-major+minor + (package-version glibc-utf8-locales)))) + (setlocale LC_ALL "en_US.utf8"))) + + (define builder + (with-extensions (list guile-json) + (with-imported-modules (source-module-closure + '((gnu installer locale))) + #~(begin + (use-modules (gnu installer locale)) + + ;; The locale files contain non-ASCII characters. + #$set-utf8-locale + + (mkdir #$output) + (let ((locale-file + (string-append #$output "/" #$name ".scm")) + (locale-compiled-file + (string-append #$output "/" #$name ".go"))) + (call-with-output-file locale-file + (lambda (port) + (write #$locale-builder port))) + (compile-file locale-file + #:output-file locale-compiled-file)))))) + (computed-file name builder)) + +(define apply-locale + ;; Install the specified locale. + #~(lambda (locale-name) + (false-if-exception + (setlocale LC_ALL locale-name)))) + +(define* (compute-locale-step #:key + locales-name + iso639-languages-name + iso3166-territories-name) + "Return a gexp that run the locale-page of INSTALLER, and install the +selected locale. The list of locales, languages and territories passed to +locale-page are computed in derivations named respectively LOCALES-NAME, +ISO639-LANGUAGES-NAME and ISO3166-TERRITORIES-NAME. Those lists are compiled, +so that when the installer is run, all the lengthy operations have already +been performed at build time." + (define (compiled-file-loader file name) + #~(load-compiled + (string-append #$file "/" #$name ".go"))) + + (let* ((supported-locales #~(supported-locales->locales + #$(local-file "installer/aux-files/SUPPORTED"))) + (iso-codes #~(string-append #$iso-codes "/share/iso-codes/json/")) + (iso639-3 #~(string-append #$iso-codes "iso_639-3.json")) + (iso639-5 #~(string-append #$iso-codes "iso_639-5.json")) + (iso3166 #~(string-append #$iso-codes "iso_3166-1.json")) + (locales-file (build-compiled-file + locales-name + #~`(quote ,#$supported-locales))) + (iso639-file (build-compiled-file + iso639-languages-name + #~`(quote ,(iso639->iso639-languages + #$supported-locales + #$iso639-3 #$iso639-5)))) + (iso3166-file (build-compiled-file + iso3166-territories-name + #~`(quote ,(iso3166->iso3166-territories #$iso3166)))) + (locales-loader (compiled-file-loader locales-file + locales-name)) + (iso639-loader (compiled-file-loader iso639-file + iso639-languages-name)) + (iso3166-loader (compiled-file-loader iso3166-file + iso3166-territories-name))) + #~(lambda (current-installer) + (let ((result + ((installer-locale-page current-installer) + #:supported-locales #$locales-loader + #:iso639-languages #$iso639-loader + #:iso3166-territories #$iso3166-loader))) + (#$apply-locale result))))) + +(define apply-keymap + ;; Apply the specified keymap. + #~(match-lambda + ((model layout variant) + (kmscon-update-keymap model layout variant)))) + +(define* (compute-keymap-step) + "Return a gexp that runs the keymap-page of INSTALLER and install the +selected keymap." + #~(lambda (current-installer) + (let ((result + (call-with-values + (lambda () + (xkb-rules->models+layouts + (string-append #$xkeyboard-config + "/share/X11/xkb/rules/base.xml"))) + (lambda (models layouts) + ((installer-keymap-page current-installer) + #:models models + #:layouts layouts))))) + (#$apply-keymap result)))) + +(define (installer-steps) + (let ((locale-step (compute-locale-step + #:locales-name "locales" + #:iso639-languages-name "iso639-languages" + #:iso3166-territories-name "iso3166-territories")) + (keymap-step (compute-keymap-step)) + (timezone-data #~(string-append #$tzdata + "/share/zoneinfo/zone.tab"))) + #~(lambda (current-installer) + (list + ;; Welcome the user and ask him to choose between manual installation + ;; and graphical install. + (installer-step + (id 'welcome) + (compute (lambda _ + ((installer-welcome-page current-installer) + #$(local-file "installer/aux-files/logo.txt"))))) + + ;; Ask the user to choose a locale among those supported by the glibc. + ;; Install the selected locale right away, so that the user may + ;; benefit from any available translation for the installer messages. + (installer-step + (id 'locale) + (description (G_ "Locale selection")) + (compute (lambda _ + (#$locale-step current-installer)))) + + ;; Ask the user to select a timezone under glibc format. + (installer-step + (id 'timezone) + (description (G_ "Timezone selection")) + (compute (lambda _ + ((installer-timezone-page current-installer) + #$timezone-data)))) + + ;; The installer runs in a kmscon virtual terminal where loadkeys + ;; won't work. kmscon uses libxkbcommon as a backend for keyboard + ;; input. It is possible to update kmscon current keymap by sending it + ;; a keyboard model, layout and variant, in a somehow similar way as + ;; what is done with setxkbmap utility. + ;; + ;; So ask for a keyboard model, layout and variant to update the + ;; current kmscon keymap. + (installer-step + (id 'keymap) + (description (G_ "Keyboard mapping selection")) + (compute (lambda _ + (#$keymap-step current-installer)))) + + ;; Ask the user to input a hostname for the system. + (installer-step + (id 'hostname) + (description (G_ "Hostname selection")) + (compute (lambda _ + ((installer-hostname-page current-installer))))) + + ;; Provide an interface above connmanctl, so that the user can select + ;; a network susceptible to acces Internet. + (installer-step + (id 'network) + (description (G_ "Network selection")) + (compute (lambda _ + ((installer-network-page current-installer))))) + + ;; Prompt for users (name, group and home directory). + (installer-step + (id 'hostname) + (description (G_ "User selection")) + (compute (lambda _ + ((installer-user-page current-installer))))))))) + +(define (installer-program) + "Return a file-like object that runs the given INSTALLER." + (define init-gettext + ;; Initialize gettext support, so that installer messages can be + ;; translated. + #~(begin + (bindtextdomain "guix" (string-append #$guix "/share/locale")) + (textdomain "guix"))) + + (define set-installer-path + ;; Add the specified binary to PATH for later use by the installer. + #~(let* ((inputs + '#$(append (list bash connman shadow) + (map canonical-package (list coreutils))))) + (with-output-to-port (%make-void-port "w") + (lambda () + (set-path-environment-variable "PATH" '("bin" "sbin") inputs))))) + + (define steps (installer-steps)) + + (define installer-builder + (with-extensions (list guile-gcrypt guile-newt guile-json) + (with-imported-modules `(,@(source-module-closure + '((gnu installer newt) + (guix build utils)) + #:select? not-config?) + ((guix config) => ,(make-config.scm))) + #~(begin + (use-modules (gnu installer record) + (gnu installer keymap) + (gnu installer steps) + (gnu installer locale) + (gnu installer newt) + (guix i18n) + (guix build utils) + (ice-9 match)) + + ;; Set the default locale to install unicode support. + (setlocale LC_ALL "en_US.utf8") + + ;; Initialize gettext support so that installers can use + ;; (guix i18n) module. + #$init-gettext + + ;; Add some binaries used by the installers to PATH. + #$set-installer-path + + (let ((current-installer newt-installer)) + ((installer-init current-installer)) + + (catch #t + (lambda () + (run-installer-steps + #:rewind-strategy 'menu + #:menu-proc (installer-menu-page current-installer) + #:steps (#$steps current-installer))) + (const #f) + (lambda (key . args) + ((installer-exit-error current-installer) key args) + + ;; Be sure to call newt-finish, to restore the terminal into + ;; its original state before printing the error report. + (call-with-output-file "/tmp/error" + (lambda (port) + (display-backtrace (make-stack #t) port) + (print-exception port + (stack-ref (make-stack #t) 1) + key args))) + (primitive-exit 1)))) + ((installer-exit current-installer)))))) -(define (installer-top-modules) - "Return the list of installer modules." - (all-modules (map (lambda (entry) - `(,entry . "gnu/installer")) - %load-path) - #:warn warn-about-load-error)) - -(define %installers - ;; The list of publically-known installers. - (delay (fold-module-public-variables (lambda (obj result) - (if (installer? obj) - (cons obj result) - result)) - '() - (installer-top-modules)))) - -(define (lookup-installer-by-name name) - "Return the installer called NAME." - (or (find (lambda (installer) - (eq? name (installer-name installer))) - (force %installers)) - (leave (G_ "~a: no such installer~%") name))) + (program-file "installer" installer-builder)) diff --git a/gnu/installer/build-installer.scm b/gnu/installer/build-installer.scm deleted file mode 100644 index c7f439b35f..0000000000 --- a/gnu/installer/build-installer.scm +++ /dev/null @@ -1,322 +0,0 @@ -;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2018 Mathieu Othacehe -;;; -;;; This file is part of GNU Guix. -;;; -;;; GNU Guix is free software; you can redistribute it and/or modify it -;;; under the terms of the GNU General Public License as published by -;;; the Free Software Foundation; either version 3 of the License, or (at -;;; your option) any later version. -;;; -;;; GNU Guix is distributed in the hope that it will be useful, but -;;; WITHOUT ANY WARRANTY; without even the implied warranty of -;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;;; GNU General Public License for more details. -;;; -;;; You should have received a copy of the GNU General Public License -;;; along with GNU Guix. If not, see . - -(define-module (gnu installer build-installer) - #:use-module (guix packages) - #:use-module (guix gexp) - #:use-module (guix modules) - #:use-module (guix utils) - #:use-module (guix ui) - #:use-module ((guix self) #:select (make-config.scm)) - #:use-module (gnu installer) - #:use-module (gnu packages admin) - #:use-module (gnu packages base) - #:use-module (gnu packages bash) - #:use-module (gnu packages connman) - #:use-module (gnu packages guile) - #:autoload (gnu packages gnupg) (guile-gcrypt) - #:use-module (gnu packages iso-codes) - #:use-module (gnu packages linux) - #:use-module (gnu packages ncurses) - #:use-module (gnu packages package-management) - #:use-module (gnu packages xorg) - #:use-module (ice-9 match) - #:use-module (srfi srfi-1) - #:export (installer-program - installer-program-launcher)) - -(define not-config? - ;; Select (guix …) and (gnu …) modules, except (guix config). - (match-lambda - (('guix 'config) #f) - (('guix rest ...) #t) - (('gnu rest ...) #t) - (rest #f))) - -(define* (build-compiled-file name locale-builder) - "Return a file-like object that evalutes the gexp LOCALE-BUILDER and store -its result in the scheme file NAME. The derivation will also build a compiled -version of this file." - (define set-utf8-locale - #~(begin - (setenv "LOCPATH" - #$(file-append glibc-utf8-locales "/lib/locale/" - (version-major+minor - (package-version glibc-utf8-locales)))) - (setlocale LC_ALL "en_US.utf8"))) - - (define builder - (with-extensions (list guile-json) - (with-imported-modules (source-module-closure - '((gnu installer locale))) - #~(begin - (use-modules (gnu installer locale)) - - ;; The locale files contain non-ASCII characters. - #$set-utf8-locale - - (mkdir #$output) - (let ((locale-file - (string-append #$output "/" #$name ".scm")) - (locale-compiled-file - (string-append #$output "/" #$name ".go"))) - (call-with-output-file locale-file - (lambda (port) - (write #$locale-builder port))) - (compile-file locale-file - #:output-file locale-compiled-file)))))) - (computed-file name builder)) - -(define apply-locale - ;; Install the specified locale. - #~(lambda (locale-name) - (false-if-exception - (setlocale LC_ALL locale-name)))) - -(define* (compute-locale-step installer - #:key - locales-name - iso639-languages-name - iso3166-territories-name) - "Return a gexp that run the locale-page of INSTALLER, and install the -selected locale. The list of locales, languages and territories passed to -locale-page are computed in derivations named respectively LOCALES-NAME, -ISO639-LANGUAGES-NAME and ISO3166-TERRITORIES-NAME. Those lists are compiled, -so that when the installer is run, all the lengthy operations have already -been performed at build time." - (define (compiled-file-loader file name) - #~(load-compiled - (string-append #$file "/" #$name ".go"))) - - (let* ((supported-locales #~(supported-locales->locales - #$(local-file "aux-files/SUPPORTED"))) - (iso-codes #~(string-append #$iso-codes "/share/iso-codes/json/")) - (iso639-3 #~(string-append #$iso-codes "iso_639-3.json")) - (iso639-5 #~(string-append #$iso-codes "iso_639-5.json")) - (iso3166 #~(string-append #$iso-codes "iso_3166-1.json")) - (locales-file (build-compiled-file - locales-name - #~`(quote ,#$supported-locales))) - (iso639-file (build-compiled-file - iso639-languages-name - #~`(quote ,(iso639->iso639-languages - #$supported-locales - #$iso639-3 #$iso639-5)))) - (iso3166-file (build-compiled-file - iso3166-territories-name - #~`(quote ,(iso3166->iso3166-territories #$iso3166)))) - (locales-loader (compiled-file-loader locales-file - locales-name)) - (iso639-loader (compiled-file-loader iso639-file - iso639-languages-name)) - (iso3166-loader (compiled-file-loader iso3166-file - iso3166-territories-name))) - #~(let ((result - (#$(installer-locale-page installer) - #:supported-locales #$locales-loader - #:iso639-languages #$iso639-loader - #:iso3166-territories #$iso3166-loader))) - (#$apply-locale result)))) - -(define apply-keymap - ;; Apply the specified keymap. - #~(match-lambda - ((model layout variant) - (kmscon-update-keymap model layout variant)))) - -(define* (compute-keymap-step installer) - "Return a gexp that runs the keymap-page of INSTALLER and install the -selected keymap." - #~(let ((result - (call-with-values - (lambda () - (xkb-rules->models+layouts - (string-append #$xkeyboard-config - "/share/X11/xkb/rules/base.xml"))) - (lambda (models layouts) - (#$(installer-keymap-page installer) - #:models models - #:layouts layouts))))) - (#$apply-keymap result))) - -(define (installer-steps installer) - (let ((locale-step (compute-locale-step - installer - #:locales-name "locales" - #:iso639-languages-name "iso639-languages" - #:iso3166-territories-name "iso3166-territories")) - (keymap-step (compute-keymap-step installer)) - (timezone-data #~(string-append #$tzdata - "/share/zoneinfo/zone.tab"))) - #~(list - ;; Welcome the user and ask him to choose between manual installation - ;; and graphical install. - (installer-step - (id 'welcome) - (compute (lambda _ - #$(installer-welcome-page installer)))) - - ;; Ask the user to choose a locale among those supported by the glibc. - ;; Install the selected locale right away, so that the user may - ;; benefit from any available translation for the installer messages. - (installer-step - (id 'locale) - (description (G_ "Locale selection")) - (compute (lambda _ - #$locale-step))) - - ;; Ask the user to select a timezone under glibc format. - (installer-step - (id 'timezone) - (description (G_ "Timezone selection")) - (compute (lambda _ - (#$(installer-timezone-page installer) - #$timezone-data)))) - - ;; The installer runs in a kmscon virtual terminal where loadkeys - ;; won't work. kmscon uses libxkbcommon as a backend for keyboard - ;; input. It is possible to update kmscon current keymap by sending it - ;; a keyboard model, layout and variant, in a somehow similar way as - ;; what is done with setxkbmap utility. - ;; - ;; So ask for a keyboard model, layout and variant to update the - ;; current kmscon keymap. - (installer-step - (id 'keymap) - (description (G_ "Keyboard mapping selection")) - (compute (lambda _ - #$keymap-step))) - - ;; Ask the user to input a hostname for the system. - (installer-step - (id 'hostname) - (description (G_ "Hostname selection")) - (compute (lambda _ - #$(installer-hostname-page installer)))) - - ;; Provide an interface above connmanctl, so that the user can select - ;; a network susceptible to acces Internet. - (installer-step - (id 'network) - (description (G_ "Network selection")) - (compute (lambda _ - #$(installer-network-page installer)))) - - ;; Prompt for users (name, group and home directory). - (installer-step - (id 'hostname) - (description (G_ "User selection")) - (compute (lambda _ - #$(installer-user-page installer))))))) - -(define (installer-program installer) - "Return a file-like object that runs the given INSTALLER." - (define init-gettext - ;; Initialize gettext support, so that installer messages can be - ;; translated. - #~(begin - (bindtextdomain "guix" (string-append #$guix "/share/locale")) - (textdomain "guix"))) - - (define set-installer-path - ;; Add the specified binary to PATH for later use by the installer. - #~(let* ((inputs - '#$(append (list bash connman shadow) - (map canonical-package (list coreutils))))) - (with-output-to-port (%make-void-port "w") - (lambda () - (set-path-environment-variable "PATH" '("bin" "sbin") inputs))))) - - (define installer-builder - (with-extensions (list guile-gcrypt guile-newt guile-json) - (with-imported-modules `(,@(source-module-closure - `(,@(installer-modules installer) - (guix build utils)) - #:select? not-config?) - ((guix config) => ,(make-config.scm))) - #~(begin - (use-modules (gnu installer keymap) - (gnu installer steps) - (gnu installer locale) - #$@(installer-modules installer) - (guix i18n) - (guix build utils) - (ice-9 match)) - - ;; Initialize gettext support so that installers can use - ;; (guix i18n) module. - #$init-gettext - - ;; Add some binaries used by the installers to PATH. - #$set-installer-path - - #$(installer-init installer) - - (catch #t - (lambda () - (run-installer-steps - #:rewind-strategy 'menu - #:menu-proc #$(installer-menu-page installer) - #:steps #$(installer-steps installer))) - (const #f) - (lambda (key . args) - (#$(installer-exit-error installer) key args) - - ;; Be sure to call newt-finish, to restore the terminal into - ;; its original state before printing the error report. - (call-with-output-file "/tmp/error" - (lambda (port) - (display-backtrace (make-stack #t) port) - (print-exception port - (stack-ref (make-stack #t) 1) - key args))) - (primitive-exit 1))) - #$(installer-exit installer))))) - - (program-file "installer" installer-builder)) - -;; We want the installer to honor the LANG environment variable, so that the -;; locale is correctly installed when the installer is launched, and the -;; welcome page is possibly translated. The /etc/environment file (containing -;; LANG) is supposed to be loaded using PAM by the login program. As the -;; installer replaces the login program, read this file and set all the -;; variables it contains before starting the installer. This is a dirty hack, -;; we might want to find a better way to do it in the future. -(define (installer-program-launcher installer) - "Return a file-like object that set the variables in /etc/environment and -run the given INSTALLER." - (define load-environment - #~(call-with-input-file "/etc/environment" - (lambda (port) - (let ((lines (read-lines port))) - (map (lambda (line) - (match (string-split line #\=) - ((name value) - (setenv name value)))) - lines))))) - - (define wrapper - (with-imported-modules '((gnu installer utils)) - #~(begin - (use-modules (gnu installer utils) - (ice-9 match)) - - #$load-environment - (system #$(installer-program installer))))) - - (program-file "installer-launcher" wrapper)) diff --git a/gnu/installer/newt.scm b/gnu/installer/newt.scm index 23b737ddf0..db57c732d1 100644 --- a/gnu/installer/newt.scm +++ b/gnu/installer/newt.scm @@ -17,71 +17,69 @@ ;;; along with GNU Guix. If not, see . (define-module (gnu installer newt) - #:use-module (gnu installer) + #:use-module (gnu installer record) + #:use-module (gnu installer newt ethernet) + #:use-module (gnu installer newt hostname) + #:use-module (gnu installer newt keymap) + #:use-module (gnu installer newt locale) + #:use-module (gnu installer newt menu) + #:use-module (gnu installer newt network) + #:use-module (gnu installer newt timezone) + #:use-module (gnu installer newt user) + #:use-module (gnu installer newt utils) + #:use-module (gnu installer newt welcome) + #:use-module (gnu installer newt wifi) #:use-module (guix discovery) - #:use-module (guix gexp) - #:use-module (guix ui) + #:use-module (guix i18n) + #:use-module (srfi srfi-26) + #:use-module (newt) #:export (newt-installer)) -(define (modules) - (cons '(newt) - (scheme-modules* - (dirname (search-path %load-path "guix.scm")) - "gnu/installer/newt"))) +(define (init) + (newt-init) + (clear-screen) + (set-screen-size!)) -(define init - #~(begin - (newt-init) - (clear-screen) - (set-screen-size!))) +(define (exit) + (newt-finish)) -(define exit - #~(begin - (newt-finish))) +(define (exit-error key . args) + (newt-finish)) -(define exit-error - #~(lambda (key args) - (newt-finish))) +(define* (locale-page #:key + supported-locales + iso639-languages + iso3166-territories) + (run-locale-page + #:supported-locales supported-locales + #:iso639-languages iso639-languages + #:iso3166-territories iso3166-territories)) -(define locale-page - #~(lambda* (#:key - supported-locales - iso639-languages - iso3166-territories) - (run-locale-page - #:supported-locales supported-locales - #:iso639-languages iso639-languages - #:iso3166-territories iso3166-territories))) +(define (timezone-page zonetab) + (run-timezone-page zonetab)) -(define timezone-page - #~(lambda* (zonetab) - (run-timezone-page zonetab))) +(define (welcome-page logo) + (run-welcome-page logo)) -(define welcome-page - #~(run-welcome-page #$(local-file "aux-files/logo.txt"))) +(define (menu-page steps) + (run-menu-page steps)) -(define menu-page - #~(lambda (steps) - (run-menu-page steps))) +(define* (keymap-page #:key models layouts) + (run-keymap-page #:models models + #:layouts layouts)) -(define keymap-page - #~(lambda* (#:key models layouts) - (run-keymap-page #:models models - #:layouts layouts))) +(define (network-page) + (run-network-page)) -(define network-page - #~(run-network-page)) +(define (hostname-page) + (run-hostname-page)) -(define hostname-page - #~(run-hostname-page)) - -(define user-page - #~(run-user-page)) +(define (user-page) + (run-user-page)) (define newt-installer (installer (name 'newt) - (modules (modules)) (init init) (exit exit) (exit-error exit-error) diff --git a/gnu/installer/record.scm b/gnu/installer/record.scm new file mode 100644 index 0000000000..9c10c65758 --- /dev/null +++ b/gnu/installer/record.scm @@ -0,0 +1,75 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2018 Mathieu Othacehe +;;; +;;; This file is part of GNU Guix. +;;; +;;; GNU Guix is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; GNU Guix is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with GNU Guix. If not, see . + +(define-module (gnu installer record) + #:use-module (guix records) + #:use-module (srfi srfi-1) + #:export ( + installer + make-installer + installer? + installer-name + installer-init + installer-exit + installer-exit-error + installer-keymap-page + installer-locale-page + installer-menu-page + installer-network-page + installer-timezone-page + installer-hostname-page + installer-user-page + installer-welcome-page)) + + +;;; +;;; Installer record. +;;; + +;; The record contains pages that will be run to prompt the user +;; for the system configuration. The goal of the installer is to produce a +;; complete record and install it. + +(define-record-type* + installer make-installer + installer? + ;; symbol + (name installer-name) + ;; procedure: void -> void + (init installer-init) + ;; procedure: void -> void + (exit installer-exit) + ;; procedure (key arguments) -> void + (exit-error installer-exit-error) + ;; procedure (#:key models layouts) -> (list model layout variant) + (keymap-page installer-keymap-page) + ;; procedure: (#:key supported-locales iso639-languages iso3166-territories) + ;; -> glibc-locale + (locale-page installer-locale-page) + ;; procedure: (steps) -> step-id + (menu-page installer-menu-page) + ;; procedure void -> void + (network-page installer-network-page) + ;; procedure (zonetab) -> posix-timezone + (timezone-page installer-timezone-page) + ;; procedure void -> void + (hostname-page installer-hostname-page) + ;; procedure void -> void + (user-page installer-user-page) + ;; procedure (logo) -> void + (welcome-page installer-welcome-page)) diff --git a/gnu/local.mk b/gnu/local.mk index 665721bec1..b0ec16de34 100644 --- a/gnu/local.mk +++ b/gnu/local.mk @@ -567,7 +567,7 @@ if ENABLE_INSTALLER GNU_SYSTEM_MODULES += \ %D%/installer.scm \ - %D%/installer/build-installer.scm \ + %D%/installer/record.scm \ %D%/installer/connman.scm \ %D%/installer/keymap.scm \ %D%/installer/locale.scm \ @@ -588,6 +588,11 @@ GNU_SYSTEM_MODULES += \ %D%/installer/newt/welcome.scm \ %D%/installer/newt/wifi.scm +installerdir = $(guilemoduledir)/%D%/installer +dist_installer_DATA = \ + %D%/installer/aux-files/logo.txt \ + %D%/installer/aux-files/SUPPORTED + endif ENABLE_INSTALLER # Modules that do not need to be compiled. diff --git a/gnu/system/install.scm b/gnu/system/install.scm index aef083506c..880a8be32d 100644 --- a/gnu/system/install.scm +++ b/gnu/system/install.scm @@ -28,8 +28,7 @@ #:use-module (guix store) #:use-module (guix monads) #:use-module ((guix store) #:select (%store-prefix)) - #:use-module (gnu installer newt) - #:use-module (gnu installer build-installer) + #:use-module (gnu installer) #:use-module (gnu services dbus) #:use-module (gnu services networking) #:use-module (gnu services shepherd) @@ -233,8 +232,7 @@ You have been warned. Thanks for being so brave.\x1b[0m (service kmscon-service-type (kmscon-configuration (virtual-terminal "tty1") - (login-program (installer-program-launcher - newt-installer)))) + (login-program (installer-program)))) (login-service (login-configuration (motd motd))) diff --git a/guix/self.scm b/guix/self.scm index 2698596387..4df4f6506e 100644 --- a/guix/self.scm +++ b/guix/self.scm @@ -604,11 +604,7 @@ Info manual." (scheme-node "guix-system" `((gnu system) (gnu services) - ,@(filter-map - (match-lambda - (('gnu 'system 'install) #f) - (name name)) - (scheme-modules* source "gnu/system")) + ,@(scheme-modules* source "gnu/system") ,@(scheme-modules* source "gnu/services")) (list *core-package-modules* *package-modules* *extra-modules* *core-modules*) @@ -616,7 +612,9 @@ Info manual." #:extra-files (append (file-imports source "gnu/system/examples" (const #t)) - + ;; All the installer code is on the build-side. + (file-imports source "gnu/installer/" + (const #t)) ;; Build-side code that we don't build. Some of ;; these depend on guile-rsvg, the Shepherd, etc. (file-imports source "gnu/build" (const #t))) diff --git a/po/guix/POTFILES.in b/po/guix/POTFILES.in index 585ceeb5c2..1378b33e0e 100644 --- a/po/guix/POTFILES.in +++ b/po/guix/POTFILES.in @@ -9,7 +9,7 @@ gnu/system/mapped-devices.scm gnu/system/shadow.scm guix/import/opam.scm gnu/installer.scm -gnu/installer/build-installer.scm +gnu/installer/record.scm gnu/installer/connman.scm gnu/installer/keymap.scm gnu/installer/locale.scm -- cgit v1.2.3 From b08bea04978ee93696a2172c6c5fe2c08561a8a2 Mon Sep 17 00:00:00 2001 From: Mathieu Othacehe Date: Wed, 5 Dec 2018 14:08:35 +0900 Subject: build: syscalls: Add device-in-use?. This new procedure uses BLKRRPART to determine whether or not a device is busy. It is useful when a device does not appear as mounted but is maybe used by the kernel. This is the case with overlayfs lowerdir backend device for example. * guix/build/syscalls.scm (device-in-use?): New exported procedure. --- guix/build/syscalls.scm | 22 ++++++++++++++++++++++ 1 file changed, 22 insertions(+) (limited to 'guix') diff --git a/guix/build/syscalls.scm b/guix/build/syscalls.scm index d75c11ada7..6f2a061f35 100644 --- a/guix/build/syscalls.scm +++ b/guix/build/syscalls.scm @@ -73,6 +73,7 @@ file-system-mount-flags statfs free-disk-space + device-in-use? processes mkdtemp! @@ -684,6 +685,27 @@ mounted at FILE." (define AT_NO_AUTOMOUNT #x800) (define AT_EMPTY_PATH #x1000) +(define-syntax BLKRRPART ; + (identifier-syntax #x125F)) + +(define* (device-in-use? device) + "Return #t if the block DEVICE is in use, #f otherwise. This is inspired +from fdisk_device_is_used function of util-linux. This is particulary useful +for devices that do not appear in /proc/self/mounts like overlayfs lowerdir +backend device." + (let*-values (((port) (open-file device "rb")) + ((ret err) (%ioctl (fileno port) BLKRRPART %null-pointer))) + (close-port port) + (cond + ((= ret 0) + #f) + ((= err EBUSY) + #t) + (else + (throw 'system-error "ioctl" "~A" + (list (strerror err)) + (list err)))))) + ;;; ;;; Containers. -- cgit v1.2.3 From a1f5dfc202f831b5e1cac4fbec9c27ae897c069f Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 16 Jan 2019 16:16:24 +0100 Subject: syscalls: 'device-in-use?' does not create a port. * guix/build/syscalls.scm (device-in-use?): Use 'open-fdes' rather than 'open-file'. --- guix/build/syscalls.scm | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) (limited to 'guix') diff --git a/guix/build/syscalls.scm b/guix/build/syscalls.scm index 6f2a061f35..94d335b67c 100644 --- a/guix/build/syscalls.scm +++ b/guix/build/syscalls.scm @@ -693,9 +693,9 @@ mounted at FILE." from fdisk_device_is_used function of util-linux. This is particulary useful for devices that do not appear in /proc/self/mounts like overlayfs lowerdir backend device." - (let*-values (((port) (open-file device "rb")) - ((ret err) (%ioctl (fileno port) BLKRRPART %null-pointer))) - (close-port port) + (let*-values (((fd) (open-fdes device O_RDONLY)) + ((ret err) (%ioctl fd BLKRRPART %null-pointer))) + (close-fdes fd) (cond ((= ret 0) #f) -- cgit v1.2.3 From 077589459c1c3ce4cb690447d82b75a46712f896 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 16 Jan 2019 17:43:52 +0100 Subject: syscalls: 'device-in-use?' returns #f upon EINVAL. This mirrors the behavior of the 'fdisk_device_is_used' function of util-linux. * guix/build/syscalls.scm (device-in-use?): Return #f upon EINVAL. --- guix/build/syscalls.scm | 5 +++++ 1 file changed, 5 insertions(+) (limited to 'guix') diff --git a/guix/build/syscalls.scm b/guix/build/syscalls.scm index 94d335b67c..66d63a2931 100644 --- a/guix/build/syscalls.scm +++ b/guix/build/syscalls.scm @@ -701,6 +701,11 @@ backend device." #f) ((= err EBUSY) #t) + ((= err EINVAL) + ;; We get EINVAL for devices that have the GENHD_FL_NO_PART_SCAN flag + ;; set in the kernel, in particular loopback devices, though we do seem + ;; to get it for SCSI storage (/dev/sr0) on QEMU. + #f) (else (throw 'system-error "ioctl" "~A" (list (strerror err)) -- 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') 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 @@ Supported formats: 'nix-base32' (default), 'base32', and 'base16' (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 cf22e99f0252a4712ab94d630dc4914c9a89f18d Mon Sep 17 00:00:00 2001 From: Christopher Baines Date: Thu, 17 Jan 2019 21:00:19 +0000 Subject: guix: Add guard to texlive-configuration profile hook. It is possible to generate a profile where this hook will crash, as the texmf.cnf file does not exist to be patched by substitute*. A simple example is the profile just containing texlive-fonts-txfonts. * guix/profiles.scm (texlive-configuration): Check that the texmf.cnf file exists before trying to change it. --- guix/profiles.scm | 15 +++++++++------ 1 file changed, 9 insertions(+), 6 deletions(-) (limited to 'guix') diff --git a/guix/profiles.scm b/guix/profiles.scm index d22539bdb2..598e0acf62 100644 --- a/guix/profiles.scm +++ b/guix/profiles.scm @@ -1363,12 +1363,15 @@ MANIFEST." (manifest-entries manifest)) #:create-all-directories? #t #:log-port (%make-void-port "w")) - (substitute* (string-append #$output - "/share/texmf-dist/web2c/texmf.cnf") - (("^TEXMFROOT = .*") - (string-append "TEXMFROOT = " #$output "/share\n")) - (("^TEXMF = .*") - "TEXMF = $TEXMFROOT/share/texmf-dist\n")) + (let ((texmf.cnf (string-append + #$output + "/share/texmf-dist/web2c/texmf.cnf"))) + (when (file-exists? texmf.cnf) + (substitute* texmf.cnf + (("^TEXMFROOT = .*") + (string-append "TEXMFROOT = " #$output "/share\n")) + (("^TEXMF = .*") + "TEXMF = $TEXMFROOT/share/texmf-dist\n")))) #t))) (with-monad %store-monad -- cgit v1.2.3 From 9fe3f11398e858f1d06120bd046cab506efc86dc Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 18 Jan 2019 14:23:31 +0100 Subject: serialization: 'restore-file' errors out upon non-convertible file names. Fixes . Reported by Maxim Cournoyer . * guix/serialization.scm (port-conversion-strategy): New variable. (restore-file): Parameterize it. * tests/nar.scm ("restore-file with non-UTF8 locale"): New test. --- guix/serialization.scm | 13 +++++++++++-- tests/nar.scm | 36 +++++++++++++++++++++++++++++++++++- 2 files changed, 46 insertions(+), 3 deletions(-) (limited to 'guix') diff --git a/guix/serialization.scm b/guix/serialization.scm index 87ad7eeec0..7c0fea552d 100644 --- a/guix/serialization.scm +++ b/guix/serialization.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. ;;; @@ -380,10 +380,19 @@ which case you can use 'identity'." (&nar-error (file f) (port port)))))) (write-string ")" p))) +(define port-conversion-strategy + (fluid->parameter %default-port-conversion-strategy)) + (define (restore-file port file) "Read a file (possibly a directory structure) in Nar format from PORT. Restore it as FILE." - (parameterize ((currently-restored-file file)) + (parameterize ((currently-restored-file file) + + ;; Error out if we can convert file names to the current + ;; locale. (XXX: We'd prefer UTF-8 encoding for file names + ;; regardless of the locale, but that's what Guile gives us + ;; so far.) + (port-conversion-strategy 'error)) (let ((signature (read-string port))) (unless (equal? signature %archive-version-1) (raise diff --git a/tests/nar.scm b/tests/nar.scm index 5ffe68c9e2..bfc71c69a8 100644 --- a/tests/nar.scm +++ b/tests/nar.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. ;;; @@ -334,6 +334,40 @@ (lambda () (rmdir input))))) +(test-eq "restore-file with non-UTF8 locale" ; + 'encoding-error + (let* ((file (search-path %load-path "guix.scm")) + (output (string-append %test-dir "/output")) + (locale (setlocale LC_ALL "C"))) + (dynamic-wind + (lambda () #t) + (lambda () + (define-values (port get-bytevector) + (open-bytevector-output-port)) + + (write-file-tree "root" port + #:file-type+size + (match-lambda + ("root" (values 'directory 0)) + ("root/λ" (values 'regular 0))) + #:file-port (const (%make-void-port "r")) + #:symlink-target (const #f) + #:directory-entries (const '("λ"))) + (close-port port) + + (mkdir %test-dir) + (catch 'encoding-error + (lambda () + ;; This show throw to 'encoding-error. + (restore-file (open-bytevector-input-port (get-bytevector)) + output) + (scandir output)) + (lambda args + 'encoding-error))) + (lambda () + (false-if-exception (rm-rf %test-dir)) + (setlocale LC_ALL locale))))) + (test-assert "restore-file-set (signed, valid)" (with-store store (let* ((texts (unfold (cut >= <> 10) -- 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') 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 @@ #: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 @@ true, display what would be built without actually building it." #: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 8bb62ae10c2b22dd052911939f71dcff68e19b97 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 18 Jan 2019 23:16:19 +0100 Subject: self: Add gnu/tests/* to the installed files. * guix/self.scm (compiled-guix)[*system-modules*]: Add gnu/tests/*. --- guix/self.scm | 5 +++++ 1 file changed, 5 insertions(+) (limited to 'guix') diff --git a/guix/self.scm b/guix/self.scm index 4df4f6506e..fa78015a41 100644 --- a/guix/self.scm +++ b/guix/self.scm @@ -612,6 +612,11 @@ Info manual." #:extra-files (append (file-imports source "gnu/system/examples" (const #t)) + + ;; Need so we get access system tests from an + ;; inferior. + (file-imports source "gnu/tests" (const #t)) + ;; All the installer code is on the build-side. (file-imports source "gnu/installer/" (const #t)) -- cgit v1.2.3 From 38b77f34640ff8a491913d29abcd16a846f2d0e4 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sun, 20 Jan 2019 01:33:25 +0100 Subject: profiles: Allow a profile to be added as an entry of another profile. * guix/build/profiles.scm (build-etc/profile): When 'OUTPUT/etc/profile' already exists, delete it first. (build-profile): Likewise for 'OUTPUT/manifest'. * tests/profiles.scm ("profile in profile"): New test. --- guix/build/profiles.scm | 23 +++++++++++++++++++---- tests/profiles.scm | 32 +++++++++++++++++++++++++++++++- 2 files changed, 50 insertions(+), 5 deletions(-) (limited to 'guix') diff --git a/guix/build/profiles.scm b/guix/build/profiles.scm index 0c23cd300e..1dc7976879 100644 --- a/guix/build/profiles.scm +++ b/guix/build/profiles.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 ;;; ;;; This file is part of GNU Guix. ;;; @@ -67,8 +67,14 @@ user-friendly name of the profile is, for instance ~/.guix-profile rather than (define (build-etc/profile output search-paths) "Build the 'OUTPUT/etc/profile' shell file containing environment variable definitions for all the SEARCH-PATHS." - (mkdir-p (string-append output "/etc")) - (call-with-output-file (string-append output "/etc/profile") + (define file + (string-append output "/etc/profile")) + + (mkdir-p (dirname file)) + (when (file-exists? file) + (delete-file file)) + + (call-with-output-file file (lambda (port) ;; The use of $GUIX_PROFILE described below is not great. Another ;; option would have been to use "$1" and have users run: @@ -144,13 +150,22 @@ instead make DIRECTORY a \"real\" directory containing symlinks." create symlinks. Write MANIFEST, an sexp, to OUTPUT/manifest. Create OUTPUT/etc/profile with Bash definitions for -all the variables listed in SEARCH-PATHS." + (define manifest-file + (string-append output "/manifest")) + ;; Make the symlinks. (union-build output inputs #:symlink symlink #:log-port (%make-void-port "w")) + ;; If one of the INPUTS provides a '/manifest' file, delete it. That can + ;; happen if MANIFEST contains something such as a Guix instance, which is + ;; ultimately built as a profile. + (when (file-exists? manifest-file) + (delete-file manifest-file)) + ;; Store meta-data. - (call-with-output-file (string-append output "/manifest") + (call-with-output-file manifest-file (lambda (p) (pretty-print manifest p))) diff --git a/tests/profiles.scm b/tests/profiles.scm index 8816839d16..9a05030aff 100644 --- a/tests/profiles.scm +++ b/tests/profiles.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 Alex Kost ;;; ;;; This file is part of GNU Guix. @@ -591,6 +591,36 @@ (built-derivations (list drv)) (return (readlink (readlink (string-append profile "/dangling"))))))) +(test-equalm "profile in profile" + '("foo" "0") + + ;; Make sure we can build a profile that has another profile has one of its + ;; entries. The new profile's /manifest and /etc/profile must override the + ;; other's. + (mlet* %store-monad + ((prof0 (profile-derivation + (manifest + (list (package->manifest-entry %bootstrap-guile))) + #:hooks '() + #:locales? #f)) + (prof1 (profile-derivation + (manifest (list (manifest-entry + (name "foo") + (version "0") + (item prof0)))) + #:hooks '() + #:locales? #f))) + (mbegin %store-monad + (built-derivations (list prof1)) + (let ((out (derivation->output-path prof1))) + (return (and (file-exists? + (string-append out "/bin/guile")) + (let ((manifest (profile-manifest out))) + (match (manifest-entries manifest) + ((entry) + (list (manifest-entry-name entry) + (manifest-entry-version entry))))))))))) + (test-end "profiles") ;;; Local Variables: -- 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') 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 @@ descriptions maintained upstream." "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 ed75bdf35ca494496cdbc7a06b414e1f08e70cac Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 17 Jan 2019 16:57:53 +0100 Subject: channels: Don't pull from the same channel more than once. Previous 'channel-instance->manifest' would call 'latest-channel-derivation', which could trigger another round of 'latest-repository-commit' for no good reason. * guix/channels.scm (resolve-dependencies): New procedure. (channel-instance-derivations)[edges]: New variable. [instance->derivation]: New procedure. * tests/channels.scm (make-instance): Use 'checkout->channel-instance' instead of 'channel-instance'. ("channel-instances->manifest"): New test. --- guix/channels.scm | 64 ++++++++++++++++++++++++++++------------- tests/channels.scm | 84 ++++++++++++++++++++++++++++++++++++++++++++++++++++-- 2 files changed, 126 insertions(+), 22 deletions(-) (limited to 'guix') diff --git a/guix/channels.scm b/guix/channels.scm index cd8a0131bd..b9ce2aa024 100644 --- a/guix/channels.scm +++ b/guix/channels.scm @@ -35,6 +35,7 @@ #:autoload (guix self) (whole-package make-config.scm) #:autoload (guix inferior) (gexp->derivation-in-inferior) ;FIXME: circular dep #:use-module (ice-9 match) + #:use-module (ice-9 vlist) #:export (channel channel? channel-name @@ -289,6 +290,34 @@ INSTANCE depends on." #:commit (channel-instance-commit instance) #:dependencies dependencies)) +(define (resolve-dependencies instances) + "Return a procedure that, given one of the elements of INSTANCES, returns +list of instances it depends on." + (define channel-instance-name + (compose channel-name channel-instance-channel)) + + (define table ;map a name to an instance + (fold (lambda (instance table) + (vhash-consq (channel-instance-name instance) + instance table)) + vlist-null + instances)) + + (define edges + (fold (lambda (instance edges) + (fold (lambda (channel edges) + (let ((name (channel-name channel))) + (match (vhash-assq name table) + ((_ . target) + (vhash-consq instance target edges))))) + edges + (channel-instance-dependencies instance))) + vlist-null + instances)) + + (lambda (instance) + (vhash-foldq* cons '() instance edges))) + (define (channel-instance-derivations instances) "Return the list of derivations to build INSTANCES, in the same order as INSTANCES." @@ -310,27 +339,22 @@ INSTANCES." (module-ref (resolve-interface '(gnu packages guile)) 'guile-bytestructures))) - (mlet %store-monad ((core (build-channel-instance core-instance))) - (mapm %store-monad - (lambda (instance) - (if (eq? instance core-instance) - (return core) - (match (channel-instance-dependencies instance) - (() + (define edges + (resolve-dependencies instances)) + + (define (instance->derivation instance) + (mcached (if (eq? instance core-instance) + (build-channel-instance instance) + (mlet %store-monad ((core (instance->derivation core-instance)) + (deps (mapm %store-monad instance->derivation + (edges instance)))) (build-channel-instance instance - (cons core dependencies))) - (channels - (mlet %store-monad ((dependencies-derivation - (latest-channel-derivation - ;; %default-channels is used here to - ;; ensure that the core channel is - ;; available for channels declared as - ;; dependencies. - (append channels %default-channels)))) - (build-channel-instance instance - (cons dependencies-derivation - (cons core dependencies)))))))) - instances))) + (cons core + (append deps + dependencies))))) + instance)) + + (mapm %store-monad instance->derivation instances)) (define (whole-package-for-legacy name modules) "Return a full-blown Guix package for MODULES, a derivation that builds Guix diff --git a/tests/channels.scm b/tests/channels.scm index f3fc383ac3..7df1b8c5fe 100644 --- a/tests/channels.scm +++ b/tests/channels.scm @@ -18,9 +18,15 @@ (define-module (test-channels) #:use-module (guix channels) + #:use-module (guix profiles) #:use-module ((guix build syscalls) #:select (mkdtemp!)) #:use-module (guix tests) + #:use-module (guix store) + #:use-module ((guix grafts) #:select (%graft?)) + #:use-module (guix derivations) + #:use-module (guix gexp) #:use-module (srfi srfi-1) + #:use-module (srfi srfi-26) #:use-module (srfi srfi-64) #:use-module (ice-9 match)) @@ -34,8 +40,9 @@ (and spec (with-output-to-file (string-append instance-dir "/.guix-channel") (lambda _ (format #t "~a" spec)))) - ((@@ (guix channels) channel-instance) - name commit instance-dir)) + (checkout->channel-instance instance-dir + #:commit commit + #:name name)) (define instance--boring (make-instance)) (define instance--no-deps @@ -136,4 +143,77 @@ 'abc1234))) instances)))))) +(test-assert "channel-instances->manifest" + ;; Compute the manifest for a graph of instances and make sure we get a + ;; derivation graph that mirrors the instance graph. This test also ensures + ;; we don't try to access Git repositores at all at this stage. + (let* ((spec (lambda deps + `(channel (version 0) + (dependencies + ,@(map (lambda (dep) + `(channel + (name ,dep) + (url "http://example.org"))) + deps))))) + (guix (make-instance #:name 'guix)) + (instance0 (make-instance #:name 'a)) + (instance1 (make-instance #:name 'b #:spec (spec 'a))) + (instance2 (make-instance #:name 'c #:spec (spec 'b))) + (instance3 (make-instance #:name 'd #:spec (spec 'c 'a)))) + (%graft? #f) ;don't try to build stuff + + ;; Create 'build-self.scm' so that GUIX is recognized as the 'guix' channel. + (let ((source (channel-instance-checkout guix))) + (mkdir (string-append source "/build-aux")) + (call-with-output-file (string-append source + "/build-aux/build-self.scm") + (lambda (port) + (write '(begin + (use-modules (guix) (gnu packages bootstrap)) + + (lambda _ + (package->derivation %bootstrap-guile))) + port)))) + + (with-store store + (let () + (define manifest + (run-with-store store + (channel-instances->manifest (list guix + instance0 instance1 + instance2 instance3)))) + + (define entries + (manifest-entries manifest)) + + (define (depends? drv in out) + ;; Return true if DRV depends on all of IN and none of OUT. + (let ((lst (map derivation-input-path (derivation-inputs drv))) + (in (map derivation-file-name in)) + (out (map derivation-file-name out))) + (and (every (cut member <> lst) in) + (not (any (cut member <> lst) out))))) + + (define (lookup name) + (run-with-store store + (lower-object + (manifest-entry-item + (manifest-lookup manifest + (manifest-pattern (name name))))))) + + (let ((drv-guix (lookup "guix")) + (drv0 (lookup "a")) + (drv1 (lookup "b")) + (drv2 (lookup "c")) + (drv3 (lookup "d"))) + (and (depends? drv-guix '() (list drv0 drv1 drv2 drv3)) + (depends? drv0 + (list) (list drv1 drv2 drv3)) + (depends? drv1 + (list drv0) (list drv2 drv3)) + (depends? drv2 + (list drv1) (list drv0 drv3)) + (depends? drv3 + (list drv2 drv0) (list drv1)))))))) + (test-end "channels") -- cgit v1.2.3 From 1fafc383b1f04fcdaa49941f5bb64ac3008cfad8 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 18 Jan 2019 10:01:37 +0100 Subject: inferior: 'gexp->derivation-in-inferior' honors EXP's load path. Previously the imported modules and extensions of EXP would be missing from the load path of 'guix repl'. * guix/inferior.scm (gexp->derivation-in-inferior)[script]: New variable. [trampoline]: Write (primitive-load #$script) to PIPE. Add #$output. * tests/channels.scm ("channel-instances->manifest")[depends?]: Check for requisites rather than direct references. Adjust callers accordingly. --- guix/inferior.scm | 13 ++++++++++--- tests/channels.scm | 16 ++++++++++------ 2 files changed, 20 insertions(+), 9 deletions(-) (limited to 'guix') diff --git a/guix/inferior.scm b/guix/inferior.scm index 4dfb242e44..9f19e7d316 100644 --- a/guix/inferior.scm +++ b/guix/inferior.scm @@ -491,6 +491,10 @@ PACKAGE must be live." "Return a derivation that evaluates EXP with GUIX, an instance of Guix as returned for example by 'channel-instances->derivation'. Other arguments are passed as-is to 'gexp->derivation'." + (define script + ;; EXP wrapped with a proper (set! %load-path …) prologue. + (scheme-file "inferior-script.scm" exp)) + (define trampoline ;; This is a crude way to run EXP on GUIX. TODO: use 'raw-derivation' and ;; make 'guix repl' the "builder"; this will require "opening up" the @@ -501,9 +505,12 @@ passed as-is to 'gexp->derivation'." (let ((pipe (open-pipe* OPEN_WRITE #+(file-append guix "/bin/guix") "repl" "-t" "machine"))) - ;; Unquote EXP right here so that its references to #$output - ;; propagate to the surrounding gexp. - (write '#$exp pipe) ;XXX: load path for EXP? + + ;; XXX: EXP presumably refers to #$output but that reference is lost + ;; so explicitly reference it here. + #$output + + (write `(primitive-load #$script) pipe) (unless (zero? (close-pipe pipe)) (error "inferior failed" #+guix))))) diff --git a/tests/channels.scm b/tests/channels.scm index 7df1b8c5fe..8540aef435 100644 --- a/tests/channels.scm +++ b/tests/channels.scm @@ -24,6 +24,7 @@ #:use-module (guix store) #:use-module ((guix grafts) #:select (%graft?)) #:use-module (guix derivations) + #:use-module (guix sets) #:use-module (guix gexp) #:use-module (srfi srfi-1) #:use-module (srfi srfi-26) @@ -187,12 +188,15 @@ (manifest-entries manifest)) (define (depends? drv in out) - ;; Return true if DRV depends on all of IN and none of OUT. - (let ((lst (map derivation-input-path (derivation-inputs drv))) + ;; Return true if DRV depends (directly or indirectly) on all of IN + ;; and none of OUT. + (let ((set (list->set + (requisites store + (list (derivation-file-name drv))))) (in (map derivation-file-name in)) (out (map derivation-file-name out))) - (and (every (cut member <> lst) in) - (not (any (cut member <> lst) out))))) + (and (every (cut set-contains? set <>) in) + (not (any (cut set-contains? set <>) out))))) (define (lookup name) (run-with-store store @@ -212,8 +216,8 @@ (depends? drv1 (list drv0) (list drv2 drv3)) (depends? drv2 - (list drv1) (list drv0 drv3)) + (list drv1) (list drv3)) (depends? drv3 - (list drv2 drv0) (list drv1)))))))) + (list drv2 drv0) (list)))))))) (test-end "channels") -- cgit v1.2.3 From acefa7408b2f573e6a14acd5f55b652b7c8806b4 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 18 Jan 2019 10:15:35 +0100 Subject: channels: Build channel modules in an inferior. This ensures that channel modules are compiled with the right Guile, that they get to see the right modules, and so on. IOW, it avoids bugs such as those addressed by commits 3c0e16391ed9a3e3e4611b940fb393c5f2ecea63 and cb341c121919877ae6267a6460c0c17536d06eff. * guix/channels.scm (standard-module-derivation): Add 'core' parameter. Rewrite in terms of 'gexp->derivation-in-inferior'. (build-from-source): Add #:core parameter and pass it to 'standard-module-derivation'. (build-channel-instance): Add 'core' parameter and pass it on. (channel-instance-derivations)[dependencies]: Remove. Adjust 'build-channel-instance' call. --- guix/channels.scm | 87 +++++++++++++++++++++++++------------------------------ 1 file changed, 39 insertions(+), 48 deletions(-) (limited to 'guix') diff --git a/guix/channels.scm b/guix/channels.scm index b9ce2aa024..eb56c821e5 100644 --- a/guix/channels.scm +++ b/guix/channels.scm @@ -218,45 +218,48 @@ of COMMIT at URL. Use NAME as the channel name." ;; place a set of compiled Guile modules in ~/.config/guix/latest. 1) -(define (standard-module-derivation name source dependencies) - "Return a derivation that builds the Scheme modules in SOURCE and that -depend on DEPENDENCIES, a list of lowerable objects. The assumption is that -SOURCE contains package modules to be added to '%package-module-path'." - (define modules - (scheme-modules* source)) - +(define (standard-module-derivation name source core dependencies) + "Return a derivation that builds with CORE, a Guix instance, the Scheme +modules in SOURCE and that depend on DEPENDENCIES, a list of lowerable +objects. The assumption is that SOURCE contains package modules to be added +to '%package-module-path'." ;; FIXME: We should load, say SOURCE/.guix-channel.scm, which would allow ;; channel publishers to specify things such as the sub-directory where .scm ;; files live, files to exclude from the channel, preferred substitute URLs, ;; etc. - (mlet* %store-monad ((compiled - (compiled-modules modules - #:name name - #:module-path (list source) - #:extensions dependencies))) - - (gexp->derivation name - (with-extensions dependencies - (with-imported-modules '((guix build utils)) - #~(begin - (use-modules (guix build utils)) - - (let ((go (string-append #$output "/lib/guile/" - (effective-version) - "/site-ccache")) - (scm (string-append #$output - "/share/guile/site/" - (effective-version)))) - (mkdir-p (dirname go)) - (symlink #$compiled go) - (mkdir-p (dirname scm)) - (symlink #$source scm)))))))) + + (define build + ;; This is code that we'll run in CORE, a Guix instance, with its own + ;; modules and so on. That way, we make sure these modules are built for + ;; the right Guile version, with the right dependencies, and that they get + ;; to see the right (gnu packages …) modules. + (with-extensions dependencies + #~(begin + (use-modules (guix build compile) + (guix build utils) + (srfi srfi-26)) + + (define go + (string-append #$output "/lib/guile/" (effective-version) + "/site-ccache")) + (define scm + (string-append #$output "/share/guile/site/" + (effective-version))) + + (compile-files #$source go + (find-files #$source "\\.scm$")) + (mkdir-p (dirname scm)) + (symlink #$source scm) + scm))) + + (gexp->derivation-in-inferior name build core)) (define* (build-from-source name source - #:key verbose? commit + #:key core verbose? commit (dependencies '())) "Return a derivation to build Guix from SOURCE, using the self-build script -contained therein. Use COMMIT as the version string." +contained therein; use COMMIT as the version string. When CORE is true, build +package modules under SOURCE using CORE, an instance of Guix." ;; Running the self-build script makes it easier to update the build ;; procedure: the self-build script of the Guix-to-be-installed contains the ;; right dependencies, build procedure, etc., which the Guix-in-use may not @@ -278,9 +281,10 @@ contained therein. Use COMMIT as the version string." #:pull-version %pull-version)) ;; Build a set of modules that extend Guix using the standard method. - (standard-module-derivation name source dependencies))) + (standard-module-derivation name source core dependencies))) -(define* (build-channel-instance instance #:optional (dependencies '())) +(define* (build-channel-instance instance + #:optional core (dependencies '())) "Return, as a monadic value, the derivation for INSTANCE, a channel instance. DEPENDENCIES is a list of extensions providing Guile modules that INSTANCE depends on." @@ -288,6 +292,7 @@ INSTANCE depends on." (channel-name (channel-instance-channel instance))) (channel-instance-checkout instance) #:commit (channel-instance-commit instance) + #:core core #:dependencies dependencies)) (define (resolve-dependencies instances) @@ -328,17 +333,6 @@ INSTANCES." (guix-channel? (channel-instance-channel instance))) instances)) - (define dependencies - ;; Dependencies of CORE-INSTANCE. - ;; FIXME: It would be best not to hard-wire this information here and - ;; instead query it to CORE-INSTANCE. - (list (module-ref (resolve-interface '(gnu packages gnupg)) - 'guile-gcrypt) - (module-ref (resolve-interface '(gnu packages guile)) - 'guile-git) - (module-ref (resolve-interface '(gnu packages guile)) - 'guile-bytestructures))) - (define edges (resolve-dependencies instances)) @@ -348,10 +342,7 @@ INSTANCES." (mlet %store-monad ((core (instance->derivation core-instance)) (deps (mapm %store-monad instance->derivation (edges instance)))) - (build-channel-instance instance - (cons core - (append deps - dependencies))))) + (build-channel-instance instance core deps))) instance)) (mapm %store-monad instance->derivation instances)) -- cgit v1.2.3 From ab6025b52cec792312d465107e9b86d7900c5f93 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sun, 20 Jan 2019 18:11:11 +0100 Subject: channels: Gracefully report the lack of a 'guix' channel. * guix/channels.scm (channel-instance-derivations): Raise an '&message' condition when CORE-INSTANCE is #f. --- guix/channels.scm | 16 ++++++++++++++++ 1 file changed, 16 insertions(+) (limited to 'guix') diff --git a/guix/channels.scm b/guix/channels.scm index eb56c821e5..e588d86b4b 100644 --- a/guix/channels.scm +++ b/guix/channels.scm @@ -28,10 +28,15 @@ #:use-module (guix derivations) #:use-module (guix store) #:use-module (guix i18n) + #:use-module ((guix utils) + #:select (source-properties->location + &error-location)) #:use-module (srfi srfi-1) #:use-module (srfi srfi-2) #:use-module (srfi srfi-9) #:use-module (srfi srfi-11) + #:use-module (srfi srfi-34) + #:use-module (srfi srfi-35) #:autoload (guix self) (whole-package make-config.scm) #:autoload (guix inferior) (gexp->derivation-in-inferior) ;FIXME: circular dep #:use-module (ice-9 match) @@ -345,6 +350,17 @@ INSTANCES." (build-channel-instance instance core deps))) instance)) + (unless core-instance + (let ((loc (and=> (any (compose channel-location channel-instance-channel) + instances) + source-properties->location))) + (raise (apply make-compound-condition + (condition + (&message (message "'guix' channel is lacking"))) + (if loc + (list (condition (&error-location (location loc)))) + '()))))) + (mapm %store-monad instance->derivation instances)) (define (whole-package-for-legacy name modules) -- cgit v1.2.3 From f58f676b12254cdf5adb453798917b06ac6609a6 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sun, 20 Jan 2019 18:45:40 +0100 Subject: channels: Use 'fold2'. * guix/channels.scm (latest-channel-instances): Use 'fold2' instead of 'fold'. --- guix/channels.scm | 72 +++++++++++++++++++++++++++---------------------------- 1 file changed, 36 insertions(+), 36 deletions(-) (limited to 'guix') diff --git a/guix/channels.scm b/guix/channels.scm index e588d86b4b..10345c1ce5 100644 --- a/guix/channels.scm +++ b/guix/channels.scm @@ -26,6 +26,7 @@ #:use-module (guix monads) #:use-module (guix profiles) #:use-module (guix derivations) + #:use-module (guix combinators) #:use-module (guix store) #:use-module (guix i18n) #:use-module ((guix utils) @@ -162,44 +163,43 @@ of previously processed channels." (or (channel-commit b) (not (or (channel-commit a) (channel-commit b)))))))) + ;; Accumulate a list of instances. A list of processed channels is also ;; accumulated to decide on duplicate channel specifications. - (match (fold (lambda (channel acc) - (match acc - ((#:channels previous-channels #:instances instances) - (if (ignore? channel previous-channels) - acc - (begin - (format (current-error-port) - (G_ "Updating channel '~a' from Git repository at '~a'...~%") - (channel-name channel) - (channel-url channel)) - (let-values (((checkout commit) - (latest-repository-commit store (channel-url channel) - #:ref (channel-reference - channel)))) - (let ((instance (channel-instance channel commit checkout))) - (let-values (((new-instances new-channels) - (latest-channel-instances - store - (channel-instance-dependencies instance) - previous-channels))) - `(#:channels - ,(append (cons channel new-channels) - previous-channels) - #:instances - ,(append (cons instance new-instances) - instances)))))))))) - `(#:channels ,previous-channels #:instances ()) - channels) - ((#:channels channels #:instances instances) - (let ((instance-name (compose channel-name channel-instance-channel))) - ;; Remove all earlier channel specifications if they are followed by a - ;; more specific one. - (values (delete-duplicates instances - (lambda (a b) - (eq? (instance-name a) (instance-name b)))) - channels))))) + (define-values (resulting-channels instances) + (fold2 (lambda (channel previous-channels instances) + (if (ignore? channel previous-channels) + (values previous-channels instances) + (begin + (format (current-error-port) + (G_ "Updating channel '~a' from Git repository at '~a'...~%") + (channel-name channel) + (channel-url channel)) + (let-values (((checkout commit) + (latest-repository-commit store (channel-url channel) + #:ref (channel-reference + channel)))) + (let ((instance (channel-instance channel commit checkout))) + (let-values (((new-instances new-channels) + (latest-channel-instances + store + (channel-instance-dependencies instance) + previous-channels))) + (values (append (cons channel new-channels) + previous-channels) + (append (cons instance new-instances) + instances)))))))) + previous-channels + '() ;instances + channels)) + + (let ((instance-name (compose channel-name channel-instance-channel))) + ;; Remove all earlier channel specifications if they are followed by a + ;; more specific one. + (values (delete-duplicates instances + (lambda (a b) + (eq? (instance-name a) (instance-name b)))) + resulting-channels))) (define* (checkout->channel-instance checkout #:key commit -- cgit v1.2.3 From 2034a231dcfbf0507930597492b986bfd5cf4c37 Mon Sep 17 00:00:00 2001 From: Arun Isaac Date: Sun, 20 Jan 2019 22:18:32 +0530 Subject: import: github: Check if git URIs are GitHub URIs. This fixes a regression introduced in 9a5091d0c181453d0f31ce97f96a4e577a25e796 whereby packages with git origin URIs not hosted on GitHub would be wrongly detected as being covered under the github updater. Reported by Efraim Flashner . * guix/import/github.scm (updated-github-url): Check if git URIs are GitHub URIs. --- guix/import/github.scm | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/import/github.scm b/guix/import/github.scm index b287313d98..e17ef0b840 100644 --- a/guix/import/github.scm +++ b/guix/import/github.scm @@ -98,7 +98,9 @@ false if none is recognized" (updated-url source-uri)) ((source-uri ...) (find updated-url source-uri)))) - ((eq? fetch-method download:git-fetch) + ((and (eq? fetch-method download:git-fetch) + (string-prefix? "https://github.com/" + (download:git-reference-url source-uri))) (download:git-reference-url source-uri)) (else #f)))) -- cgit v1.2.3 From 54800977d9e234fa92f927496ca9f9e6ec050aca Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sun, 20 Jan 2019 22:59:28 +0100 Subject: self: Build the (gnu tests …) modules. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit * guix/self.scm (compiled-guix)[*system-modules*]: Remove gnu/tests/* from #:extra-files. [*system-test-modules*]: New variable. [build-modules]: Add them. --- guix/self.scm | 15 +++++++++++---- 1 file changed, 11 insertions(+), 4 deletions(-) (limited to 'guix') diff --git a/guix/self.scm b/guix/self.scm index fa78015a41..f3679546f6 100644 --- a/guix/self.scm +++ b/guix/self.scm @@ -613,10 +613,6 @@ Info manual." (append (file-imports source "gnu/system/examples" (const #t)) - ;; Need so we get access system tests from an - ;; inferior. - (file-imports source "gnu/tests" (const #t)) - ;; All the installer code is on the build-side. (file-imports source "gnu/installer/" (const #t)) @@ -626,6 +622,16 @@ Info manual." #:guile-for-build guile-for-build)) + (define *system-test-modules* + ;; Ship these modules mostly so (gnu ci) can refer to them. + (scheme-node "guix-system-tests" + `((gnu tests) + ,@(scheme-modules* source "gnu/tests")) + (list *core-package-modules* *package-modules* + *extra-modules* *system-modules* *core-modules*) + #:extensions dependencies + #:guile-for-build guile-for-build)) + (define *cli-modules* (scheme-node "guix-cli" (append (scheme-modules* source "/guix/scripts") @@ -664,6 +670,7 @@ Info manual." ;; comes with *CORE-MODULES*. (list *config* *cli-modules* + *system-test-modules* *system-modules* *package-modules* *core-package-modules* -- 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') 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 @@ #: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 6b7ea49bedb6902ee620ec337cb234a34b2ab49b Mon Sep 17 00:00:00 2001 From: Arun Isaac Date: Thu, 17 Jan 2019 01:34:07 +0530 Subject: import: github: Use prereleases when package has no releases. * guix/import/github.scm (latest-released-version): Use preleases when package has no releases. --- guix/import/github.scm | 14 ++++++-------- 1 file changed, 6 insertions(+), 8 deletions(-) (limited to 'guix') diff --git a/guix/import/github.scm b/guix/import/github.scm index e17ef0b840..c78469dac5 100644 --- a/guix/import/github.scm +++ b/guix/import/github.scm @@ -171,6 +171,9 @@ empty list." "Return a string of the newest released version name given a string URL like 'https://github.com/arq5x/bedtools2/archive/v2.24.0.tar.gz' and the name of the package e.g. 'bedtools2'. Return #f if there is no releases" + (define (pre-release? x) + (hash-ref x "prerelease")) + (let* ((json (fetch-releases-or-tags url))) (if (eq? json #f) (if (%github-token) @@ -181,14 +184,9 @@ API. This may be fixed by using an access token and setting the environment variable GUIX_GITHUB_TOKEN, for instance one procured from https://github.com/settings/tokens")) (let loop ((releases - (filter - (lambda (x) - ;; example pre-release: - ;; https://github.com/wwood/OrfM/releases/tag/v0.5.1 - ;; or an all-prerelease set - ;; https://github.com/powertab/powertabeditor/releases - (not (hash-ref x "prerelease"))) - json))) + (match (remove pre-release? json) + (() json) ; keep everything + (releases releases)))) (match releases (() ;empty release list #f) -- cgit v1.2.3 From cb5fe915d215af6accfc413bea109902f5618e47 Mon Sep 17 00:00:00 2001 From: Arun Isaac Date: Mon, 21 Jan 2019 01:43:09 +0530 Subject: import: github: Improve readability. * guix/import/github.scm (latest-released-version): Use any and cond instead of a recursive loop and an if-else ladder respectively. --- guix/import/github.scm | 55 ++++++++++++++++++++++++-------------------------- 1 file changed, 26 insertions(+), 29 deletions(-) (limited to 'guix') diff --git a/guix/import/github.scm b/guix/import/github.scm index c78469dac5..4d12339204 100644 --- a/guix/import/github.scm +++ b/guix/import/github.scm @@ -183,35 +183,32 @@ API when using a GitHub token") API. This may be fixed by using an access token and setting the environment variable GUIX_GITHUB_TOKEN, for instance one procured from https://github.com/settings/tokens")) - (let loop ((releases - (match (remove pre-release? json) - (() json) ; keep everything - (releases releases)))) - (match releases - (() ;empty release list - #f) - ((release . rest) ;one or more releases - (let ((tag (or (hash-ref release "tag_name") ;a "release" - (hash-ref release "name"))) ;a tag - (name-length (string-length package-name))) - ;; some tags include the name of the package e.g. "fdupes-1.51" - ;; so remove these - (if (and (< name-length (string-length tag)) - (string=? (string-append package-name "-") - (substring tag 0 (+ name-length 1)))) - (substring tag (+ name-length 1)) - ;; some tags start with a "v" e.g. "v0.25.0" - ;; where some are just the version number - (if (string-prefix? "v" tag) - (substring tag 1) - - ;; Finally, reject tags that don't start with a digit: - ;; they may not represent a release. - (if (and (not (string-null? tag)) - (char-set-contains? char-set:digit - (string-ref tag 0))) - tag - (loop rest))))))))))) + (any + (lambda (release) + (let ((tag (or (hash-ref release "tag_name") ;a "release" + (hash-ref release "name"))) ;a tag + (name-length (string-length package-name))) + (cond + ;; some tags include the name of the package e.g. "fdupes-1.51" + ;; so remove these + ((and (< name-length (string-length tag)) + (string=? (string-append package-name "-") + (substring tag 0 (+ name-length 1)))) + (substring tag (+ name-length 1))) + ;; some tags start with a "v" e.g. "v0.25.0" + ;; where some are just the version number + ((string-prefix? "v" tag) + (substring tag 1)) + ;; Finally, reject tags that don't start with a digit: + ;; they may not represent a release. + ((and (not (string-null? tag)) + (char-set-contains? char-set:digit + (string-ref tag 0))) + tag) + (else #f)))) + (match (remove pre-release? json) + (() json) ; keep everything + (releases releases)))))) (define (latest-release pkg) "Return an for the latest release of PKG." -- cgit v1.2.3 From 1b7dd99738f17d3e3ebc29500bc475f9dd214ba3 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 21 Jan 2019 15:30:14 +0100 Subject: deprecation: Add 'define-deprecated/alias'. * guix/deprecation.scm (define-deprecated/alias): New macro. --- guix/deprecation.scm | 22 +++++++++++++++++++++- 1 file changed, 21 insertions(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/deprecation.scm b/guix/deprecation.scm index 453aad7106..8d9e42758d 100644 --- a/guix/deprecation.scm +++ b/guix/deprecation.scm @@ -20,7 +20,7 @@ #:use-module (guix i18n) #:use-module (ice-9 format) #:export (define-deprecated - without-deprecation-warnings + define-deprecated/alias deprecation-warning-port)) ;;; Commentary: @@ -87,3 +87,23 @@ This will write a deprecation warning to DEPRECATION-WARNING-PORT." (id (identifier? #'id) #'real)))))))))) + +(define-syntax-rule (define-deprecated/alias deprecated replacement) + "Define as an alias a deprecated variable, procedure, or macro, along +these lines: + + (define-deprecated/alias nix-server? store-connection?) + +where 'nix-server?' is the deprecated name for 'store-connection?'. + +This will write a deprecation warning to DEPRECATION-WARNING-PORT." + (define-syntax deprecated + (lambda (s) + (warn-about-deprecation 'deprecated (syntax-source s) + #:replacement 'replacement) + (syntax-case s () + ((_ args (... ...)) + #'(replacement args (... ...))) + (id + (identifier? #'id) + #'replacement))))) -- cgit v1.2.3 From 3a0b2c6c6efd221341def2adf17279a9566555f7 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 21 Jan 2019 15:30:31 +0100 Subject: deprecation: Send warnings to (current-error-port) by default. * guix/deprecation.scm (deprecation-warning-port): Default to (current-error-port). --- guix/deprecation.scm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/deprecation.scm b/guix/deprecation.scm index 8d9e42758d..2f7c058940 100644 --- a/guix/deprecation.scm +++ b/guix/deprecation.scm @@ -33,7 +33,7 @@ (define deprecation-warning-port ;; Port where deprecation warnings go. - (make-parameter (current-warning-port))) + (make-parameter (current-error-port))) (define (source-properties->location-string properties) "Return a human-friendly, GNU-standard representation of PROPERTIES, a -- cgit v1.2.3 From de9fbe9cdcf5f8deb08becfc54b523084fd67bda Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 21 Jan 2019 15:32:35 +0100 Subject: store: Rename to . * guix/store.scm (): Rename to... (): ... this. Adjust users accordingly. (nix-server?, nix-server-major-version) (nix-server-minor-version, nix-server-socket) (nix-server-version): Define as deprecated aliases. * guix/inferior.scm: Adjust accordingly. * guix/ssh.scm: Likewise. --- guix/inferior.scm | 12 ++--- guix/ssh.scm | 6 +-- guix/store.scm | 153 ++++++++++++++++++++++++++++++------------------------ 3 files changed, 95 insertions(+), 76 deletions(-) (limited to 'guix') diff --git a/guix/inferior.scm b/guix/inferior.scm index 9f19e7d316..6cfa146029 100644 --- a/guix/inferior.scm +++ b/guix/inferior.scm @@ -26,9 +26,9 @@ version>? version-prefix? cache-directory)) #:use-module ((guix store) - #:select (nix-server-socket - nix-server-major-version - nix-server-minor-version + #:select (store-connection-socket + store-connection-major-version + store-connection-minor-version store-lift)) #:use-module ((guix derivations) #:select (read-derivation-from-file)) @@ -424,8 +424,8 @@ thus be the code of a one-argument procedure that accepts a store." (chmod directory #o700) (let* ((name (string-append directory "/inferior")) (socket (socket AF_UNIX SOCK_STREAM 0)) - (major (nix-server-major-version store)) - (minor (nix-server-minor-version store)) + (major (store-connection-major-version store)) + (minor (store-connection-minor-version store)) (proto (logior major minor))) (bind socket AF_UNIX name) (listen socket 1024) @@ -451,7 +451,7 @@ thus be the code of a one-argument procedure that accepts a store." inferior) (match (accept socket) ((client . address) - (proxy client (nix-server-socket store)))) + (proxy client (store-connection-socket store)))) (close-port socket) (read-inferior-response inferior))))) diff --git a/guix/ssh.scm b/guix/ssh.scm index d90cb77be0..77329618d5 100644 --- a/guix/ssh.scm +++ b/guix/ssh.scm @@ -180,7 +180,7 @@ right away." (socket-name "/var/guix/daemon-socket/socket")) "Connect to the remote build daemon listening on SOCKET-NAME over SESSION, -an SSH session. Return a object." +an SSH session. Return a object." (open-connection #:port (remote-daemon-channel session socket-name))) @@ -288,7 +288,7 @@ REMOTE, a remote store. When RECURSIVE? is true, send the closure of FILES. Return the list of store items actually sent." ;; 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))) + (session (channel-get-session (store-connection-socket remote))) (missing (inferior-remote-eval `(begin (use-modules (guix) @@ -345,7 +345,7 @@ Return the list of store items actually sent." (define (remote-store-session remote) "Return the SSH channel beneath REMOTE, a remote store as returned by 'connect-to-remote-daemon', or #f." - (channel-get-session (nix-server-socket remote))) + (channel-get-session (store-connection-socket remote))) (define (remote-store-host remote) "Return the name of the host REMOTE is connected to, where REMOTE is a diff --git a/guix/store.scm b/guix/store.scm index 1f88eb2b33..f8c79788b8 100644 --- a/guix/store.scm +++ b/guix/store.scm @@ -20,6 +20,7 @@ (define-module (guix store) #:use-module (guix utils) #:use-module (guix config) + #:use-module (guix deprecation) #:use-module (guix memoization) #:use-module (guix serialization) #:use-module (guix monads) @@ -51,11 +52,19 @@ %gc-roots-directory %default-substitute-urls + store-connection? + store-connection-version + store-connection-major-version + store-connection-minor-version + store-connection-socket + + ;; Deprecated forms for 'store-connection'. nix-server? nix-server-version nix-server-major-version nix-server-minor-version nix-server-socket + current-store-protocol-version ;for internal use mcached @@ -335,31 +344,39 @@ ;; remote-store.cc -(define-record-type* nix-server %make-nix-server - nix-server? - (socket nix-server-socket) - (major nix-server-major-version) - (minor nix-server-minor-version) +(define-record-type* store-connection %make-store-connection + store-connection? + (socket store-connection-socket) + (major store-connection-major-version) + (minor store-connection-minor-version) - (buffer nix-server-output-port) ;output port - (flush nix-server-flush-output) ;thunk + (buffer store-connection-output-port) ;output port + (flush store-connection-flush-output) ;thunk ;; Caches. We keep them per-connection, because store paths build ;; during the session are temporary GC roots kept for the duration of ;; the session. - (ats-cache nix-server-add-to-store-cache) - (atts-cache nix-server-add-text-to-store-cache) - (object-cache nix-server-object-cache + (ats-cache store-connection-add-to-store-cache) + (atts-cache store-connection-add-text-to-store-cache) + (object-cache store-connection-object-cache (default vlist-null))) ;vhash -(set-record-type-printer! +(set-record-type-printer! (lambda (obj port) - (format port "#" - (nix-server-major-version obj) - (nix-server-minor-version obj) + (format port "#" + (store-connection-major-version obj) + (store-connection-minor-version obj) (number->string (object-address obj) 16)))) +(define-deprecated/alias nix-server? store-connection?) +(define-deprecated/alias nix-server-major-version + store-connection-major-version) +(define-deprecated/alias nix-server-minor-version + store-connection-minor-version) +(define-deprecated/alias nix-server-socket store-connection-socket) + + (define-condition-type &nix-error &error nix-error?) @@ -515,13 +532,13 @@ for this connection will be pinned. Return a server object." (write-int cpu-affinity port))) (when (>= (protocol-minor v) 11) (write-int (if reserve-space? 1 0) port)) - (let ((conn (%make-nix-server port - (protocol-major v) - (protocol-minor v) - output flush - (make-hash-table 100) - (make-hash-table 100) - vlist-null))) + (let ((conn (%make-store-connection port + (protocol-major v) + (protocol-minor v) + output flush + (make-hash-table 100) + (make-hash-table 100) + vlist-null))) (let loop ((done? (process-stderr conn))) (or done? (process-stderr conn))) conn))))))))) @@ -536,27 +553,29 @@ already taken place on PORT and that we're just continuing on this established connection. Use with care." (let-values (((output flush) (buffering-output-port port (make-bytevector 8192)))) - (%make-nix-server port - (protocol-major version) - (protocol-minor version) - output flush - (make-hash-table 100) - (make-hash-table 100) - vlist-null))) - -(define (nix-server-version store) + (%make-store-connection port + (protocol-major version) + (protocol-minor version) + output flush + (make-hash-table 100) + (make-hash-table 100) + vlist-null))) + +(define (store-connection-version store) "Return the protocol version of STORE as an integer." - (protocol-version (nix-server-major-version store) - (nix-server-minor-version store))) + (protocol-version (store-connection-major-version store) + (store-connection-minor-version store))) + +(define-deprecated/alias nix-server-version store-connection-version) (define (write-buffered-output server) "Flush SERVER's output port." - (force-output (nix-server-output-port server)) - ((nix-server-flush-output server))) + (force-output (store-connection-output-port server)) + ((store-connection-flush-output server))) (define (close-connection server) "Close the connection to SERVER." - (close (nix-server-socket server))) + (close (store-connection-socket server))) (define-syntax-rule (with-store store exp ...) "Bind STORE to an open connection to the store and evaluate EXPs; @@ -566,7 +585,7 @@ automatically close the store when the dynamic extent of EXP is left." (const #f) (lambda () (parameterize ((current-store-protocol-version - (nix-server-version store))) + (store-connection-version store))) exp) ...) (lambda () (false-if-exception (close-connection store)))))) @@ -622,7 +641,7 @@ Since the build process's output cannot be assumed to be UTF-8, we conservatively consider it to be Latin-1, thereby avoiding possible encoding conversion errors." (define p - (nix-server-socket server)) + (store-connection-socket server)) ;; magic cookies from worker-protocol.hh (define %stderr-next #x6f6c6d67) ; "olmg", build log @@ -666,7 +685,7 @@ encoding conversion errors." (let ((error (read-maybe-utf8-string p)) ;; Currently the daemon fails to send a status code for early ;; errors like DB schema version mismatches, so check for EOF. - (status (if (and (>= (nix-server-minor-version server) 8) + (status (if (and (>= (store-connection-minor-version server) 8) (not (eof-object? (lookahead-u8 p)))) (read-int p) 1))) @@ -734,7 +753,7 @@ encoding conversion errors." ;; Must be called after `open-connection'. (define socket - (nix-server-socket server)) + (store-connection-socket server)) (let-syntax ((send (syntax-rules () ((_ (type option) ...) @@ -744,22 +763,22 @@ encoding conversion errors." (write-int (operation-id set-options) socket) (send (boolean keep-failed?) (boolean keep-going?) (boolean fallback?) (integer verbosity)) - (when (< (nix-server-minor-version server) #x61) + (when (< (store-connection-minor-version server) #x61) (let ((max-build-jobs (or max-build-jobs 1)) (max-silent-time (or max-silent-time 3600))) (send (integer max-build-jobs) (integer max-silent-time)))) - (when (>= (nix-server-minor-version server) 2) + (when (>= (store-connection-minor-version server) 2) (send (boolean use-build-hook?))) - (when (>= (nix-server-minor-version server) 4) + (when (>= (store-connection-minor-version server) 4) (send (integer build-verbosity) (integer log-type) (boolean print-build-trace))) - (when (and (>= (nix-server-minor-version server) 6) - (< (nix-server-minor-version server) #x61)) + (when (and (>= (store-connection-minor-version server) 6) + (< (store-connection-minor-version server) #x61)) (let ((build-cores (or build-cores (current-processor-count)))) (send (integer build-cores)))) - (when (>= (nix-server-minor-version server) 10) + (when (>= (store-connection-minor-version server) 10) (send (boolean use-substitutes?))) - (when (>= (nix-server-minor-version server) 12) + (when (>= (store-connection-minor-version server) 12) (let ((pairs `(;; This option is honored by 'guix substitute' et al. ,@(if print-build-trace `(("print-extended-build-trace" @@ -884,8 +903,8 @@ bytevector) as its internal buffer, and a thunk to flush this output port." ((_ (name (type arg) ...) docstring return ...) (lambda (server arg ...) docstring - (let* ((s (nix-server-socket server)) - (buffered (nix-server-output-port server))) + (let* ((s (store-connection-socket server)) + (buffered (store-connection-output-port server))) (record-operation 'name) (write-int (operation-id name) buffered) (write-arg type arg buffered) @@ -944,7 +963,7 @@ string). Raise an error if no such path exists." REFERENCES is the list of store paths referred to by the resulting store path." (let* ((args `(,bytes ,name ,references)) - (cache (nix-server-add-text-to-store-cache server))) + (cache (store-connection-add-text-to-store-cache server))) (or (hash-ref cache args) (let ((path (add-text-to-store server name bytes references))) (hash-set! cache args path) @@ -973,7 +992,7 @@ path." ;; We don't use the 'operation' macro so we can pass SELECT? to ;; 'write-file'. (record-operation 'add-to-store) - (let ((port (nix-server-socket server))) + (let ((port (store-connection-socket server))) (write-int (operation-id add-to-store) port) (write-string basename port) (write-int 1 port) ;obsolete, must be #t @@ -999,7 +1018,7 @@ where FILE is the entry's absolute file name and STAT is the result of ;; Note: We don't stat FILE-NAME at each call, and thus we assume that ;; the file remains unchanged for the lifetime of SERVER. (let* ((args `(,file-name ,basename ,recursive? ,hash-algo ,select?)) - (cache (nix-server-add-to-store-cache server))) + (cache (store-connection-add-to-store-cache server))) (or (hash-ref cache args) (let ((path (add-to-store server basename recursive? hash-algo file-name @@ -1078,14 +1097,14 @@ an arbitrary directory layout in the store without creating a derivation." ((_ 'directory (names . _) ...) names))) (define cache - (nix-server-add-to-store-cache server)) + (store-connection-add-to-store-cache server)) (or (hash-ref cache tree) (begin ;; We don't use the 'operation' macro so we can use 'write-file-tree' ;; instead of 'write-file'. (record-operation 'add-to-store/tree) - (let ((port (nix-server-socket server))) + (let ((port (store-connection-socket server))) (write-int (operation-id add-to-store) port) (write-string basename port) (write-int 1 port) ;obsolete, must be #t @@ -1117,8 +1136,8 @@ outputs, and return when the worker is done building them. Elements of THINGS that are not derivations can only be substituted and not built locally. Return #t on success." (parameterize ((current-store-protocol-version - (nix-server-version store))) - (if (>= (nix-server-minor-version store) 15) + (store-connection-version store))) + (if (>= (store-connection-minor-version store) 15) (build store things mode) (if (= mode (build-mode normal)) (build/old store things) @@ -1334,9 +1353,9 @@ supported by STORE." ;; derivation builders in general, which appeared in Guix > 0.11.0. ;; Return the empty list if it doesn't. Note that this RPC does not ;; exist in 'nix-daemon'. - (if (or (> (nix-server-major-version store) #x100) - (and (= (nix-server-major-version store) #x100) - (>= (nix-server-minor-version store) #x60))) + (if (or (> (store-connection-major-version store) #x100) + (and (= (store-connection-major-version store) #x100) + (>= (store-connection-minor-version store) #x60))) (builders store) '())))) @@ -1366,14 +1385,14 @@ the list of store paths to delete. IGNORE-LIVENESS? should always be #f. MIN-FREED is the minimum amount of disk space to be freed, in bytes, before the GC can stop. Return the list of store paths delete, and the number of bytes freed." - (let ((s (nix-server-socket server))) + (let ((s (store-connection-socket server))) (write-int (operation-id collect-garbage) s) (write-int action s) (write-store-path-list to-delete s) (write-arg boolean #f s) ; ignore-liveness? (write-long-long min-freed s) (write-int 0 s) ; obsolete - (when (>= (nix-server-minor-version server) 5) + (when (>= (store-connection-minor-version server) 5) ;; Obsolete `use-atime' and `max-atime' parameters. (write-int 0 s) (write-int 0 s)) @@ -1389,8 +1408,8 @@ and the number of bytes freed." ;; To be on the safe side, completely invalidate both caches. ;; Otherwise we could end up returning store paths that are no longer ;; valid. - (hash-clear! (nix-server-add-to-store-cache server)) - (hash-clear! (nix-server-add-text-to-store-cache server))) + (hash-clear! (store-connection-add-to-store-cache server)) + (hash-clear! (store-connection-add-text-to-store-cache server))) (values paths freed)))) @@ -1425,7 +1444,7 @@ collected, and the number of bytes freed." "Import the set of store paths read from PORT into SERVER's store. An error is raised if the set of paths read from PORT is not signed (as per 'export-path #:sign? #t'.) Return the list of store paths imported." - (let ((s (nix-server-socket server))) + (let ((s (store-connection-socket server))) (write-int (operation-id import-paths) s) (let loop ((done? (process-stderr server port))) (or done? (loop (process-stderr server port)))) @@ -1433,7 +1452,7 @@ is raised if the set of paths read from PORT is not signed (as per (define* (export-path server path port #:key (sign? #t)) "Export PATH to PORT. When SIGN? is true, sign it." - (let ((s (nix-server-socket server))) + (let ((s (store-connection-socket server))) (write-int (operation-id export-path) s) (write-store-path path s) (write-arg boolean sign? s) @@ -1502,10 +1521,10 @@ OBJECT is typically a high-level object such as a or an , and RESULT is typically its derivation." (lambda (store) (values result - (nix-server + (store-connection (inherit store) (object-cache (vhash-consq object (cons result keys) - (nix-server-object-cache store))))))) + (store-connection-object-cache store))))))) (define record-cache-lookup! (if (profiled? "object-cache") @@ -1540,7 +1559,7 @@ and KEYS. KEYS is a list of additional keys to match against, and which are compared with 'equal?'. Return #f on failure and the cached result otherwise." (lambda (store) - (let* ((cache (nix-server-object-cache store)) + (let* ((cache (store-connection-object-cache store)) ;; Escape as soon as we find the result. This avoids traversing ;; the whole vlist chain and significantly reduces the number of -- 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') 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 (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 @@ ;;; 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 @@ available." 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 @@ "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 @@ this type of graph"))))))) 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 @@ descriptions maintained upstream." (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 @@ MACHINE." (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 @@ ;; 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 @@ Return the list of store items actually sent." 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 @@ 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-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 (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 @@ ;; 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 @@ "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 @@ for this connection will be pinned. Return a server object." ;; 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 @@ encoding conversion errors." (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 @@ bytevector) as its internal buffer, and a thunk to flush this output port." 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 @@ Return #t on success." (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 @@ error if there is no such root." (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 @@ information for one of ITEMS is missing." '() (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 @@ where FILE is the entry's absolute file name and STAT is the result of "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* (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 @@ or remove one of them from the profile.") 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 @@ (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 @@ (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 @@ . ,(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 @@ . ,(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 @@ (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 @@ `("-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 @@ `("-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 @@ `("-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 @@ (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 @@ (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 @@ #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 @@ (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 @@ (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 @@ (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 @@ (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 @@ (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 @@ (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 @@ (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 @@ %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 @@ (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 @@ #: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 @@ (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 @@ (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 @@ (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 @@ (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 @@ #: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 567f0d2590ede190ff8700d2fc3e2b4d4b72bcbe Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 22 Jan 2019 10:22:33 +0100 Subject: self: Remove leftover export. * guix/self.scm: Remove 'reload-guix' export. --- guix/self.scm | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) (limited to 'guix') diff --git a/guix/self.scm b/guix/self.scm index f3679546f6..fea5db5da3 100644 --- a/guix/self.scm +++ b/guix/self.scm @@ -36,8 +36,7 @@ #:export (make-config.scm whole-package ;for internal use in 'guix pull' compiled-guix - guix-derivation - reload-guix)) + guix-derivation)) ;;; -- cgit v1.2.3 From c498aaaf110cd7f6950ea47e637725e0513655d4 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 22 Jan 2019 12:01:49 +0100 Subject: compile: Let compiler warnings through during the load phase. Previous warnings and errors such as those raised by (guix records) would not be displayed during the load phase. * guix/build/compile.scm (load-files): Remove 'parameterize' around 'resolve-interface' call. (compile-files)[build]: Move 'with-fluids' for *CURRENT-WARNING-PREFIX* to... : ... here. --- guix/build/compile.scm | 56 +++++++++++++++++++++++++------------------------- 1 file changed, 28 insertions(+), 28 deletions(-) (limited to 'guix') diff --git a/guix/build/compile.scm b/guix/build/compile.scm index 215489f136..9e31be93ff 100644 --- a/guix/build/compile.scm +++ b/guix/build/compile.scm @@ -97,8 +97,7 @@ (report-load file total completed) (format debug-port "~%loading '~a'...~%" file) - (parameterize ((current-warning-port debug-port)) - (resolve-interface (file-name->module-name file))) + (resolve-interface (file-name->module-name file)) (loop files (+ 1 completed))))))) @@ -158,37 +157,38 @@ files are for HOST, a GNU triplet such as \"x86_64-linux-gnu\"." ;; Exit as soon as something goes wrong. (exit-on-exception - (with-fluids ((*current-warning-prefix* "")) - (with-target host - (lambda () - (let ((relative (relative-file source-directory file))) - (compile-file file - #:output-file (string-append build-directory "/" - (scm->go relative)) - #:opts (append warning-options - (optimization-options relative)))))))) + (with-target host + (lambda () + (let ((relative (relative-file source-directory file))) + (compile-file file + #:output-file (string-append build-directory "/" + (scm->go relative)) + #:opts (append warning-options + (optimization-options relative))))))) (with-mutex progress-lock (set! completed (+ 1 completed)))) (with-augmented-search-path %load-path source-directory (with-augmented-search-path %load-compiled-path build-directory - ;; FIXME: To work around , we first load all - ;; of FILES. - (load-files source-directory files - #:report-load report-load - #:debug-port debug-port) - - ;; Make sure compilation related modules are loaded before starting to - ;; compile files in parallel. - (compile #f) - - ;; XXX: Don't use too many workers to work around the insane memory - ;; requirements of the compiler in Guile 2.2.2: - ;; . - (n-par-for-each (min workers 8) build files) - - (unless (zero? total) - (report-compilation #f total total))))) + (with-fluids ((*current-warning-prefix* "")) + + ;; FIXME: To work around , we first load all + ;; of FILES. + (load-files source-directory files + #:report-load report-load + #:debug-port debug-port) + + ;; Make sure compilation related modules are loaded before starting to + ;; compile files in parallel. + (compile #f) + + ;; XXX: Don't use too many workers to work around the insane memory + ;; requirements of the compiler in Guile 2.2.2: + ;; . + (n-par-for-each (min workers 8) build files) + + (unless (zero? total) + (report-compilation #f total total)))))) (eval-when (eval load) (when (and (string=? "2" (major-version)) -- cgit v1.2.3 From c2dcff41c2e47f5f978f467864d5ed7829939884 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 19 Apr 2018 12:33:25 -0400 Subject: records: Detect duplicate field initializers. * guix/records.scm (report-duplicate-field-specifier): New procedure. (make-syntactic-constructor): Call it. * tests/records.scm ("define-record-type* & duplicate initializers"): New test. Co-authored-by: Mark H Weaver --- guix/records.scm | 20 ++++++++++++++++++++ tests/records.scm | 26 +++++++++++++++++++++++++- 2 files changed, 45 insertions(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/records.scm b/guix/records.scm index 98f3c8fef0..6b3c25cefa 100644 --- a/guix/records.scm +++ b/guix/records.scm @@ -1,5 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018 Ludovic Courtès +;;; Copyright © 2018 Mark H Weaver ;;; ;;; This file is part of GNU Guix. ;;; @@ -52,6 +53,22 @@ ((weird _ ...) ;weird! (syntax-violation name "invalid field specifier" #'weird))))) +(define (report-duplicate-field-specifier name ctor) + "Report the first duplicate identifier among the bindings in CTOR." + (syntax-case ctor () + ((_ bindings ...) + (let loop ((bindings #'(bindings ...)) + (seen '())) + (syntax-case bindings () + (((field value) rest ...) + (not (memq (syntax->datum #'field) seen)) + (loop #'(rest ...) (cons (syntax->datum #'field) seen))) + ((duplicate rest ...) + (syntax-violation name "duplicate field initializer" + #'duplicate)) + (() + #t)))))) + (eval-when (expand load eval) ;; The procedures below are needed both at run time and at expansion time. @@ -169,6 +186,9 @@ of TYPE matches the expansion-time ABI." #'(field (... ...))) (wrap-field-value f (field-default-value f)))) + ;; Pass S to make sure source location info is preserved. + (report-duplicate-field-specifier 'name s) + (let ((fields (append fields (map car default-values)))) (cond ((lset= eq? fields '(expected ...)) #`(let* #,(field-bindings diff --git a/tests/records.scm b/tests/records.scm index 09ada70c2d..d9469a78bd 100644 --- a/tests/records.scm +++ b/tests/records.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2018 Ludovic Courtès +;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2018, 2019 Ludovic Courtès ;;; ;;; This file is part of GNU Guix. ;;; @@ -288,6 +288,30 @@ (and (string-match "extra.*initializer.*baz" message) (eq? proc 'foo))))) +(test-assert "define-record-type* & duplicate initializers" + (let ((exp '(begin + (define-record-type* foo make-foo + foo? + (bar foo-bar (default 42))) + + (foo (bar 1) + (bar 2)))) + (loc (current-source-location))) ;keep this alignment! + (catch 'syntax-error + (lambda () + (eval exp (test-module)) + #f) + (lambda (key proc message location form . args) + (and (string-match "duplicate.*initializer" message) + (eq? proc 'foo) + + ;; Make sure the location is that of the field specifier. + (lset= equal? + (pk 'expected-loc + `((line . ,(- (assq-ref loc 'line) 1)) + ,@(alist-delete 'line loc))) + (pk 'actual-loc location))))))) + (test-assert "ABI checks" (let ((module (test-module))) (eval '(begin -- 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') 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 @@ machine." (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 5f2daffe096de707a120ae3e6396e9244c366930 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 22 Jan 2019 22:54:04 +0100 Subject: self: System tests depend on CLI modules. This is because (gnu tests docker) depends on (guix scripts pack). * guix/self.scm (compiled-guix)[*system-test-modules*]: Add dependency on *CLI-MODULES*. --- guix/self.scm | 21 +++++++++++---------- 1 file changed, 11 insertions(+), 10 deletions(-) (limited to 'guix') diff --git a/guix/self.scm b/guix/self.scm index fea5db5da3..d1b8256802 100644 --- a/guix/self.scm +++ b/guix/self.scm @@ -621,16 +621,6 @@ Info manual." #:guile-for-build guile-for-build)) - (define *system-test-modules* - ;; Ship these modules mostly so (gnu ci) can refer to them. - (scheme-node "guix-system-tests" - `((gnu tests) - ,@(scheme-modules* source "gnu/tests")) - (list *core-package-modules* *package-modules* - *extra-modules* *system-modules* *core-modules*) - #:extensions dependencies - #:guile-for-build guile-for-build)) - (define *cli-modules* (scheme-node "guix-cli" (append (scheme-modules* source "/guix/scripts") @@ -641,6 +631,17 @@ Info manual." #:extensions dependencies #:guile-for-build guile-for-build)) + (define *system-test-modules* + ;; Ship these modules mostly so (gnu ci) can discover them. + (scheme-node "guix-system-tests" + `((gnu tests) + ,@(scheme-modules* source "gnu/tests")) + (list *core-package-modules* *package-modules* + *extra-modules* *system-modules* *core-modules* + *cli-modules*) ;for (guix scripts pack), etc. + #:extensions dependencies + #:guile-for-build guile-for-build)) + (define *config* (scheme-node "guix-config" '() -- cgit v1.2.3 From ba5e89be8cfa3428d7b41954df8af792986eb5ee Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 23 Jan 2019 22:27:29 +0100 Subject: deduplication: Ignore EMLINK. Until now 'guix offload' would fail (transient failure) upon EMLINK. * guix/store/deduplication.scm (replace-with-link) (deduplicate): Ignore EMLINK. --- guix/store/deduplication.scm | 11 ++++++++--- 1 file changed, 8 insertions(+), 3 deletions(-) (limited to 'guix') diff --git a/guix/store/deduplication.scm b/guix/store/deduplication.scm index a777940f86..8ca16a4cd8 100644 --- a/guix/store/deduplication.scm +++ b/guix/store/deduplication.scm @@ -1,6 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2017 Caleb Ristvedt -;;; Copyright © 2018 Ludovic Courtès +;;; Copyright © 2018, 2019 Ludovic Courtès ;;; ;;; This file is part of GNU Guix. ;;; @@ -109,8 +109,9 @@ Note: TARGET, TO-REPLACE, and SWAP-DIRECTORY must be on the same file system." (get-temp-link target swap-directory)) (lambda args ;; We get ENOSPC when we can't fit an additional entry in - ;; SWAP-DIRECTORY. - (if (= ENOSPC (system-error-errno args)) + ;; SWAP-DIRECTORY. If it's EMLINK, then TARGET has reached its + ;; maximum number of links. + (if (memv (system-error-errno args) `(,ENOSPC ,EMLINK)) #f (apply throw args))))) @@ -169,4 +170,8 @@ under STORE." ;; more entries in .links, but that's fine: we can ;; just stop. #f) + ((= errno EMLINK) + ;; PATH has reached the maximum number of links, but + ;; that's OK: we just can't deduplicate it more. + #f) (else (apply throw args)))))))))) -- cgit v1.2.3 From e6b065b299e1819cd35643043a63e2f1ff27418c Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 23 Jan 2019 22:30:05 +0100 Subject: ui: Don't report "build failed:" for daemon error messages. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Until now we'd get things like: guix build: error: build failed: build of `/gnu/store/….drv' failed or: $ guix gc -d /sdf guix gc: error: build failed: path `/sdf' is not in the store which is kinda ridiculous. * guix/ui.scm (call-with-error-handling): Remove "build failed:" prefix for 'store-protocol-error?'. --- guix/ui.scm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/ui.scm b/guix/ui.scm index 9ff56ea85c..9eab4ba3f7 100644 --- a/guix/ui.scm +++ b/guix/ui.scm @@ -690,7 +690,7 @@ or remove one of them from the profile.") (strerror (store-connection-error-code c)))) ((store-protocol-error? c) ;; FIXME: Server-provided error messages aren't i18n'd. - (leave (G_ "build failed: ~a~%") + (leave (G_ "~a~%") (store-protocol-error-message c))) ((derivation-missing-output-error? c) (leave (G_ "reference to invalid output '~a' of derivation '~a'~%") -- cgit v1.2.3 From da94575858971b4f95e241c4f677e0547ae971fe Mon Sep 17 00:00:00 2001 From: Ricardo Wurmus Date: Thu, 24 Jan 2019 13:21:21 +0100 Subject: licenses: Add lppl1.1+. * guix/licenses.scm (lppl1.1+): New variable. --- guix/licenses.scm | 9 +++++++-- 1 file changed, 7 insertions(+), 2 deletions(-) (limited to 'guix') diff --git a/guix/licenses.scm b/guix/licenses.scm index 4ef18fb326..4ef3ed188c 100644 --- a/guix/licenses.scm +++ b/guix/licenses.scm @@ -3,7 +3,7 @@ ;;; Copyright © 2013, 2015 Andreas Enge ;;; Copyright © 2012, 2013 Nikita Karetnikov ;;; Copyright © 2015 Mark H Weaver -;;; Copyright © 2015 Ricardo Wurmus +;;; Copyright © 2015, 2019 Ricardo Wurmus ;;; Copyright © 2016 Eric Bavier ;;; Copyright © 2016 Leo Famulari ;;; Copyright © 2016 Fabian Harfert @@ -65,7 +65,7 @@ ipa knuth lgpl2.0 lgpl2.0+ lgpl2.1 lgpl2.1+ lgpl3 lgpl3+ - lppl lppl1.0+ lppl1.2 lppl1.2+ + lppl lppl1.0+ lppl1.1+ lppl1.2 lppl1.2+ lppl1.3 lppl1.3+ lppl1.3a lppl1.3a+ lppl1.3b lppl1.3b+ @@ -421,6 +421,11 @@ at URI, which may be a file:// URI pointing the package's tree." "https://www.latex-project.org/lppl/lppl-1-0/" "LaTeX Project Public License 1.0")) +(define lppl1.1+ + (license "LPPL 1.1+" + "https://www.latex-project.org/lppl/lppl-1-1/" + "LaTeX Project Public License 1.1")) + (define lppl1.2 (license "LPPL 1.2" "http://directory.fsf.org/wiki/License:LPPLv1.2" -- cgit v1.2.3 From 2c5ee9bba4067fb0a9e68fb2af3a6e7fe36960cb Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 24 Jan 2019 19:18:10 +0100 Subject: tests: Remove duplicate field initializers. Fixes a regression introduced in c2dcff41c2e47f5f978f467864d5ed7829939884, whereby many tests in 'tests/packages.scm' would trigger a syntax error due to duplicate field intializers in forms like: (dummy-package "foo" (version "0")) * guix/tests.scm (dummy-package, dummy-origin): Rewrite to inherit from a base record. This restores the semantics from before c2dcff41c2e47f5f978f467864d5ed7829939884. * tests/services.scm ("instantiate-missing-services, indirect"): Remove duplicate 'extensions' field. --- guix/tests.scm | 19 ++++++++++--------- tests/services.scm | 4 ++-- 2 files changed, 12 insertions(+), 11 deletions(-) (limited to 'guix') diff --git a/guix/tests.scm b/guix/tests.scm index 16a426c4f9..749a4edd7a 100644 --- a/guix/tests.scm +++ b/guix/tests.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 ;;; ;;; This file is part of GNU Guix. ;;; @@ -334,18 +334,19 @@ CONTENTS." (define-syntax-rule (dummy-package name* extra-fields ...) "Return a \"dummy\" package called NAME*, with all its compulsory fields initialized with default values, and with EXTRA-FIELDS set as specified." - (package extra-fields ... - (name name*) (version "0") (source #f) - (build-system gnu-build-system) - (synopsis #f) (description #f) - (home-page #f) (license #f))) + (let ((p (package + (name name*) (version "0") (source #f) + (build-system gnu-build-system) + (synopsis #f) (description #f) + (home-page #f) (license #f)))) + (package (inherit p) extra-fields ...))) (define-syntax-rule (dummy-origin extra-fields ...) "Return a \"dummy\" origin, with all its compulsory fields initialized with default values, and with EXTRA-FIELDS set as specified." - (origin extra-fields ... - (method #f) (uri "http://www.example.com") - (sha256 (base32 (make-string 52 #\x))))) + (let ((o (origin (method #f) (uri "http://www.example.com") + (sha256 (base32 (make-string 52 #\x)))))) + (origin (inherit o) extra-fields ...))) ;; Local Variables: ;; eval: (put 'call-with-derivation-narinfo 'scheme-indent-function 1) diff --git a/tests/services.scm b/tests/services.scm index 5827dee80d..44ad0022c6 100644 --- a/tests/services.scm +++ b/tests/services.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2015, 2016, 2017, 2018 Ludovic Courtès +;;; Copyright © 2015, 2016, 2017, 2018, 2019 Ludovic Courtès ;;; ;;; This file is part of GNU Guix. ;;; @@ -143,7 +143,7 @@ (default-value 'dflt) (compose concatenate) (extend cons))) - (t2 (service-type (name 't2) (extensions '()) + (t2 (service-type (name 't2) (default-value 'dflt2) (compose concatenate) (extend cons) -- cgit v1.2.3 From bbb2bd50dcb160d8e60fc657b96f1b6739cd8d89 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 24 Jan 2019 20:48:14 +0100 Subject: records: Make 'report-duplicate-field-specifier' available at expansion-time. Fixes a regression in 'guix pack -R' introduced with commit c2dcff41c2e47f5f978f467864d5ed7829939884. The imported modules of 'c-compiler' would be compiled in this order: first (guix records), then (guix search-paths). Consequently, 'report-duplicate-field-specifier' would be reported as unbound while compiling (guix search-paths), leading to a build failure. * guix/records.scm (report-invalid-field-specifier) (report-duplicate-field-specifier): Move within 'eval-expand'. --- guix/records.scm | 54 +++++++++++++++++++++++++++--------------------------- 1 file changed, 27 insertions(+), 27 deletions(-) (limited to 'guix') diff --git a/guix/records.scm b/guix/records.scm index 6b3c25cefa..0649c90ea3 100644 --- a/guix/records.scm +++ b/guix/records.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 Mark H Weaver ;;; ;;; This file is part of GNU Guix. @@ -44,31 +44,6 @@ (format #f fmt args ...) form)))) -(define (report-invalid-field-specifier name bindings) - "Report the first invalid binding among BINDINGS." - (let loop ((bindings bindings)) - (syntax-case bindings () - (((field value) rest ...) ;good - (loop #'(rest ...))) - ((weird _ ...) ;weird! - (syntax-violation name "invalid field specifier" #'weird))))) - -(define (report-duplicate-field-specifier name ctor) - "Report the first duplicate identifier among the bindings in CTOR." - (syntax-case ctor () - ((_ bindings ...) - (let loop ((bindings #'(bindings ...)) - (seen '())) - (syntax-case bindings () - (((field value) rest ...) - (not (memq (syntax->datum #'field) seen)) - (loop #'(rest ...) (cons (syntax->datum #'field) seen))) - ((duplicate rest ...) - (syntax-violation name "duplicate field initializer" - #'duplicate)) - (() - #t)))))) - (eval-when (expand load eval) ;; The procedures below are needed both at run time and at expansion time. @@ -91,7 +66,32 @@ interface\" (ABI) for TYPE is equal to COOKIE." ;; recompiled. (throw 'record-abi-mismatch-error 'abi-check "~a: record ABI mismatch; recompilation needed" - (list #,type) '()))))) + (list #,type) '())))) + + (define (report-invalid-field-specifier name bindings) + "Report the first invalid binding among BINDINGS." + (let loop ((bindings bindings)) + (syntax-case bindings () + (((field value) rest ...) ;good + (loop #'(rest ...))) + ((weird _ ...) ;weird! + (syntax-violation name "invalid field specifier" #'weird))))) + + (define (report-duplicate-field-specifier name ctor) + "Report the first duplicate identifier among the bindings in CTOR." + (syntax-case ctor () + ((_ bindings ...) + (let loop ((bindings #'(bindings ...)) + (seen '())) + (syntax-case bindings () + (((field value) rest ...) + (not (memq (syntax->datum #'field) seen)) + (loop #'(rest ...) (cons (syntax->datum #'field) seen))) + ((duplicate rest ...) + (syntax-violation name "duplicate field initializer" + #'duplicate)) + (() + #t))))))) (define-syntax make-syntactic-constructor (syntax-rules () -- cgit v1.2.3 From 3e223a22a70138b8c57e742ad8ec737131249820 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 25 Jan 2019 10:05:31 +0100 Subject: packages: Add 'package-closure'. * guix/packages.scm (package-closure): New procedure. * tests/packages.scm ("package-closure"): New test. --- guix/packages.scm | 25 ++++++++++++++++++++++++- tests/packages.scm | 23 +++++++++++++++++++++++ 2 files changed, 47 insertions(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/packages.scm b/guix/packages.scm index e4c2ac3be5..f191327718 100644 --- a/guix/packages.scm +++ b/guix/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 ;;; Copyright © 2014, 2015, 2017, 2018 Mark H Weaver ;;; Copyright © 2015 Eric Bavier ;;; Copyright © 2016 Alex Kost @@ -133,6 +133,7 @@ bag-transitive-host-inputs bag-transitive-build-inputs bag-transitive-target-inputs + package-closure default-guile default-guile-derivation @@ -798,6 +799,28 @@ dependencies are known to build on SYSTEM." "Return the \"target inputs\" of BAG, recursively." (transitive-inputs (bag-target-inputs bag))) +(define* (package-closure packages #:key (system (%current-system))) + "Return the closure of PACKAGES on SYSTEM--i.e., PACKAGES and the list of +packages they depend on, recursively." + (let loop ((packages packages) + (visited vlist-null) + (closure (list->setq packages))) + (match packages + (() + (set->list closure)) + ((package . rest) + (if (vhash-assq package visited) + (loop rest visited closure) + (let* ((bag (package->bag package system)) + (dependencies (filter-map (match-lambda + ((label (? package? package) . _) + package) + (_ #f)) + (bag-direct-inputs bag)))) + (loop (append dependencies rest) + (vhash-consq package #t visited) + (fold set-insert closure dependencies)))))))) + (define* (package-mapping proc #:optional (cut? (const #f))) "Return a procedure that, given a package, applies PROC to all the packages depended on and returns the resulting package. The procedure stops recursion diff --git a/tests/packages.scm b/tests/packages.scm index 29e5e4103c..e5704ae4b9 100644 --- a/tests/packages.scm +++ b/tests/packages.scm @@ -249,6 +249,28 @@ (package-transitive-supported-systems d) (package-transitive-supported-systems e)))) +(test-assert "package-closure" + (let-syntax ((dummy-package/no-implicit + (syntax-rules () + ((_ name rest ...) + (package + (inherit (dummy-package name rest ...)) + (build-system trivial-build-system)))))) + (let* ((a (dummy-package/no-implicit "a")) + (b (dummy-package/no-implicit "b" + (propagated-inputs `(("a" ,a))))) + (c (dummy-package/no-implicit "c" + (inputs `(("a" ,a))))) + (d (dummy-package/no-implicit "d" + (native-inputs `(("b" ,b))))) + (e (dummy-package/no-implicit "e" + (inputs `(("c" ,c) ("d" ,d)))))) + (lset= eq? + (list a b c d e) + (package-closure (list e)) + (package-closure (list e d)) + (package-closure (list e c b)))))) + (test-equal "origin-actual-file-name" "foo-1.tar.gz" (let ((o (dummy-origin (uri "http://www.example.com/foo-1.tar.gz")))) @@ -1180,4 +1202,5 @@ ;;; Local Variables: ;;; eval: (put 'dummy-package 'scheme-indent-function 1) +;;; eval: (put 'dummy-package/no-implicit 'scheme-indent-function 1) ;;; End: -- 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') 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 @@ (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') 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 @@ the latest known version of ~a (~a)~%") (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') 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 @@ the latest known version of ~a (~a)~%") (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') 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 @@ #: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 @@ #: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 @@ Report the availability of substitutes.\n")) -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 @@ Report the availability of substitutes.\n")) (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 @@ Report the availability of substitutes.\n")) (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 @@ Report the availability of substitutes.\n")) (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 7d2be1277b44de9d0528d9d3015443b40cb3b104 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 28 Jan 2019 15:41:12 +0100 Subject: packages: 'package-input-rewriting' can take a promise. * guix/packages.scm (package-input-rewriting): Allow REPLACEMENTS to be a promise. * gnu/packages/guile.scm (package-for-guile-2.0): Delay the first argument to 'package-input-rewriting'. --- gnu/packages/guile.scm | 2 +- guix/packages.scm | 16 ++++++++++++---- 2 files changed, 13 insertions(+), 5 deletions(-) (limited to 'guix') diff --git a/gnu/packages/guile.scm b/gnu/packages/guile.scm index 869fec97bd..5f5d59da47 100644 --- a/gnu/packages/guile.scm +++ b/gnu/packages/guile.scm @@ -391,7 +391,7 @@ GNU@tie{}Guile. Use the @code{(ice-9 readline)} module and call its (define package-for-guile-2.0 ;; A procedure that rewrites the dependency tree of the given package to use ;; GUILE-2.0 instead of GUILE-2.2. - (package-input-rewriting `((,guile-2.2 . ,guile-2.0)) + (package-input-rewriting (delay `((,guile-2.2 . ,guile-2.0))) (guile-variant-package-name "guile2.0"))) (define-public guile-for-guile-emacs diff --git a/guix/packages.scm b/guix/packages.scm index f191327718..8515bb7c6f 100644 --- a/guix/packages.scm +++ b/guix/packages.scm @@ -855,19 +855,27 @@ when CUT? returns true for a given package." #:optional (rewrite-name identity)) "Return a procedure that, when passed a package, replaces its direct and indirect dependencies (but not its implicit inputs) according to REPLACEMENTS. -REPLACEMENTS is a list of package pairs; the first element of each pair is the -package to replace, and the second one is the replacement. +REPLACEMENTS is a list of package pairs or a promise thereof; the first +element of each pair is the package to replace, and the second one is the +replacement. Optionally, REWRITE-NAME is a one-argument procedure that takes the name of a package and returns its new name after rewrite." (define (rewrite p) - (match (assq-ref replacements p) + (match (assq-ref (if (promise? replacements) + (force replacements) + replacements) + p) (#f (package (inherit p) (name (rewrite-name (package-name p))))) (new new))) - (package-mapping rewrite (cut assq <> replacements))) + (package-mapping rewrite + (lambda (package) + (assq package (if (promise? replacements) + (force replacements) + replacements))))) (define-syntax-rule (package/inherit p overrides ...) "Like (package (inherit P) OVERRIDES ...), except that the same -- cgit v1.2.3 From 3a8c4860fbccc840b28227dbe44cfffb128a91e0 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 28 Jan 2019 22:42:48 +0100 Subject: channels: Turn off deprecation warnings when loading 'build-self.scm'. * guix/channels.scm (build-from-source): Parameterize DEPRECATION-WARNING-PORT when loading SCRIPT. --- guix/channels.scm | 8 +++++++- 1 file changed, 7 insertions(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/channels.scm b/guix/channels.scm index 10345c1ce5..f386d18b74 100644 --- a/guix/channels.scm +++ b/guix/channels.scm @@ -27,6 +27,7 @@ #:use-module (guix profiles) #:use-module (guix derivations) #:use-module (guix combinators) + #:use-module (guix deprecation) #:use-module (guix store) #:use-module (guix i18n) #:use-module ((guix utils) @@ -275,7 +276,12 @@ package modules under SOURCE using CORE, an instance of Guix." (if (file-exists? script) (let ((build (save-module-excursion (lambda () - (primitive-load script))))) + ;; Disable deprecation warnings; it's OK for SCRIPT to + ;; use deprecated APIs and the user doesn't have to know + ;; about it. + (parameterize ((deprecation-warning-port + (%make-void-port "w"))) + (primitive-load script)))))) ;; BUILD must be a monadic procedure of at least one argument: the ;; source tree. ;; -- 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') 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 @@ true, display what would be built without actually building it." (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 f674bc6620ec2aad35dad455c55fd7dea79236e2 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 29 Jan 2019 11:58:50 +0100 Subject: channels: Do not offload package cache derivation. * guix/channels.scm (package-cache-file): Pass #:local-build? to 'gexp->derivation-in-inferior'. --- guix/channels.scm | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/channels.scm b/guix/channels.scm index f386d18b74..96d62ce062 100644 --- a/guix/channels.scm +++ b/guix/channels.scm @@ -478,7 +478,8 @@ be used as a profile hook." (gexp->derivation-in-inferior "guix-package-cache" build profile #:properties '((type . profile-hook) - (hook . package-cache))))) + (hook . package-cache)) + #:local-build? #t))) (define %channel-profile-hooks ;; The default channel profile hooks. -- cgit v1.2.3 From 976ef2d97887d16eab8d4eb9dad811786b04d690 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sun, 27 Jan 2019 22:10:13 +0100 Subject: status: Record more information about builds. * guix/status.scm (): New record type. (build, matching-build): New procedures. (compute-status): Adjust to manipulate records instead of derivation file names in 'build-status-builds-completed' and 'build-status-building'. (build-event-output-port)[process-line]: Use 'string-split' to preserve spaces. * tests/status.scm ("compute-status, builds + substitutes") ("compute-status, missing events"): Adjust to expect records. Produce complete "build-started" events. ("compute-status, multiplexed build output"): Likewise, and remove "bar.drv" from 'builds-completed'. --- guix/status.scm | 76 +++++++++++++++++++++++++++++++++++++++++++------------- tests/status.scm | 28 +++++++++++---------- 2 files changed, 74 insertions(+), 30 deletions(-) (limited to 'guix') diff --git a/guix/status.scm b/guix/status.scm index 93e119bed1..0a5ff59236 100644 --- a/guix/status.scm +++ b/guix/status.scm @@ -50,6 +50,11 @@ build-status-builds-completed build-status-downloads-completed + build? + build + build-derivation + build-system + download? download download-item @@ -85,15 +90,28 @@ ;; Builds and substitutions performed by the daemon. (define-record-type* build-status make-build-status build-status? - (building build-status-building ;list of drv + (building build-status-building ;list of (default '())) (downloading build-status-downloading ;list of (default '())) - (builds-completed build-status-builds-completed ;list of drv + (builds-completed build-status-builds-completed ;list of (default '())) - (downloads-completed build-status-downloads-completed ;list of store items + (downloads-completed build-status-downloads-completed ;list of (default '()))) +;; On-going or completed build. +(define-record-type + (%build derivation id system log-file) + build? + (derivation build-derivation) ;string (.drv file name) + (id build-id) ;#f | integer + (system build-system) ;string + (log-file build-log-file)) ;#f | string + +(define* (build derivation system #:key id log-file) + "Return a new build." + (%build derivation id system log-file)) + ;; On-going or completed downloads. Downloads can be stem from substitutes ;; and from "builtin:download" fixed-output derivations. (define-record-type @@ -113,6 +131,11 @@ "Return a new download." (%download item uri size start end transferred)) +(define (matching-build drv) + "Return a predicate that matches builds of DRV." + (lambda (build) + (string=? drv (build-derivation build)))) + (define (matching-download item) "Return a predicate that matches downloads of ITEM." (lambda (download) @@ -126,15 +149,29 @@ "Given EVENT, a tuple like (build-started \"/gnu/store/...-foo.drv\" ...), compute a new status based on STATUS." (match event - (('build-started drv _ ...) - (build-status - (inherit status) - (building (cons drv (build-status-building status))))) + (('build-started drv "-" system log-file . rest) + (let ((build (build drv system + #:id (match rest + ((pid . _) (string->number pid)) + (_ #f)) + #:log-file (if (string-null? log-file) + #f + log-file)))) + (build-status + (inherit status) + (building (cons build (build-status-building status)))))) (((or 'build-succeeded 'build-failed) drv _ ...) - (build-status - (inherit status) - (building (delete drv (build-status-building status))) - (builds-completed (cons drv (build-status-builds-completed status))))) + (let ((build (find (matching-build drv) + (build-status-building status)))) + ;; If BUILD is #f, this may be because DRV corresponds to a + ;; fixed-output derivation that is listed as a download. + (if build + (build-status + (inherit status) + (building (delq build (build-status-building status))) + (builds-completed + (cons build (build-status-builds-completed status)))) + status))) ;; Note: Ignore 'substituter-started' and 'substituter-succeeded' because ;; they're not as informative as 'download-started' and @@ -146,10 +183,11 @@ compute a new status based on STATUS." ;; because ITEM is different from DRV's output. (build-status (inherit status) - (building (remove (lambda (drv) - (equal? (false-if-exception - (derivation-path->output-path drv)) - item)) + (building (remove (lambda (build) + (let ((drv (build-derivation build))) + (equal? (false-if-exception + (derivation-path->output-path drv)) + item))) (build-status-building status))) (downloading (cons (download item uri #:size size #:start (current-time time-monotonic)) @@ -394,7 +432,7 @@ addition to build events." (N_ "The following build is still in progress:~%~{ ~a~%~}~%" "The following builds are still in progress:~%~{ ~a~%~}~%" (length ongoing)) - ongoing)))) + (map build-derivation ongoing))))) (('build-failed drv . _) (format port (failure (G_ "build of ~a failed")) drv) (newline port) @@ -570,7 +608,11 @@ The second return value is a thunk to retrieve the current state." (define (process-line line) (cond ((string-prefix? "@ " line) - (match (string-tokenize (string-drop line 2)) + ;; Note: Drop the trailing \n, and use 'string-split' to preserve + ;; spaces (the log file part of 'build-started' events can be the + ;; empty string.) + (match (string-split (string-drop (string-drop-right line 1) 2) + #\space) (("build-log" (= string->number pid) (= string->number len)) (set! %build-output-pid pid) (set! %build-output '()) diff --git a/tests/status.scm b/tests/status.scm index 08a3153218..e3ea768968 100644 --- a/tests/status.scm +++ b/tests/status.scm @@ -36,18 +36,18 @@ (test-equal "compute-status, builds + substitutes" (list (build-status - (building '("foo.drv")) + (building (list (build "foo.drv" "x86_64-linux"))) (downloading (list (download "bar" "http://example.org/bar" #:size 500 #:start 'now)))) (build-status - (building '("foo.drv")) + (building (list (build "foo.drv" "x86_64-linux"))) (downloading (list (download "bar" "http://example.org/bar" #:size 500 #:transferred 42 #:start 'now)))) (build-status - (builds-completed '("foo.drv")) + (builds-completed (list (build "foo.drv" "x86_64-linux"))) (downloads-completed (list (download "bar" "http://example.org/bar" #:size 500 #:transferred 500 @@ -58,7 +58,7 @@ (compute-status event status #:current-time (const 'now)))))) - (display "@ build-started foo.drv\n" port) + (display "@ build-started foo.drv - x86_64-linux \n" port) (display "@ substituter-started bar\n" port) (display "@ download-started bar http://example.org/bar 500\n" port) (display "various\nthings\nget\nwritten\n" port) @@ -76,7 +76,8 @@ (test-equal "compute-status, missing events" (list (build-status - (building '("foo.drv")) + (building (list (build "foo.drv" "x86_64-linux" + #:log-file "foo.log"))) (downloading (list (download "baz" "http://example.org/baz" #:size 500 #:transferred 42 @@ -86,7 +87,8 @@ #:transferred 0 #:start 'now)))) (build-status - (builds-completed '("foo.drv")) + (builds-completed (list (build "foo.drv" "x86_64-linux" + #:log-file "foo.log"))) (downloads-completed (list (download "baz" "http://example.org/baz" #:size 500 #:transferred 500 @@ -103,7 +105,7 @@ (compute-status event status #:current-time (const 'now)))))) - (display "@ build-started foo.drv\n" port) + (display "@ build-started foo.drv - x86_64-linux foo.log\n" port) (display "@ download-started bar http://example.org/bar 999\n" port) (display "various\nthings\nget\nwritten\n" port) (display "@ download-progress baz http://example.org/baz 500 42\n" @@ -136,19 +138,19 @@ (test-equal "compute-status, multiplexed build output" (list (build-status - (building '("foo.drv")) + (building (list (build "foo.drv" "x86_64-linux" #:id 121))) (downloading (list (download "bar" "http://example.org/bar" #:size 999 #:start 'now)))) (build-status - (building '("foo.drv")) + (building (list (build "foo.drv" "x86_64-linux" #:id 121))) (downloading (list (download "bar" "http://example.org/bar" #:size 999 #:transferred 42 #:start 'now)))) (build-status - ;; XXX: Should "bar.drv" be present twice? - (builds-completed '("bar.drv" "foo.drv")) + ;; "bar" is now only listed as a download. + (builds-completed (list (build "foo.drv" "x86_64-linux" #:id 121))) (downloads-completed (list (download "bar" "http://example.org/bar" #:size 999 #:transferred 999 @@ -162,8 +164,8 @@ #:derivation-path->output-path (match-lambda ("bar.drv" "bar"))))))) - (display "@ build-started foo.drv 121\n" port) - (display "@ build-started bar.drv 144\n" port) + (display "@ build-started foo.drv - x86_64-linux 121\n" port) + (display "@ build-started bar.drv - armhf-linux bar.log 144\n" port) (display "@ build-log 121 6\nHello!" port) (display "@ build-log 144 50 @ download-started bar http://example.org/bar 999\n" port) -- cgit v1.2.3 From 73a8681a16869a2b3a9da1c7ba9434e07a204e19 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sun, 27 Jan 2019 22:33:16 +0100 Subject: status: Keep track of build completion as reported by build tools. * guix/status.scm ()[completion]: New field. (build): Add #:completion parameter. (%percentage-line-rx, %fraction-line-rx): New variables. (update-build): New procedure. (compute-status): Add 'build-log' case. * tests/status.scm ("compute-status, build completion"): New test. --- guix/status.scm | 62 ++++++++++++++++++++++++++++++++++++++++++++++++++++---- tests/status.scm | 31 ++++++++++++++++++++++++++++ 2 files changed, 89 insertions(+), 4 deletions(-) (limited to 'guix') diff --git a/guix/status.scm b/guix/status.scm index 0a5ff59236..0435d14d6a 100644 --- a/guix/status.scm +++ b/guix/status.scm @@ -101,16 +101,17 @@ ;; On-going or completed build. (define-record-type - (%build derivation id system log-file) + (%build derivation id system log-file completion) build? (derivation build-derivation) ;string (.drv file name) (id build-id) ;#f | integer (system build-system) ;string - (log-file build-log-file)) ;#f | string + (log-file build-log-file) ;#f | string + (completion build-completion)) ;#f | integer (percentage) -(define* (build derivation system #:key id log-file) +(define* (build derivation system #:key id log-file completion) "Return a new build." - (%build derivation id system log-file)) + (%build derivation id system log-file completion)) ;; On-going or completed downloads. Downloads can be stem from substitutes ;; and from "builtin:download" fixed-output derivations. @@ -141,6 +142,57 @@ (lambda (download) (string=? item (download-item download)))) +(define %percentage-line-rx + ;; Things like CMake write lines like "[ 10%] gcc -c …". This regexp + ;; matches them. + (make-regexp "^[[:space:]]*\\[ *([0-9]+)%\\]")) + +(define %fraction-line-rx + ;; The 'compiled-modules' derivations and Ninja produce reports like + ;; "[ 1/32]" at the beginning of each line, while GHC prints "[ 6 of 45]". + ;; This regexp matches these. + (make-regexp "^[[:space:]]*\\[ *([0-9]+) *(/|of) *([0-9]+)\\]")) + +(define (update-build status id line) + "Update STATUS based on LINE, a build output line for ID that might contain +a completion indication." + (define (set-completion b %) + (build (build-derivation b) + (build-system b) + #:id (build-id b) + #:log-file (build-log-file b) + #:completion %)) + + (define (find-build) + (find (lambda (build) + (and (build-id build) + (= (build-id build) id))) + (build-status-building status))) + + (define (update %) + (let ((build (find-build))) + (build-status + (inherit status) + (building (cons (set-completion build %) + (delq build (build-status-building status))))))) + + (cond ((string-any #\nul line) + ;; Don't try to match a regexp here. + status) + ((regexp-exec %percentage-line-rx line) + => + (lambda (match) + (let ((% (string->number (match:substring match 1)))) + (update %)))) + ((regexp-exec %fraction-line-rx line) + => + (lambda (match) + (let ((done (string->number (match:substring match 1))) + (total (string->number (match:substring match 3)))) + (update (* 100. (/ done total)))))) + (else + status))) + (define* (compute-status event status #:key (current-time current-time) @@ -242,6 +294,8 @@ compute a new status based on STATUS." (current-time time-monotonic)) #:transferred transferred) downloads))))) + (('build-log (? integer? pid) line) + (update-build status pid line)) (_ status))) diff --git a/tests/status.scm b/tests/status.scm index e3ea768968..f3afadfcd0 100644 --- a/tests/status.scm +++ b/tests/status.scm @@ -180,4 +180,35 @@ (display "@ build-succeeded bar.drv\n" port) (list first second (get-status)))))) +(test-equal "compute-status, build completion" + (list (build-status + (building (list (build "foo.drv" "x86_64-linux" #:id 121)))) + (build-status + (building (list (build "foo.drv" "x86_64-linux" #:id 121 + #:completion 0.)))) + (build-status + (building (list (build "foo.drv" "x86_64-linux" #:id 121 + #:completion 50.)))) + (build-status + (builds-completed (list (build "foo.drv" "x86_64-linux" #:id 121 + #:completion 100.))))) + (let-values (((port get-status) + (build-event-output-port (lambda (event status) + (compute-status event status + #:current-time + (const 'now)))))) + (display "@ build-started foo.drv - x86_64-linux 121\n" port) + (display "@ build-log 121 6\nHello!" port) + (let ((first (get-status))) + (display "@ build-log 121 20\n[ 0/100] building X\n" port) + (display "@ build-log 121 6\nHello!" port) + (let ((second (get-status))) + (display "@ build-log 121 20\n[50/100] building Y\n" port) + (display "@ build-log 121 6\nHello!" port) + (let ((third (get-status))) + (display "@ build-log 121 21\n[100/100] building Z\n" port) + (display "@ build-log 121 6\nHello!" port) + (display "@ build-succeeded foo.drv\n" port) + (list first second third (get-status))))))) + (test-end "status") -- cgit v1.2.3 From 3854c6429c648df5b5ab23f871de9ec3c466f61b Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sun, 27 Jan 2019 22:44:34 +0100 Subject: status: Print a progress bar for on-going builds when possible. * guix/status.scm (print-build-event)[report-build-progress]: New procedure. [print-log-line]: Add ID parameter. Call 'report-build-progress' when appropriate. Adjust callers. --- guix/status.scm | 27 +++++++++++++++++++++------ 1 file changed, 21 insertions(+), 6 deletions(-) (limited to 'guix') diff --git a/guix/status.scm b/guix/status.scm index 0435d14d6a..e3375816c5 100644 --- a/guix/status.scm +++ b/guix/status.scm @@ -441,14 +441,29 @@ addition to build events." (cut colorize-string <> 'RED 'BOLD) identity)) + (define (report-build-progress %) + (let ((% (min (max % 0) 100))) ;sanitize + (erase-current-line port) + (format port "~3d% " (inexact->exact (round %))) + (display (progress-bar % (- (current-terminal-columns) 5)) + port) + (force-output port))) + (define print-log-line (if print-log? (if colorize? - (lambda (line) + (lambda (id line) (display (colorize-log-line line) port)) - (cut display <> port)) - (lambda (line) - (spin! port)))) + (lambda (id line) + (display line port))) + (lambda (id line) + (match (build-status-building status) + ((build) ;single job + (match (build-completion build) + ((? number? %) (report-build-progress %)) + (_ (spin! port)))) + (_ + (spin! port)))))) (unless print-log? (display "\r" port)) ;erase the spinner @@ -552,7 +567,7 @@ addition to build events." ;; through. (display line port) (force-output port)) - (print-log-line line)) + (print-log-line pid line)) (cond ((string-prefix? "substitute: " line) ;; The daemon prefixes early messages coming with 'guix ;; substitute' with "substitute:". These are useful ("updating @@ -565,7 +580,7 @@ addition to build events." (display (info (string-trim-right line)) port) (newline)) (else - (print-log-line line))))) + (print-log-line pid line))))) (_ event))) -- cgit v1.2.3 From 35dcaa119e2b24343e76aa2a4213a3cc1fb69049 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sun, 27 Jan 2019 18:15:05 +0100 Subject: self: Produce progress reports compatible with (guix status). * guix/self.scm (compiled-modules)[build](report-load) (report-compilation): Write "[M/N]" progress reports. Use line-buffering. --- guix/self.scm | 18 ++++++++++++++---- 1 file changed, 14 insertions(+), 4 deletions(-) (limited to 'guix') diff --git a/guix/self.scm b/guix/self.scm index d1b8256802..f028bdbfdd 100644 --- a/guix/self.scm +++ b/guix/self.scm @@ -856,13 +856,23 @@ containing MODULE-FILES and possibly other files as well." (define (report-load file total completed) (display #\cr) (format #t - "loading...\t~5,1f% of ~d files" ;FIXME: i18n + "[~3@a/~3@a] loading...\t~5,1f% of ~d files" + + ;; Note: Multiply TOTAL by two to account for the + ;; compilation phase that follows. + completed (* total 2) + (* 100. (/ completed total)) total) (force-output)) (define (report-compilation file total completed) (display #\cr) - (format #t "compiling...\t~5,1f% of ~d files" ;FIXME: i18n + (format #t "[~3@a/~3@a] compiling...\t~5,1f% of ~d files" + + ;; Add TOTAL to account for the load phase that came + ;; before. + (+ total completed) (* total 2) + (* 100. (/ completed total)) total) (force-output)) @@ -874,8 +884,8 @@ containing MODULE-FILES and possibly other files as well." #:report-load report-load #:report-compilation report-compilation))) - (setvbuf (current-output-port) 'none) - (setvbuf (current-error-port) 'none) + (setvbuf (current-output-port) 'line) + (setvbuf (current-error-port) 'line) (set! %load-path (cons #+module-tree %load-path)) (set! %load-path -- 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') 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 @@ (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') 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 @@ processed, #f otherwise." (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 From f6fe7da3721070f81a4b0378285cb6398b935c52 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 1 Feb 2019 19:25:38 +0100 Subject: profiles: 'manual-database' hook reports progress. * guix/profiles.scm (manual-database)[build](compute-entries): Write a progress report. --- guix/profiles.scm | 25 ++++++++++++++++++------- 1 file changed, 18 insertions(+), 7 deletions(-) (limited to 'guix') diff --git a/guix/profiles.scm b/guix/profiles.scm index 598e0acf62..efe5ecb9dc 100644 --- a/guix/profiles.scm +++ b/guix/profiles.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, 2016 Alex Kost ;;; Copyright © 2015 Mark H Weaver @@ -1300,12 +1300,22 @@ the entries in MANIFEST." (srfi srfi-19)) (define (compute-entries) - (append-map (lambda (directory) - (let ((man (string-append directory "/share/man"))) - (if (directory-exists? man) - (mandb-entries man) - '()))) - '#$(manifest-inputs manifest))) + ;; This is the most expensive part (I/O and CPU, due to + ;; decompression), so report progress as we traverse INPUTS. + (let* ((inputs '#$(manifest-inputs manifest)) + (total (length inputs))) + (append-map (lambda (directory count) + (format #t "\r[~3d/~3d] building list of \ +man-db entries..." + count total) + (force-output) + (let ((man (string-append directory + "/share/man"))) + (if (directory-exists? man) + (mandb-entries man) + '()))) + inputs + (iota total 1)))) (define man-directory (string-append #$output "/share/man")) @@ -1320,6 +1330,7 @@ the entries in MANIFEST." "/index.db") entries)) (duration (time-difference (current-time) start))) + (newline) (format #t "~a entries processed in ~,1f s~%" (length entries) (+ (time-second duration) -- cgit v1.2.3 From a87d66f371da2a84d7bba1cae58b71c9c9af73aa Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sun, 3 Feb 2019 22:10:06 +0100 Subject: daemon: Rename 'NIX_STATE_DIR' and 'NIX_DB_DIR' environment variables. Fixes . Reported by Jeff Mickey . * guix/config.scm.in (%state-directory): Change NIX_STATE_DIR to GUIX_STATE_DIRECTORY. (%store-database-directory): Change NIX_DB_DIR to GUIX_DATABASE_DIRECTORY. * nix/libstore/globals.cc (Settings::processEnvironment): Likewise. * guix/self.scm (make-config.scm): Likewise. * build-aux/build-self.scm (make-config.scm): Likewise. * build-aux/test-env.in: Likewise. * tests/derivations.scm ("derivation #:leaked-env-vars"): Likewise. * tests/guix-build.sh (GUIX_DAEMON_SOCKET): Likewise. * tests/guix-daemon.sh (socket): Likewise. --- build-aux/build-self.scm | 4 ++-- build-aux/test-env.in | 22 +++++++++++----------- guix/config.scm.in | 6 +++--- guix/self.scm | 4 ++-- nix/libstore/globals.cc | 6 +++--- tests/derivations.scm | 15 ++++++++------- tests/guix-build.sh | 4 ++-- tests/guix-daemon.sh | 2 +- 8 files changed, 32 insertions(+), 31 deletions(-) (limited to 'guix') diff --git a/build-aux/build-self.scm b/build-aux/build-self.scm index f70c3d91ff..d18b4504cf 100644 --- a/build-aux/build-self.scm +++ b/build-aux/build-self.scm @@ -114,11 +114,11 @@ (define %state-directory ;; This must match `NIX_STATE_DIR' as defined in ;; `nix/local.mk'. - (or (getenv "NIX_STATE_DIR") + (or (getenv "GUIX_STATE_DIRECTORY") (string-append %localstatedir "/guix"))) (define %store-database-directory - (or (getenv "NIX_DB_DIR") + (or (getenv "GUIX_DATABASE_DIRECTORY") (string-append %state-directory "/db"))) (define %config-directory diff --git a/build-aux/test-env.in b/build-aux/test-env.in index aaadcf205b..b1470bb953 100644 --- a/build-aux/test-env.in +++ b/build-aux/test-env.in @@ -1,7 +1,7 @@ #!/bin/sh # 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. # @@ -51,19 +51,19 @@ then NIX_STORE_DIR="`cd "@GUIX_TEST_ROOT@/store"; pwd -P`" NIX_LOCALSTATE_DIR="@GUIX_TEST_ROOT@/var" - NIX_LOG_DIR="@GUIX_TEST_ROOT@/var/log/guix" - NIX_DB_DIR="@GUIX_TEST_ROOT@/db" + GUIX_LOG_DIRECTORY="@GUIX_TEST_ROOT@/var/log/guix" + GUIX_DATABASE_DIRECTORY="@GUIX_TEST_ROOT@/db" NIX_ROOT_FINDER="@abs_top_builddir@/nix/scripts/list-runtime-roots" # Choose a PID-dependent name to allow for parallel builds. Note # that the directory name must be chosen so that the socket's file # name is less than 108-char long (the size of `sun_path' in glibc). # Currently, in Nix builds, we're at ~106 chars... - NIX_STATE_DIR="@GUIX_TEST_ROOT@/var/$$" + GUIX_STATE_DIRECTORY="@GUIX_TEST_ROOT@/var/$$" # We can't exit when we reach the limit, because perhaps the test doesn't # actually rely on the daemon, but at least warn. - if test "`echo -n "$NIX_STATE_DIR/daemon-socket/socket" | wc -c`" -ge 108 + if test "`echo -n "$GUIX_STATE_DIRECTORY/daemon-socket/socket" | wc -c`" -ge 108 then echo "warning: exceeding socket file name limit; test may fail!" >&2 fi @@ -82,22 +82,22 @@ then fi # A place to store data of the substituter. - GUIX_BINARY_SUBSTITUTE_URL="file://$NIX_STATE_DIR/substituter-data" - rm -rf "$NIX_STATE_DIR/substituter-data" - mkdir -p "$NIX_STATE_DIR/substituter-data" + GUIX_BINARY_SUBSTITUTE_URL="file://$GUIX_STATE_DIRECTORY/substituter-data" + rm -rf "$GUIX_STATE_DIRECTORY/substituter-data" + mkdir -p "$GUIX_STATE_DIRECTORY/substituter-data" # For a number of tests, we want to allow unsigned narinfos, for # simplicity. GUIX_ALLOW_UNAUTHENTICATED_SUBSTITUTES=yes # Place for the substituter's cache. - XDG_CACHE_HOME="$NIX_STATE_DIR/cache-$$" + XDG_CACHE_HOME="$GUIX_STATE_DIRECTORY/cache-$$" # For the (guix import snix) tests. NIXPKGS="@NIXPKGS@" export NIX_IGNORE_SYMLINK_STORE NIX_STORE_DIR \ - NIX_LOCALSTATE_DIR NIX_LOG_DIR NIX_STATE_DIR NIX_DB_DIR \ + NIX_LOCALSTATE_DIR GUIX_LOG_DIRECTORY GUIX_STATE_DIRECTORY GUIX_DATABASE_DIRECTORY \ NIX_ROOT_FINDER GUIX_BINARY_SUBSTITUTE_URL \ GUIX_ALLOW_UNAUTHENTICATED_SUBSTITUTES \ GUIX_CONFIGURATION_DIRECTORY XDG_CACHE_HOME NIXPKGS @@ -109,7 +109,7 @@ then --substitute-urls="$GUIX_BINARY_SUBSTITUTE_URL" & daemon_pid=$! - trap "kill $daemon_pid ; rm -rf $NIX_STATE_DIR" EXIT + trap "kill $daemon_pid ; rm -rf $GUIX_STATE_DIRECTORY" EXIT # The test suite expects the 'guile-bootstrap' package to be available. # Normally the Guile bootstrap tarball is downloaded by a fixed-output diff --git a/guix/config.scm.in b/guix/config.scm.in index 1a761b912e..d2ec9921c6 100644 --- a/guix/config.scm.in +++ b/guix/config.scm.in @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2018 Ludovic Courtès +;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2018, 2019 Ludovic Courtès ;;; Copyright © 2017 Caleb Ristvedt ;;; ;;; This file is part of GNU Guix. @@ -73,11 +73,11 @@ (define %state-directory ;; This must match `NIX_STATE_DIR' as defined in `nix/local.mk'. - (or (getenv "NIX_STATE_DIR") + (or (getenv "GUIX_STATE_DIRECTORY") (string-append %localstatedir "/guix"))) (define %store-database-directory - (or (getenv "NIX_DB_DIR") + (or (getenv "GUIX_DATABASE_DIRECTORY") (string-append %state-directory "/db"))) (define %config-directory diff --git a/guix/self.scm b/guix/self.scm index f028bdbfdd..68f5641fec 100644 --- a/guix/self.scm +++ b/guix/self.scm @@ -786,11 +786,11 @@ Info manual." (define %state-directory ;; This must match `NIX_STATE_DIR' as defined in ;; `nix/local.mk'. - (or (getenv "NIX_STATE_DIR") + (or (getenv "GUIX_STATE_DIRECTORY") (string-append %localstatedir "/guix"))) (define %store-database-directory - (or (getenv "NIX_DB_DIR") + (or (getenv "GUIX_DATABASE_DIRECTORY") (string-append %state-directory "/db"))) (define %config-directory diff --git a/nix/libstore/globals.cc b/nix/libstore/globals.cc index 25f80da2dd..ac92971887 100644 --- a/nix/libstore/globals.cc +++ b/nix/libstore/globals.cc @@ -67,9 +67,9 @@ void Settings::processEnvironment() { nixStore = canonPath(getEnv("NIX_STORE_DIR", getEnv("NIX_STORE", NIX_STORE_DIR))); nixDataDir = canonPath(getEnv("NIX_DATA_DIR", NIX_DATA_DIR)); - nixLogDir = canonPath(getEnv("NIX_LOG_DIR", NIX_LOG_DIR)); - nixStateDir = canonPath(getEnv("NIX_STATE_DIR", NIX_STATE_DIR)); - nixDBPath = getEnv("NIX_DB_DIR", nixStateDir + "/db"); + nixLogDir = canonPath(getEnv("GUIX_LOG_DIRECTORY", NIX_LOG_DIR)); + nixStateDir = canonPath(getEnv("GUIX_STATE_DIRECTORY", NIX_STATE_DIR)); + nixDBPath = getEnv("GUIX_DATABASE_DIRECTORY", nixStateDir + "/db"); nixConfDir = canonPath(getEnv("GUIX_CONFIGURATION_DIRECTORY", GUIX_CONFIGURATION_DIRECTORY)); nixLibexecDir = canonPath(getEnv("NIX_LIBEXEC_DIR", NIX_LIBEXEC_DIR)); nixBinDir = canonPath(getEnv("NIX_BIN_DIR", NIX_BIN_DIR)); diff --git a/tests/derivations.scm b/tests/derivations.scm index c0601c0e88..dbb5b584eb 100644 --- a/tests/derivations.scm +++ b/tests/derivations.scm @@ -650,18 +650,19 @@ (build-derivations %store (list drv)) #f))) -;; Here we should get the value of $NIX_STATE_DIR that the daemon sees, which -;; is a unique value for each test process; this value is the same as the one -;; we see in the process executing this file since it is set by 'test-env'. +;; Here we should get the value of $GUIX_STATE_DIRECTORY that the daemon sees, +;; which is a unique value for each test process; this value is the same as +;; the one we see in the process executing this file since it is set by +;; 'test-env'. (test-equal "derivation #:leaked-env-vars" - (getenv "NIX_STATE_DIR") - (let* ((value (getenv "NIX_STATE_DIR")) + (getenv "GUIX_STATE_DIRECTORY") + (let* ((value (getenv "GUIX_STATE_DIRECTORY")) (drv (derivation %store "leaked-env-vars" %bash - '("-c" "echo -n $NIX_STATE_DIR > $out") + '("-c" "echo -n $GUIX_STATE_DIRECTORY > $out") #:hash (sha256 (string->utf8 value)) #:hash-algo 'sha256 #:inputs `((,%bash)) - #:leaked-env-vars '("NIX_STATE_DIR")))) + #:leaked-env-vars '("GUIX_STATE_DIRECTORY")))) (and (build-derivations %store (list drv)) (call-with-input-file (derivation->output-path drv) get-string-all)))) diff --git a/tests/guix-build.sh b/tests/guix-build.sh index 7842ce87c6..66bf6be8d0 100644 --- a/tests/guix-build.sh +++ b/tests/guix-build.sh @@ -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 # # This file is part of GNU Guix. # @@ -37,7 +37,7 @@ guix build hello -d | \ grep -e '-hello-[0-9\.]\+\.drv$' # Passing a URI. -GUIX_DAEMON_SOCKET="file://$NIX_STATE_DIR/daemon-socket/socket" \ +GUIX_DAEMON_SOCKET="file://$GUIX_STATE_DIRECTORY/daemon-socket/socket" \ guix build -e '(@@ (gnu packages bootstrap) %bootstrap-guile)' ( if GUIX_DAEMON_SOCKET="weird://uri" \ diff --git a/tests/guix-daemon.sh b/tests/guix-daemon.sh index 4c19a55722..ce82cfd1e6 100644 --- a/tests/guix-daemon.sh +++ b/tests/guix-daemon.sh @@ -63,7 +63,7 @@ guile -c " (exit (has-substitutes? store \"$out\"))" # Now, run guix-daemon --no-substitutes. -socket="$NIX_STATE_DIR/alternate-socket" +socket="$GUIX_STATE_DIRECTORY/alternate-socket" guix-daemon --no-substitutes --listen="$socket" --disable-chroot & daemon_pid=$! trap 'kill $daemon_pid' EXIT -- cgit v1.2.3 From 765a5bf1677ad6bc77ed65df4f63da9ef77bb55a Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sun, 3 Feb 2019 22:13:55 +0100 Subject: self: Ensure the daemon refers to the right 'guix' command. Previously it would refer to /var/guix/profiles/per-user/root/current-guix/bin/guix, which would fail when that profile does not exist. This is notably the case when using 'channel-instance->package' as done in commit 7e6d8d366a61f951936ed83371877ce006f679f6. * gnu/packages/package-management.scm (guix-daemon)[arguments]: In 'install phase, honor environment variable 'GUIX'. * guix/self.scm (whole-package)[wrap]: New procedure. Use it. --- gnu/packages/package-management.scm | 2 +- guix/self.scm | 14 ++++++++++++-- 2 files changed, 13 insertions(+), 3 deletions(-) (limited to 'guix') diff --git a/gnu/packages/package-management.scm b/gnu/packages/package-management.scm index ef38a6f61a..c52f5e3699 100644 --- a/gnu/packages/package-management.scm +++ b/gnu/packages/package-management.scm @@ -356,7 +356,7 @@ the Nix package manager.") (let ((out (assoc-ref outputs "out"))) (substitute* (find-files (string-append out "/libexec")) (("exec \".*/bin/guix\"") - "exec /var/guix/profiles/per-user/root/current-guix/bin/guix")) + "exec \"${GUIX:-/var/guix/profiles/per-user/root/current-guix/bin/guix}\"")) #t))) (delete 'wrap-program))))))) diff --git a/guix/self.scm b/guix/self.scm index 68f5641fec..a45470a0a6 100644 --- a/guix/self.scm +++ b/guix/self.scm @@ -460,17 +460,27 @@ load path." the modules (under share/guile/site and lib/guile), and DEPENDENCIES, a list of packages depended on. COMMAND is the 'guix' program to use; INFO is the Info manual." + (define (wrap daemon) + (program-file "guix-daemon" + #~(begin + (setenv "GUIX" #$command) + (apply execl #$(file-append daemon "/bin/guix-daemon") + "guix-daemon" (cdr (command-line)))))) + (computed-file name (with-imported-modules '((guix build utils)) #~(begin (use-modules (guix build utils)) + (define daemon + #$(and daemon (wrap daemon))) + (mkdir-p (string-append #$output "/bin")) (symlink #$command (string-append #$output "/bin/guix")) - (when #$daemon - (symlink (string-append #$daemon "/bin/guix-daemon") + (when daemon + (symlink daemon (string-append #$output "/bin/guix-daemon"))) (let ((share (string-append #$output "/share")) -- cgit v1.2.3 From 7c4700e9f9c290ecc08a4da41534063565fccb25 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sun, 3 Feb 2019 22:32:13 +0100 Subject: store: 'log-file' honors 'GUIX_LOG_DIRECTORY'. * guix/store.scm (derivation-log-file): Use %LOCALSTATEDIR or "GUIX_LOG_DIRECTORY" instead of (dirname %STATE-DIRECTORY). --- guix/store.scm | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) (limited to 'guix') diff --git a/guix/store.scm b/guix/store.scm index d079147529..0a0a7c7c52 100644 --- a/guix/store.scm +++ b/guix/store.scm @@ -1856,8 +1856,9 @@ syntactically valid store path." "Return the build log file for DRV, a derivation file name, or #f if it could not be found." (let* ((base (basename drv)) - (log (string-append (dirname %state-directory) ; XXX - "/log/guix/drvs/" + (log (string-append (or (getenv "GUIX_LOG_DIRECTORY") + (string-append %localstatedir "/log/guix")) + "/drvs/" (string-take base 2) "/" (string-drop base 2))) (log.gz (string-append log ".gz")) -- cgit v1.2.3 From 7473bce207af846312d5167a398f5f20bbf3e896 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 4 Feb 2019 11:27:24 +0100 Subject: status: Erase the progress bar or spinner. Previously the progress bar wouldn't be erased by the time the next "building foo" line would be printed. * guix/status.scm (print-build-event)[erase-current-line*]: New procedure. Call it instead of (display "\r"). --- guix/status.scm | 9 ++++++++- 1 file changed, 8 insertions(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/status.scm b/guix/status.scm index e3375816c5..bd382baf7a 100644 --- a/guix/status.scm +++ b/guix/status.scm @@ -465,8 +465,15 @@ addition to build events." (_ (spin! port)))))) + (define erase-current-line* + (if (isatty?* port) + (lambda (port) + (erase-current-line port) + (force-output port)) + (const #t))) + (unless print-log? - (display "\r" port)) ;erase the spinner + (erase-current-line* port)) ;clear the spinner or progress bar (match event (('build-started drv . _) (let ((properties (derivation-properties -- cgit v1.2.3 From 625a3daa12217d7cd162149dcba5657237bb9455 Mon Sep 17 00:00:00 2001 From: Gabriel Hondet Date: Fri, 1 Feb 2019 09:38:22 +0100 Subject: gnu: dune: Update to 1.6.3. * gnu/packages/ocaml.scm (dune): Update to 1.6.3. * guix/build/dune-build-system.scm (build): Use --libdir. Signed-off-by: Julien Lepiller --- gnu/packages/ocaml.scm | 4 ++-- guix/build/dune-build-system.scm | 4 +++- 2 files changed, 5 insertions(+), 3 deletions(-) (limited to 'guix') diff --git a/gnu/packages/ocaml.scm b/gnu/packages/ocaml.scm index a32cee44dc..986e435f48 100644 --- a/gnu/packages/ocaml.scm +++ b/gnu/packages/ocaml.scm @@ -1391,14 +1391,14 @@ coverage information.") (define-public dune (package (name "dune") - (version "1.2.1") + (version "1.6.3") (source (origin (method url-fetch) (uri (string-append "https://github.com/ocaml/dune/releases/" "download/" version "/dune-" version ".tbz")) (sha256 (base32 - "00c5dbm4hkdapc2i7pg07b2lj8sv6ly38qr7zid58cdmbmzq21z9")))) + "0dmf0wbfmgdy5plz1bjiisc2hjgblvxsnrqjmw2c8y45v1h23mdz")))) (build-system ocaml-build-system) (arguments `(#:tests? #f; require odoc diff --git a/guix/build/dune-build-system.scm b/guix/build/dune-build-system.scm index fcc2d6567d..00b0c7c406 100644 --- a/guix/build/dune-build-system.scm +++ b/guix/build/dune-build-system.scm @@ -1,5 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2018 Julien Lepiller +;;; Copyright © 2019 Gabriel Hondet ;;; ;;; This file is part of GNU Guix. ;;; @@ -49,7 +50,8 @@ "Install the given package." (let ((out (assoc-ref outputs "out")) (program (if jbuild? "jbuilder" "dune"))) - (invoke program install-target "--prefix" out)) + (invoke program install-target "--prefix" out "--libdir" + (string-append out "/lib/ocaml/site-lib"))) #t) (define %standard-phases -- cgit v1.2.3 From c7465dcb96e8d35fb992f4e14c4e22251b951a98 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 5 Feb 2019 10:51:23 +0100 Subject: status: Use 'define-immutable-record-type' and its functional setters. * guix/status.scm (): Define using 'define-immutable-record-type', and add 'set-build-completion' binding. (update-build)[set-completion]: Remove. Use 'set-build-completion' instead. --- guix/status.scm | 15 +++++---------- 1 file changed, 5 insertions(+), 10 deletions(-) (limited to 'guix') diff --git a/guix/status.scm b/guix/status.scm index bd382baf7a..070071d46f 100644 --- a/guix/status.scm +++ b/guix/status.scm @@ -30,6 +30,7 @@ #:use-module (guix memoization) #:use-module (srfi srfi-1) #:use-module (srfi srfi-9) + #:use-module (srfi srfi-9 gnu) #:use-module (srfi srfi-19) #:use-module (srfi srfi-26) #:use-module (ice-9 regex) @@ -100,14 +101,15 @@ (default '()))) ;; On-going or completed build. -(define-record-type +(define-immutable-record-type (%build derivation id system log-file completion) build? (derivation build-derivation) ;string (.drv file name) (id build-id) ;#f | integer (system build-system) ;string (log-file build-log-file) ;#f | string - (completion build-completion)) ;#f | integer (percentage) + (completion build-completion ;#f | integer (percentage) + set-build-completion)) (define* (build derivation system #:key id log-file completion) "Return a new build." @@ -156,13 +158,6 @@ (define (update-build status id line) "Update STATUS based on LINE, a build output line for ID that might contain a completion indication." - (define (set-completion b %) - (build (build-derivation b) - (build-system b) - #:id (build-id b) - #:log-file (build-log-file b) - #:completion %)) - (define (find-build) (find (lambda (build) (and (build-id build) @@ -173,7 +168,7 @@ a completion indication." (let ((build (find-build))) (build-status (inherit status) - (building (cons (set-completion build %) + (building (cons (set-build-completion build %) (delq build (build-status-building status))))))) (cond ((string-any #\nul line) -- cgit v1.2.3 From ba514b601ba6be15b823e0a12d4b6e42f9d2489e Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 5 Feb 2019 11:24:44 +0100 Subject: status: Keep track of the current build phase. * guix/status.scm ()[phase]: New field. (%phase-start-rx): New variable. (update-build): Add clause to match %PHASE-START-RX and adjust the 'phase' field accordingly. * tests/status.scm ("compute-status, build phase"): Add test --- guix/status.scm | 28 +++++++++++++++++++++++++--- tests/status.scm | 33 +++++++++++++++++++++++++++++++++ 2 files changed, 58 insertions(+), 3 deletions(-) (limited to 'guix') diff --git a/guix/status.scm b/guix/status.scm index 070071d46f..c3c219219d 100644 --- a/guix/status.scm +++ b/guix/status.scm @@ -55,6 +55,9 @@ build build-derivation build-system + build-log-file + build-phase + build-completion download? download @@ -102,18 +105,20 @@ ;; On-going or completed build. (define-immutable-record-type - (%build derivation id system log-file completion) + (%build derivation id system log-file phase completion) build? (derivation build-derivation) ;string (.drv file name) (id build-id) ;#f | integer (system build-system) ;string (log-file build-log-file) ;#f | string + (phase build-phase ;#f | symbol + set-build-phase) (completion build-completion ;#f | integer (percentage) set-build-completion)) -(define* (build derivation system #:key id log-file completion) +(define* (build derivation system #:key id log-file phase completion) "Return a new build." - (%build derivation id system log-file completion)) + (%build derivation id system log-file phase completion)) ;; On-going or completed downloads. Downloads can be stem from substitutes ;; and from "builtin:download" fixed-output derivations. @@ -144,6 +149,10 @@ (lambda (download) (string=? item (download-item download)))) +(define %phase-start-rx + ;; Match the "starting phase" message emitted by 'gnu-build-system'. + (make-regexp "^starting phase [`']([^']+)'")) + (define %percentage-line-rx ;; Things like CMake write lines like "[ 10%] gcc -c …". This regexp ;; matches them. @@ -185,6 +194,19 @@ a completion indication." (let ((done (string->number (match:substring match 1))) (total (string->number (match:substring match 3)))) (update (* 100. (/ done total)))))) + ((regexp-exec %phase-start-rx line) + => + (lambda (match) + (let ((phase (match:substring match 1)) + (build (find-build))) + (if build + (build-status + (inherit status) + (building + (cons (set-build-phase (set-build-completion build #f) + (string->symbol phase)) + (delq build (build-status-building status))))) + status)))) (else status))) diff --git a/tests/status.scm b/tests/status.scm index f3afadfcd0..01a61f7345 100644 --- a/tests/status.scm +++ b/tests/status.scm @@ -211,4 +211,37 @@ (display "@ build-succeeded foo.drv\n" port) (list first second third (get-status))))))) +(test-equal "compute-status, build phase" + (list (build-status + (building (list (build "foo.drv" "x86_64-linux" #:id 121 + #:phase 'configure)))) + (build-status + (building (list (build "foo.drv" "x86_64-linux" #:id 121 + #:phase 'configure + #:completion 50.)))) + (build-status + (building (list (build "foo.drv" "x86_64-linux" #:id 121 + #:phase 'install)))) + (build-status + (builds-completed (list (build "foo.drv" "x86_64-linux" #:id 121 + #:phase 'install))))) + (let-values (((port get-status) + (build-event-output-port (lambda (event status) + (compute-status event status + #:current-time + (const 'now)))))) + (display "@ build-started foo.drv - x86_64-linux 121\n" port) + (display "@ build-log 121 27\nstarting phase `configure'\n" port) + (display "@ build-log 121 6\nabcde!" port) + (let ((first (get-status))) + (display "@ build-log 121 20\n[50/100] building Y\n" port) + (display "@ build-log 121 6\nfghik!" port) + (let ((second (get-status))) + (display "@ build-log 121 21\n[100/100] building Z\n" port) + (display "@ build-log 121 25\nstarting phase `install'\n" port) + (display "@ build-log 121 6\nlmnop!" port) + (let ((third (get-status))) + (display "@ build-succeeded foo.drv\n" port) + (list first second third (get-status))))))) + (test-end "status") -- cgit v1.2.3 From 596fb4baf0c82dbf2bdba43171c743f26fa5b924 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 5 Feb 2019 11:51:53 +0100 Subject: status: Display the current build phase. * guix/status.scm (spin!): Add 'phase' parameter and honor it. Callers updated. (print-build-event)[report-progress]: Likewise. --- guix/status.scm | 33 ++++++++++++++++++++++++--------- 1 file changed, 24 insertions(+), 9 deletions(-) (limited to 'guix') diff --git a/guix/status.scm b/guix/status.scm index c3c219219d..984f329964 100644 --- a/guix/status.scm +++ b/guix/status.scm @@ -345,14 +345,21 @@ build-log\" traces." (define spin! (let ((steps (circular-list "\\" "|" "/" "-"))) - (lambda (port) - "Display a spinner on PORT." + (lambda (phase port) + "Display a spinner on PORT. If PHASE is true, display it as a hint of +the current build phase." (when (isatty?* port) (match steps ((first . rest) (set! steps rest) (display "\r\x1b[K" port) (display first port) + (when phase + (display " " port) + ;; TRANSLATORS: The word "phase" here denotes a "build phase"; + ;; "~a" is a placeholder for the untranslated name of the current + ;; build phase--e.g., 'configure' or 'build'. + (format port (G_ "'~a' phase") phase)) (force-output port))))))) (define (color-output? port) @@ -458,12 +465,18 @@ addition to build events." (cut colorize-string <> 'RED 'BOLD) identity)) - (define (report-build-progress %) + (define (report-build-progress phase %) (let ((% (min (max % 0) 100))) ;sanitize (erase-current-line port) - (format port "~3d% " (inexact->exact (round %))) - (display (progress-bar % (- (current-terminal-columns) 5)) - port) + (let* ((prefix (format #f "~3d% ~@['~a' ~]" + (inexact->exact (round %)) + (case phase + ((build) #f) ;not useful to display it + (else phase)))) + (length (string-length prefix))) + (display prefix port) + (display (progress-bar % (- (current-terminal-columns) length)) + port)) (force-output port))) (define print-log-line @@ -477,10 +490,12 @@ addition to build events." (match (build-status-building status) ((build) ;single job (match (build-completion build) - ((? number? %) (report-build-progress %)) - (_ (spin! port)))) + ((? number? %) + (report-build-progress (build-phase build) %)) + (_ + (spin! (build-phase build) port)))) (_ - (spin! port)))))) + (spin! #f port)))))) (define erase-current-line* (if (isatty?* port) -- cgit v1.2.3