diff options
author | Marius Bakke <mbakke@fastmail.com> | 2019-10-18 18:10:47 +0200 |
---|---|---|
committer | Marius Bakke <mbakke@fastmail.com> | 2019-10-18 18:10:47 +0200 |
commit | b95d1b3289a6bb8e346a47e750660e16fb201c57 (patch) | |
tree | cd4d956436f21d77645fd795d3e9737e4892c1d3 /guix | |
parent | a1d1703a1dc6bfcd10f48fe707ee7ac65300a37d (diff) | |
parent | dabcfc6de29032ea52d1cb54163a783f7e480167 (diff) | |
download | guix-patches-b95d1b3289a6bb8e346a47e750660e16fb201c57.tar guix-patches-b95d1b3289a6bb8e346a47e750660e16fb201c57.tar.gz |
Merge branch 'master' into staging
Diffstat (limited to 'guix')
-rw-r--r-- | guix/build-system/asdf.scm | 13 | ||||
-rw-r--r-- | guix/build-system/gnu.scm | 59 | ||||
-rw-r--r-- | guix/gexp.scm | 2 | ||||
-rw-r--r-- | guix/inferior.scm | 38 | ||||
-rw-r--r-- | guix/lint.scm | 16 | ||||
-rw-r--r-- | guix/profiles.scm | 3 | ||||
-rw-r--r-- | guix/scripts/offload.scm | 22 | ||||
-rw-r--r-- | guix/scripts/pull.scm | 2 | ||||
-rw-r--r-- | guix/ssh.scm | 10 | ||||
-rw-r--r-- | guix/store.scm | 12 |
10 files changed, 136 insertions, 41 deletions
diff --git a/guix/build-system/asdf.scm b/guix/build-system/asdf.scm index af04084c86..f794bf006b 100644 --- a/guix/build-system/asdf.scm +++ b/guix/build-system/asdf.scm @@ -1,5 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2016, 2017 Andy Patterson <ajpatter@uwaterloo.ca> +;;; Copyright © 2019 Guillaume Le Vaillant <glv@posteo.net> ;;; ;;; This file is part of GNU Guix. ;;; @@ -32,6 +33,7 @@ #:use-module (ice-9 regex) #:use-module (srfi srfi-1) #:use-module (srfi srfi-26) + #:use-module (gnu packages) #:export (%asdf-build-system-modules %asdf-build-modules asdf-build @@ -160,13 +162,22 @@ set up using CL source package conventions." (define (has-from-build-system? pkg) (eq? from-build-system (package-build-system pkg))) + (define (find-input-package pkg) + (let* ((name (package-name pkg)) + (new-name (transform-package-name name)) + (pkgs (find-packages-by-name new-name))) + (if (null? pkgs) #f (list-ref pkgs 0)))) + (define transform (mlambda (pkg) (define rewrite (match-lambda ((name content . rest) (let* ((is-package? (package? content)) - (new-content (if is-package? (transform content) content))) + (new-content (if is-package? + (or (find-input-package content) + (transform content)) + content))) `(,name ,new-content ,@rest))))) ;; Special considerations for source packages: CL inputs become diff --git a/guix/build-system/gnu.scm b/guix/build-system/gnu.scm index c9140074b7..3cc89f8852 100644 --- a/guix/build-system/gnu.scm +++ b/guix/build-system/gnu.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2019 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -57,12 +57,16 @@ '((guix build gnu-build-system) (guix build utils))) -(define* (package-with-explicit-inputs p inputs - #:optional - (loc (current-source-location)) - #:key (native-inputs '()) - guile) - "Rewrite P, which is assumed to use GNU-BUILD-SYSTEM, to take INPUTS and +(define* (package-with-explicit-inputs/deprecated p inputs + #:optional + (loc (current-source-location)) + #:key (native-inputs '()) + guile) + "This variant is deprecated because it is inefficient: it memoizes only +temporarily instead of memoizing across all transformations where INPUTS is +the same. + +Rewrite P, which is assumed to use GNU-BUILD-SYSTEM, to take INPUTS and NATIVE-INPUTS as explicit inputs instead of the implicit default, and return it. INPUTS and NATIVE-INPUTS can be either input lists or thunks; in the latter case, they will be called in a context where the `%current-system' and @@ -124,6 +128,47 @@ builder, or the distro's final Guile when GUILE is #f." ,@(map rewritten-input (filtered (package-inputs p))))))))) +(define* (package-with-explicit-inputs* inputs #:optional guile) + "Return a procedure that rewrites the given package and all its dependencies +so that they use INPUTS (a thunk) instead of implicit inputs." + (define (duplicate-filter package-inputs) + (let ((names (match (inputs) + (((name _ ...) ...) + name)))) + (fold alist-delete package-inputs names))) + + (define (add-explicit-inputs p) + (if (and (eq? (package-build-system p) gnu-build-system) + (not (memq #:implicit-inputs? (package-arguments p)))) + (package + (inherit p) + (inputs (append (inputs) + (duplicate-filter (package-inputs p)))) + (arguments + (ensure-keyword-arguments (package-arguments p) + `(#:implicit-inputs? #f + #:guile ,guile)))) + p)) + + (define (cut? p) + (and (eq? (package-build-system p) gnu-build-system) + (memq #:implicit-inputs? (package-arguments p)))) + + (package-mapping add-explicit-inputs cut?)) + +(define package-with-explicit-inputs + (case-lambda* + ((inputs #:optional guile) + (package-with-explicit-inputs* inputs guile)) + ((p inputs #:optional (loc (current-source-location)) + #:key (native-inputs '()) guile) + ;; deprecated + (package-with-explicit-inputs/deprecated p inputs + loc + #:native-inputs + native-inputs + #:guile guile)))) + (define (package-with-extra-configure-variable p variable value) "Return a version of P with VARIABLE=VALUE specified as an extra `configure' flag, recursively. An example is LDFLAGS=-static. If P already has configure diff --git a/guix/gexp.scm b/guix/gexp.scm index 600750e846..7323277511 100644 --- a/guix/gexp.scm +++ b/guix/gexp.scm @@ -1508,7 +1508,7 @@ are searched for in PATH. Return #f when MODULES and EXTENSIONS are empty." (gexp (eval-when (expand load eval) ;; Augment the load paths and delete duplicates. Do that ;; without loading (srfi srfi-1) or anything. - (let ((extensions '((ungexp-native-splicing extensions))) + (let ((extensions '((ungexp-splicing extensions))) (prepend (lambda (items lst) ;; This is O(N²) but N is typically small. (let loop ((items items) diff --git a/guix/inferior.scm b/guix/inferior.scm index d6d2053ab8..b8e2f21f42 100644 --- a/guix/inferior.scm +++ b/guix/inferior.scm @@ -110,11 +110,11 @@ (packages inferior-package-promise) ;promise of inferior packages (table inferior-package-table)) ;promise of vhash -(define (inferior-pipe directory command) +(define* (inferior-pipe directory command error-port) "Return an input/output pipe on the Guix instance in DIRECTORY. This runs 'DIRECTORY/COMMAND repl' if it exists, or falls back to some other method if it's an old Guix." - (let ((pipe (with-error-to-port (%make-void-port "w") + (let ((pipe (with-error-to-port error-port (lambda () (open-pipe* OPEN_BOTH (string-append directory "/" command) @@ -125,19 +125,21 @@ it's an old Guix." ;; Older versions of Guix didn't have a 'guix repl' command, so ;; emulate it. - (open-pipe* OPEN_BOTH "guile" - "-L" (string-append directory "/share/guile/site/" - (effective-version)) - "-C" (string-append directory "/share/guile/site/" - (effective-version)) - "-C" (string-append directory "/lib/guile/" - (effective-version) "/site-ccache") - "-c" - (object->string - `(begin - (primitive-load ,(search-path %load-path - "guix/repl.scm")) - ((@ (guix repl) machine-repl)))))) + (with-error-to-port error-port + (lambda () + (open-pipe* OPEN_BOTH "guile" + "-L" (string-append directory "/share/guile/site/" + (effective-version)) + "-C" (string-append directory "/share/guile/site/" + (effective-version)) + "-C" (string-append directory "/lib/guile/" + (effective-version) "/site-ccache") + "-c" + (object->string + `(begin + (primitive-load ,(search-path %load-path + "guix/repl.scm")) + ((@ (guix repl) machine-repl)))))))) pipe))) (define* (port->inferior pipe #:optional (close close-port)) @@ -161,11 +163,13 @@ inferior." (_ #f))) -(define* (open-inferior directory #:key (command "bin/guix")) +(define* (open-inferior directory + #:key (command "bin/guix") + (error-port (%make-void-port "w"))) "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)) + (inferior-pipe directory command error-port)) (port->inferior pipe close-pipe)) diff --git a/guix/lint.scm b/guix/lint.scm index 03a8e88225..6336cf4e3b 100644 --- a/guix/lint.scm +++ b/guix/lint.scm @@ -1319,11 +1319,17 @@ or a list thereof") (name 'github-url) (description "Suggest GitHub URLs") (check check-github-url)) - (lint-checker - (name 'cve) - (description "Check the Common Vulnerabilities and Exposures\ - (CVE) database") - (check check-vulnerabilities)) + + ;; FIXME: Commented out as a consequence of the XML CVE feed retirement: + ;; <https://nvd.nist.gov/General/News/XML-Vulnerability-Feed-Retirement-Phase-3>. + ;; Reinstate it once the JSON feed is supported. + + ;; (lint-checker + ;; (name 'cve) + ;; (description "Check the Common Vulnerabilities and Exposures\ + ;; (CVE) database") + ;; (check check-vulnerabilities)) + (lint-checker (name 'refresh) (description "Check the package for new upstream releases") diff --git a/guix/profiles.scm b/guix/profiles.scm index f5c863945c..cd3b21e390 100644 --- a/guix/profiles.scm +++ b/guix/profiles.scm @@ -1732,7 +1732,8 @@ because the NUMBER is zero.)" (string-append %profile-directory "/guix-profile")) (define (ensure-profile-directory) - "Attempt to create /…/profiles/per-user/$USER if needed." + "Attempt to create /…/profiles/per-user/$USER if needed. Nowadays this is +taken care of by the daemon." (let ((s (stat %profile-directory #f))) (unless (and s (eq? 'directory (stat:type s))) (catch 'system-error diff --git a/guix/scripts/offload.scm b/guix/scripts/offload.scm index bb307cefd1..1384f6b41d 100644 --- a/guix/scripts/offload.scm +++ b/guix/scripts/offload.scm @@ -174,7 +174,7 @@ can interpret meaningfully." private key from '~a': ~a") file str)))))))) -(define (open-ssh-session machine) +(define* (open-ssh-session machine #:optional (max-silent-time -1)) "Open an SSH session for MACHINE and return it. Throw an error on failure." (let ((private (private-key-from-file* (build-machine-private-key machine))) (public (public-key-from-file @@ -183,7 +183,7 @@ private key from '~a': ~a") (session (make-session #:user (build-machine-user machine) #:host (build-machine-name machine) #:port (build-machine-port machine) - #:timeout 10 ;seconds + #:timeout 10 ;initial timeout (seconds) ;; #:log-verbosity 'protocol #:identity (build-machine-private-key machine) @@ -225,6 +225,10 @@ instead of '~a' of type '~a'~%") (leave (G_ "SSH public key authentication failed for '~a': ~a~%") (build-machine-name machine) (get-error session)))) + ;; From then on use MAX-SILENT-TIME as the absolute timeout when + ;; reading from or write to a channel for this session. + (session-set! session 'timeout max-silent-time) + session) (x ;; Connection failed or timeout expired. @@ -313,7 +317,7 @@ hook." INPUTS to MACHINE; if building DRV succeeds, retrieve all of OUTPUTS from MACHINE." (define session - (open-ssh-session machine)) + (open-ssh-session machine max-silent-time)) (define store (connect-to-remote-daemon session @@ -472,7 +476,8 @@ slot (which must later be released with 'release-build-slot'), or #f and #f." ;; 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))) + (let* ((session (false-if-exception (open-ssh-session best + %short-timeout))) (node (and session (remote-inferior session))) (load (and node (normalized-load best (node-load node)))) (space (and node (node-free-disk-space node)))) @@ -573,6 +578,11 @@ If TIMEOUT is #f, simply evaluate EXP..." ;;; Installation tests. ;;; +(define %short-timeout + ;; Timeout in seconds used on SSH connections where reads and writes + ;; shouldn't take long. + 15) + (define (assert-node-repl node name) "Bail out if NODE is not running Guile." (match (node-guile-version node) @@ -658,7 +668,7 @@ machine." (length machines) machine-file) (let* ((names (map build-machine-name machines)) (sockets (map build-machine-daemon-socket machines)) - (sessions (map open-ssh-session machines)) + (sessions (map (cut open-ssh-session <> %short-timeout) machines)) (nodes (map remote-inferior sessions))) (for-each assert-node-has-guix nodes names) (for-each assert-node-repl nodes names) @@ -682,7 +692,7 @@ machine." (length machines) machine-file) (for-each (lambda (machine) (define session - (open-ssh-session machine)) + (open-ssh-session machine %short-timeout)) (match (remote-inferior session) (#f diff --git a/guix/scripts/pull.scm b/guix/scripts/pull.scm index 04970cf503..7876019eac 100644 --- a/guix/scripts/pull.scm +++ b/guix/scripts/pull.scm @@ -772,11 +772,11 @@ Use '~/.config/guix/channels.scm' instead.")) (process-generation-change opts profile)) (else (with-store store - (ensure-default-profile) (with-status-verbosity (assoc-ref opts 'verbosity) (parameterize ((%current-system (assoc-ref opts 'system)) (%graft? (assoc-ref opts 'graft?))) (set-build-options-from-command-line store opts) + (ensure-default-profile) (honor-x509-certificates store) (let ((instances (latest-channel-instances store channels))) diff --git a/guix/ssh.scm b/guix/ssh.scm index b6b55bdfcb..5fd3c280e8 100644 --- a/guix/ssh.scm +++ b/guix/ssh.scm @@ -61,11 +61,16 @@ "zlib@openssh.com,zlib") (define* (open-ssh-session host #:key user port identity - (compression %compression)) + (compression %compression) + (timeout 3600)) "Open an SSH session for HOST and return it. IDENTITY specifies the file name of a private key to use for authenticating with the host. When USER, PORT, or IDENTITY are #f, use default values or whatever '~/.ssh/config' -specifies; otherwise use them. Throw an error on failure." +specifies; otherwise use them. Install TIMEOUT as the maximum time in seconds +after which a read or write operation on a channel of the returned session is +considered as failing. + +Throw an error on failure." (let ((session (make-session #:user user #:identity identity #:host host @@ -86,6 +91,7 @@ specifies; otherwise use them. Throw an error on failure." ;; Use public key authentication, via the SSH agent if it's available. (match (userauth-public-key/auto! session) ('success + (session-set! session 'timeout timeout) session) (x (disconnect! session) diff --git a/guix/store.scm b/guix/store.scm index d7c603898c..382aad29d9 100644 --- a/guix/store.scm +++ b/guix/store.scm @@ -748,6 +748,14 @@ encoding conversion errors." (cut string-append "http://" <>)) '("ci.guix.gnu.org"))) +(define (current-user-name) + "Return the name of the calling user." + (catch #t + (lambda () + (passwd:name (getpwuid (getuid)))) + (lambda _ + (getenv "USER")))) + (define* (set-build-options server #:key keep-failed? keep-going? fallback? (verbosity 0) @@ -759,6 +767,7 @@ encoding conversion errors." (build-verbosity 0) (log-type 0) (print-build-trace #t) + (user-name (current-user-name)) ;; When true, provide machine-readable "build ;; traces" for use by (guix status). Old clients @@ -849,6 +858,9 @@ encoding conversion errors." `(("build-repeat" . ,(number->string (max 0 (1- rounds))))) '()) + ,@(if user-name + `(("user-name" . ,user-name)) + '()) ,@(if terminal-columns `(("terminal-columns" . ,(number->string terminal-columns))) |