From 06f0453ad27c92633d3630dbe49a16dcb0281d04 Mon Sep 17 00:00:00 2001 From: Julien Lepiller Date: Tue, 17 Mar 2020 00:05:32 +0100 Subject: guix: import: opam: Use a default repository. * guix/import/opam.scm (opam->guix-package): Use a default value for `repository`. --- guix/import/opam.scm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/import/opam.scm b/guix/import/opam.scm index 394415fdd4..ae7df8a8b5 100644 --- a/guix/import/opam.scm +++ b/guix/import/opam.scm @@ -250,7 +250,7 @@ path to the repository." (substring version 1) version))))) -(define* (opam->guix-package name #:key repository) +(define* (opam->guix-package name #:key (repository (get-opam-repository))) "Import OPAM package NAME from REPOSITORY (a directory name) or, if REPOSITORY is #f, from the official OPAM repository. Return a 'package' sexp or #f on failure." -- cgit v1.2.3 From 8d003ca34499705d8dbccfcae4b7dd9bfe30c93c Mon Sep 17 00:00:00 2001 From: Mathieu Othacehe Date: Tue, 17 Mar 2020 16:51:14 +0100 Subject: build-system: linux-module: Break some long lines. * gnu/build/linux-modules.scm (make-linux-module-builder, lower): Break some long commentary lines. --- guix/build-system/linux-module.scm | 9 +++++++-- 1 file changed, 7 insertions(+), 2 deletions(-) (limited to 'guix') diff --git a/guix/build-system/linux-module.scm b/guix/build-system/linux-module.scm index ba76ab85c3..1e1a07d0a2 100644 --- a/guix/build-system/linux-module.scm +++ b/guix/build-system/linux-module.scm @@ -78,7 +78,8 @@ (lambda* (#:key inputs outputs #:allow-other-keys) (let* ((out (assoc-ref outputs "out")) (out-lib-build (string-append out "/lib/modules/build"))) - ; TODO: Only preserve the minimum, i.e. [Kbuild], Kconfig, scripts, include, ".config". + ;; TODO: Only preserve the minimum, i.e. [Kbuild], Kconfig, + ;; scripts, include, ".config". (copy-recursively "." out-lib-build) (let* ((linux (assoc-ref inputs "linux"))) (install-file (string-append linux "/System.map") @@ -111,7 +112,11 @@ ("linux-module-builder" ,(make-linux-module-builder linux)) ,@native-inputs - ;; TODO: Remove "gmp", "mpfr", "mpc" since they are only needed to compile the gcc plugins. Maybe remove "flex", "bison", "elfutils", "perl", "openssl". That leaves very little ("bc", "gcc", "kmod"). + ;; TODO: Remove "gmp", "mpfr", "mpc" since they are + ;; only needed to compile the gcc plugins. Maybe + ;; remove "flex", "bison", "elfutils", "perl", + ;; "openssl". That leaves very little ("bc", "gcc", + ;; "kmod"). ,@(package-native-inputs linux))) (outputs outputs) (build linux-module-build) -- cgit v1.2.3 From 771c5e155d7862ed91a5d503eecc00c1db1150ad Mon Sep 17 00:00:00 2001 From: Florian Pelz Date: Thu, 12 Mar 2020 11:08:16 +0100 Subject: store: Fix many guix commands failing on some locales. Partly fixes . At least 'guix environment', 'guix install' and 'guix pull' on 'az_AZ.utf8' and 'tr_TR.utf8' were affected. * guix/store.scm (store-path-hash-part): Move base path detection to ... (store-path-base): ... this new exported procedure. (store-path-package-name): Use it instead of locale-dependent regexps. (store-regexp*): Remove. --- guix/store.scm | 32 +++++++++++++++----------------- 1 file changed, 15 insertions(+), 17 deletions(-) (limited to 'guix') diff --git a/guix/store.scm b/guix/store.scm index 5768a2ba7a..2c3675dca6 100644 --- a/guix/store.scm +++ b/guix/store.scm @@ -2,6 +2,7 @@ ;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019 Ludovic Courtès ;;; Copyright © 2018 Jan Nieuwenhuizen ;;; Copyright © 2019, 2020 Mathieu Othacehe +;;; Copyright © 2020 Florian Pelz ;;; ;;; This file is part of GNU Guix. ;;; @@ -43,7 +44,6 @@ #:use-module (srfi srfi-35) #:use-module (srfi srfi-39) #:use-module (ice-9 match) - #:use-module (ice-9 regex) #:use-module (ice-9 vlist) #:use-module (ice-9 popen) #:use-module (ice-9 threads) @@ -173,6 +173,7 @@ store-path? direct-store-path? derivation-path? + store-path-base store-path-package-name store-path-hash-part direct-store-path @@ -1949,29 +1950,26 @@ valid inputs." "Return #t if PATH is a derivation path." (and (store-path? path) (string-suffix? ".drv" path))) -(define store-regexp* - ;; The substituter makes repeated calls to 'store-path-hash-part', hence - ;; this optimization. - (mlambda (store) - "Return a regexp matching a file in STORE." - (make-regexp (string-append "^" (regexp-quote store) - "/([0-9a-df-np-sv-z]{32})-([^/]+)$")))) +(define (store-path-base path) + "Return the base path of a path in the store." + (and (string-prefix? (%store-prefix) path) + (let ((base (string-drop path (+ 1 (string-length (%store-prefix)))))) + (and (> (string-length base) 33) + (not (string-index base #\/)) + base)))) (define (store-path-package-name path) "Return the package name part of PATH, a file name in the store." - (let ((path-rx (store-regexp* (%store-prefix)))) - (and=> (regexp-exec path-rx path) - (cut match:substring <> 2)))) + (let ((base (store-path-base path))) + (string-drop base (+ 32 1)))) ;32 hash part + 1 hyphen (define (store-path-hash-part path) "Return the hash part of PATH as a base32 string, or #f if PATH is not a syntactically valid store path." - (and (string-prefix? (%store-prefix) path) - (let ((base (string-drop path (+ 1 (string-length (%store-prefix)))))) - (and (> (string-length base) 33) - (let ((hash (string-take base 32))) - (and (string-every %nix-base32-charset hash) - hash)))))) + (let* ((base (store-path-base path)) + (hash (string-take base 32))) + (and (string-every %nix-base32-charset hash) + hash))) (define (derivation-log-file drv) "Return the build log file for DRV, a derivation file name, or #f if it -- cgit v1.2.3 From f06a26f5b594b1d1865a41facca0ea65a3837901 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sun, 15 Mar 2020 14:27:09 +0100 Subject: repl: Allow clients to send their protocol version. * guix/repl.scm (send-repl-response): Add #:version. (machine-repl): Make 'loop' an internal define with a 'version' parameter. Pass VERSION to 'send-repl-response'. Send (0 1) as the protocol version. If the first element read from INPUT matches (() repl-version _ ...), interpret it as the client's protocol version. --- guix/repl.scm | 34 ++++++++++++++++++++++++---------- 1 file changed, 24 insertions(+), 10 deletions(-) (limited to 'guix') diff --git a/guix/repl.scm b/guix/repl.scm index 0f75f9cd0b..a141003812 100644 --- a/guix/repl.scm +++ b/guix/repl.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2018, 2019 Ludovic Courtès +;;; Copyright © 2018, 2019, 2020 Ludovic Courtès ;;; ;;; This file is part of GNU Guix. ;;; @@ -39,9 +39,10 @@ (one-of symbol? string? keyword? pair? null? array? number? boolean? char?))) -(define (send-repl-response exp output) +(define* (send-repl-response exp output + #:key (version '(0 0))) "Write the response corresponding to the evaluation of EXP to PORT, an -output port." +output port. VERSION is the client's protocol version we are targeting." (define (value->sexp value) (if (self-quoting? value) `(value ,value) @@ -72,13 +73,26 @@ The protocol of this REPL is meant to be machine-readable and provides proper support to represent multiple-value returns, exceptions, objects that lack a read syntax, and so on. As such it is more convenient and robust than parsing Guile's REPL prompt." - (write `(repl-version 0 0) output) + (define (loop exp version) + (match exp + ((? eof-object?) #t) + (exp + (send-repl-response exp output + #:version version) + (loop (read input) version)))) + + (write `(repl-version 0 1) output) (newline output) (force-output output) - (let loop () - (match (read input) - ((? eof-object?) #t) - (exp - (send-repl-response exp output) - (loop))))) + ;; In protocol version (0 0), clients would not send their supported + ;; protocol version. Thus, the code below checks for two case: (1) a (0 0) + ;; client that directly sends an expression to evaluate, and (2) a more + ;; recent client that sends (() repl-version ...). This form is chosen to + ;; be unambiguously distinguishable from a regular Scheme expression. + + (match (read input) + ((() 'repl-version version ...) + (loop (read input) version)) + (exp + (loop exp '(0 0))))) -- cgit v1.2.3 From ec0a8661728f915c21058076327b398ac5c38bbe Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sun, 15 Mar 2020 14:34:01 +0100 Subject: inferior: Adjust to protocol (0 1). * guix/inferior.scm (port->inferior): For protocol (0 x ...), where x >= 1, send the (() repl-version ...) form. --- guix/inferior.scm | 9 +++++++++ 1 file changed, 9 insertions(+) (limited to 'guix') diff --git a/guix/inferior.scm b/guix/inferior.scm index 6b685ece30..ec8ff8ddbe 100644 --- a/guix/inferior.scm +++ b/guix/inferior.scm @@ -159,6 +159,15 @@ inferior." (letrec ((result (inferior 'pipe pipe close (cons 0 rest) (delay (%inferior-packages result)) (delay (%inferior-package-table result))))) + + ;; For protocol (0 1) and later, send the protocol version we support. + (match rest + ((n _ ...) + (when (>= n 1) + (send-inferior-request '(() repl-version 0 1) result))) + (_ + #t)) + (inferior-eval '(use-modules (guix)) result) (inferior-eval '(use-modules (gnu)) result) (inferior-eval '(use-modules (ice-9 match)) result) -- cgit v1.2.3 From 2b0a370d00e72aba7385eba0fa5db2e3ca7085fb Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sun, 15 Mar 2020 17:22:30 +0100 Subject: repl: Return stack traces along with exceptions. * guix/repl.scm (repl-prompt): New variable. (stack->frames): New procedure. (send-repl-response)[frame->sexp, handle-exception]: New procedure. Pass HANDLE-EXCEPTION as a pre-unwind handler. (machine-repl): Define 'tag'. Bump protocol version to (0 1 1). Wrap 'loop' call in 'call-with-prompt'. --- guix/repl.scm | 64 +++++++++++++++++++++++++++++++++++++++++++++++++---------- 1 file changed, 54 insertions(+), 10 deletions(-) (limited to 'guix') diff --git a/guix/repl.scm b/guix/repl.scm index a141003812..0ace5976cf 100644 --- a/guix/repl.scm +++ b/guix/repl.scm @@ -17,6 +17,8 @@ ;;; along with GNU Guix. If not, see . (define-module (guix repl) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-26) #:use-module (ice-9 match) #:export (send-repl-response machine-repl)) @@ -39,6 +41,17 @@ (one-of symbol? string? keyword? pair? null? array? number? boolean? char?))) +(define repl-prompt + ;; Current REPL prompt or #f. + (make-parameter #f)) + +(define (stack->frames stack) + "Return STACK's frames as a list." + (unfold (cute >= <> (stack-length stack)) + (cut stack-ref stack <>) + 1+ + 0)) + (define* (send-repl-response exp output #:key (version '(0 0))) "Write the response corresponding to the evaluation of EXP to PORT, an @@ -49,6 +62,32 @@ output port. VERSION is the client's protocol version we are targeting." `(non-self-quoting ,(object-address value) ,(object->string value)))) + (define (frame->sexp frame) + `(,(frame-procedure-name frame) + ,(match (frame-source frame) + ((_ (? string? file) (? integer? line) . (? integer? column)) + (list file line column)) + (_ + '(#f #f #f))))) + + (define (handle-exception key . args) + (define reply + (match version + ((0 1 (? positive?) _ ...) + ;; Protocol (0 1 1) and later. + (let ((stack (if (repl-prompt) + (make-stack #t handle-exception (repl-prompt)) + (make-stack #t)))) + `(exception (arguments ,key ,@(map value->sexp args)) + (stack ,@(map frame->sexp (stack->frames stack)))))) + (_ + ;; Protocol (0 0). + `(exception ,key ,@(map value->sexp args))))) + + (write reply output) + (newline output) + (force-output output)) + (catch #t (lambda () (let ((results (call-with-values @@ -59,10 +98,8 @@ output port. VERSION is the client's protocol version we are targeting." output) (newline output) (force-output output))) - (lambda (key . args) - (write `(exception ,key ,@(map value->sexp args))) - (newline output) - (force-output output)))) + (const #t) + handle-exception)) (define* (machine-repl #:optional (input (current-input-port)) @@ -73,6 +110,9 @@ The protocol of this REPL is meant to be machine-readable and provides proper support to represent multiple-value returns, exceptions, objects that lack a read syntax, and so on. As such it is more convenient and robust than parsing Guile's REPL prompt." + (define tag + (make-prompt-tag "repl-prompt")) + (define (loop exp version) (match exp ((? eof-object?) #t) @@ -81,7 +121,7 @@ Guile's REPL prompt." #:version version) (loop (read input) version)))) - (write `(repl-version 0 1) output) + (write `(repl-version 0 1 1) output) (newline output) (force-output output) @@ -91,8 +131,12 @@ Guile's REPL prompt." ;; recent client that sends (() repl-version ...). This form is chosen to ;; be unambiguously distinguishable from a regular Scheme expression. - (match (read input) - ((() 'repl-version version ...) - (loop (read input) version)) - (exp - (loop exp '(0 0))))) + (call-with-prompt tag + (lambda () + (parameterize ((repl-prompt tag)) + (match (read input) + ((() 'repl-version version ...) + (loop (read input) version)) + (exp + (loop exp '(0 0)))))) + (const #f))) -- cgit v1.2.3 From 1dca6aaafa9f842565deab1fe7e6929f25544551 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sun, 15 Mar 2020 17:26:45 +0100 Subject: inferior: '&inferior-exception' includes a stack trace. * guix/inferior.scm (port->inferior): Bump protocol to (0 1 1). (&inferior-exception)[stack]: New field. (read-repl-response): Recognize 'exception' form for protocol (0 1 1). * tests/inferior.scm ("&inferior-exception"): Check the value returned by 'inferior-exception-stack'. --- guix/inferior.scm | 17 ++++++++++++++--- tests/inferior.scm | 3 +++ 2 files changed, 17 insertions(+), 3 deletions(-) (limited to 'guix') diff --git a/guix/inferior.scm b/guix/inferior.scm index ec8ff8ddbe..c9a5ee5129 100644 --- a/guix/inferior.scm +++ b/guix/inferior.scm @@ -66,6 +66,7 @@ inferior-exception? inferior-exception-arguments inferior-exception-inferior + inferior-exception-stack read-repl-response inferior-packages @@ -164,7 +165,7 @@ inferior." (match rest ((n _ ...) (when (>= n 1) - (send-inferior-request '(() repl-version 0 1) result))) + (send-inferior-request '(() repl-version 0 1 1) result))) (_ #t)) @@ -211,7 +212,8 @@ equivalent. Return #f if the inferior could not be launched." (define-condition-type &inferior-exception &error inferior-exception? (arguments inferior-exception-arguments) ;key + arguments - (inferior inferior-exception-inferior)) ; | #f + (inferior inferior-exception-inferior) ; | #f + (stack inferior-exception-stack)) ;list of (FILE COLUMN LINE) (define* (read-repl-response port #:optional inferior) "Read a (guix repl) response from PORT and return it as a Scheme object. @@ -226,10 +228,19 @@ Raise '&inferior-exception' when an exception is read from PORT." (match (read port) (('values objects ...) (apply values (map sexp->object objects))) + (('exception ('arguments key objects ...) + ('stack frames ...)) + ;; Protocol (0 1 1) and later. + (raise (condition (&inferior-exception + (arguments (cons key (map sexp->object objects))) + (inferior inferior) + (stack frames))))) (('exception key objects ...) + ;; Protocol (0 0). (raise (condition (&inferior-exception (arguments (cons key (map sexp->object objects))) - (inferior inferior))))))) + (inferior inferior) + (stack '()))))))) (define (read-inferior-response inferior) (read-repl-response (inferior-socket inferior) diff --git a/tests/inferior.scm b/tests/inferior.scm index b4417d8629..2f5215920b 100644 --- a/tests/inferior.scm +++ b/tests/inferior.scm @@ -68,6 +68,9 @@ (guard (c ((inferior-exception? c) (close-inferior inferior) (and (eq? inferior (inferior-exception-inferior c)) + (match (inferior-exception-stack c) + (((_ (files lines columns)) ..1) + (member "guix/repl.scm" files))) (inferior-exception-arguments c)))) (inferior-eval '(throw 'a 'b 'c 'd) inferior) 'badness))) -- cgit v1.2.3 From 892ca1d92f6236b5e176b8fb189a83b86a6a3afe Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 19 Mar 2020 12:10:58 +0100 Subject: guix package: Remove unneeded import. This is a followup to 55e1dfa4dd189e010c541e3997b65434c702b4a5. * guix/scripts/package.scm: Remove unneeded #:use-module. --- guix/scripts/package.scm | 2 -- 1 file changed, 2 deletions(-) (limited to 'guix') diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm index d2f4f1ccd3..e620309e30 100644 --- a/guix/scripts/package.scm +++ b/guix/scripts/package.scm @@ -42,8 +42,6 @@ #:autoload (guix store roots) (gc-roots user-owned?) #:use-module ((guix build utils) #:select (directory-exists? mkdir-p)) - #:use-module ((guix build syscalls) - #:select (with-file-lock/no-wait)) #:use-module (ice-9 format) #:use-module (ice-9 match) #:use-module (ice-9 regex) -- cgit v1.2.3 From 3e000955cd232c437cbe6994c124e30a35bc2605 Mon Sep 17 00:00:00 2001 From: Brendan Tildesley Date: Fri, 20 Mar 2020 01:24:39 +1100 Subject: guix: lint: Ad scdoc as a suggested native input. * guix/lint.scm (check-inputs-should-be-native): Add scdoc. Signed-off-by: Danny Milosavljevic --- guix/lint.scm | 1 + 1 file changed, 1 insertion(+) (limited to 'guix') diff --git a/guix/lint.scm b/guix/lint.scm index 24fbf05202..40bddd0a41 100644 --- a/guix/lint.scm +++ b/guix/lint.scm @@ -317,6 +317,7 @@ of a package, and INPUT-NAMES, a list of package specifications such as "python-pytest-cov" "python2-pytest-cov" "python-setuptools-scm" "python2-setuptools-scm" "python-sphinx" "python2-sphinx" + "scdoc" "swig" "qmake" "qttools" -- cgit v1.2.3 From f2b24f01f42c1bad3ddffd140194de1aec38a5f8 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 20 Mar 2020 23:34:03 +0100 Subject: packages: 'package-field-location' preserves the original file name. Fixes . Reported by Alex ter Weele . * guix/packages.scm (package-field-location): Remove 'with-fluids' for '%file-port-name-canonicalization'. Change the 'file' field of the resulting location to FILE. --- guix/packages.scm | 37 ++++++++++++++++++------------------- 1 file changed, 18 insertions(+), 19 deletions(-) (limited to 'guix') diff --git a/guix/packages.scm b/guix/packages.scm index 5ecb97f946..4ab8650340 100644 --- a/guix/packages.scm +++ b/guix/packages.scm @@ -355,25 +355,24 @@ object." (catch 'system-error (lambda () ;; In general we want to keep relative file names for modules. - (with-fluids ((%file-port-name-canonicalization 'relative)) - (call-with-input-file (search-path %load-path file) - (lambda (port) - (goto port line column) - (match (read port) - (('package inits ...) - (let ((field (assoc field inits))) - (match field - ((_ value) - ;; Put the `or' here, and not in the first argument of - ;; `and=>', to work around a compiler bug in 2.0.5. - (or (and=> (source-properties value) - source-properties->location) - (and=> (source-properties field) - source-properties->location))) - (_ - #f)))) - (_ - #f)))))) + (call-with-input-file (search-path %load-path file) + (lambda (port) + (goto port line column) + (match (read port) + (('package inits ...) + (let ((field (assoc field inits))) + (match field + ((_ value) + (let ((props (source-properties value))) + (and props + ;; Preserve the original file name, which may be a + ;; relative file name. + (let ((loc (source-properties->location props))) + (set-field loc (location-file) file))))) + (_ + #f)))) + (_ + #f))))) (lambda _ #f))) (_ #f))) -- cgit v1.2.3 From 4a6ec23a9780bd75a7e527bd0dfb1943347869bb Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sat, 21 Mar 2020 23:08:04 +0100 Subject: download: Delete the output file upon failure. This allows ENOSPC conditions to be properly reported as such rather than as a hash mismatch due to the availability of a truncated file. Fixes . Reported by Maxim Cournoyer . * guix/build/download.scm (url-fetch): In the failure case, delete FILE. --- guix/build/download.scm | 7 +++++++ 1 file changed, 7 insertions(+) (limited to 'guix') diff --git a/guix/build/download.scm b/guix/build/download.scm index c647d00f6b..46af149b2f 100644 --- a/guix/build/download.scm +++ b/guix/build/download.scm @@ -693,6 +693,13 @@ otherwise simply ignore them." (() (format (current-error-port) "failed to download ~s from ~s~%" file url) + + ;; Remove FILE in case we made an incomplete download, for example due + ;; to ENOSPC. + (catch 'system-error + (lambda () + (delete-file file)) + (const #f)) #f)))) ;;; download.scm ends here -- cgit v1.2.3 From 9a067fe7ee3978a2f4f0ca0e89965f0fe49f4ce8 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 19 Mar 2020 11:14:29 +0100 Subject: syscalls: 'with-file-lock' re-grabs lock when reentering its dynamic extent. * guix/build/syscalls.scm (call-with-file-lock) (call-with-file-lock/no-wait): Initialize PORT in the 'dynamic-wind' "in" handler. This allows us to re-enter a captured continuation and have the lock grabbed anew. --- guix/build/syscalls.scm | 64 +++++++++++++++++++++++++------------------------ 1 file changed, 33 insertions(+), 31 deletions(-) (limited to 'guix') diff --git a/guix/build/syscalls.scm b/guix/build/syscalls.scm index ae79a9708f..0938ec0ff1 100644 --- a/guix/build/syscalls.scm +++ b/guix/build/syscalls.scm @@ -1104,47 +1104,49 @@ exception if it's already taken." #t) (define (call-with-file-lock file thunk) - (let ((port (catch 'system-error - (lambda () - (lock-file file)) - (lambda args - ;; When using the statically-linked Guile in the initrd, - ;; 'fcntl-flock' returns ENOSYS unconditionally. Ignore - ;; that error since we're typically the only process running - ;; at this point. - (if (= ENOSYS (system-error-errno args)) - #f - (apply throw args)))))) + (let ((port #f)) (dynamic-wind (lambda () - #t) + (set! port + (catch 'system-error + (lambda () + (lock-file file)) + (lambda args + ;; When using the statically-linked Guile in the initrd, + ;; 'fcntl-flock' returns ENOSYS unconditionally. Ignore + ;; that error since we're typically the only process running + ;; at this point. + (if (= ENOSYS (system-error-errno args)) + #f + (apply throw args)))))) thunk (lambda () (when port (unlock-file port)))))) (define (call-with-file-lock/no-wait file thunk handler) - (let ((port (catch #t - (lambda () - (lock-file file #:wait? #f)) - (lambda (key . args) - (match key - ('flock-error - (apply handler args) - ;; No open port to the lock, so return #f. - #f) - ('system-error - ;; When using the statically-linked Guile in the initrd, - ;; 'fcntl-flock' returns ENOSYS unconditionally. Ignore - ;; that error since we're typically the only process running - ;; at this point. - (if (= ENOSYS (system-error-errno (cons key args))) - #f - (apply throw key args))) - (_ (apply throw key args))))))) + (let ((port #f)) (dynamic-wind (lambda () - #t) + (set! port + (catch #t + (lambda () + (lock-file file #:wait? #f)) + (lambda (key . args) + (match key + ('flock-error + (apply handler args) + ;; No open port to the lock, so return #f. + #f) + ('system-error + ;; When using the statically-linked Guile in the initrd, + ;; 'fcntl-flock' returns ENOSYS unconditionally. Ignore + ;; that error since we're typically the only process running + ;; at this point. + (if (= ENOSYS (system-error-errno (cons key args))) + #f + (apply throw key args))) + (_ (apply throw key args))))))) thunk (lambda () (when port -- cgit v1.2.3 From 041b340da409078951267b6a8c43b27716e6b7ec Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 18 Mar 2020 22:17:39 +0100 Subject: store: Add 'with-build-handler'. * guix/store.scm (current-build-prompt): New variable. (call-with-build-handler, invoke-build-handler): New procedures. (with-build-handler): New macro. * tests/store.scm ("with-build-handler"): New test. --- .dir-locals.el | 1 + guix/store.scm | 75 +++++++++++++++++++++++++++++++++++++++++++++------------ tests/store.scm | 34 +++++++++++++++++++++++++- 3 files changed, 94 insertions(+), 16 deletions(-) (limited to 'guix') diff --git a/.dir-locals.el b/.dir-locals.el index 1976f7e60d..ce305602f2 100644 --- a/.dir-locals.el +++ b/.dir-locals.el @@ -68,6 +68,7 @@ (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 'with-build-handler 'scheme-indent-function 1)) (eval . (put 'mlambda 'scheme-indent-function 1)) (eval . (put 'mlambdaq 'scheme-indent-function 1)) diff --git a/guix/store.scm b/guix/store.scm index 2c3675dca6..fdaae27914 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, 2019 Ludovic Courtès +;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès ;;; Copyright © 2018 Jan Nieuwenhuizen ;;; Copyright © 2019, 2020 Mathieu Othacehe ;;; Copyright © 2020 Florian Pelz @@ -104,6 +104,7 @@ add-to-store add-file-tree-to-store binary-file + with-build-handler build-things build query-failed-paths @@ -1222,6 +1223,46 @@ an arbitrary directory layout in the store without creating a derivation." (hash-set! cache tree result) result))))) +(define current-build-prompt + ;; When true, this is the prompt to abort to when 'build-things' is called. + (make-parameter #f)) + +(define (call-with-build-handler handler thunk) + "Register HANDLER as a \"build handler\" and invoke THUNK." + (define tag + (make-prompt-tag "build handler")) + + (parameterize ((current-build-prompt tag)) + (call-with-prompt tag + thunk + (lambda (k . args) + ;; Since HANDLER may call K, which in turn may call 'build-things' + ;; again, reinstate a prompt (thus, it's not a tail call.) + (call-with-build-handler handler + (lambda () + (apply handler k args))))))) + +(define (invoke-build-handler store things mode) + "Abort to 'current-build-prompt' if it is set." + (or (not (current-build-prompt)) + (abort-to-prompt (current-build-prompt) store things mode))) + +(define-syntax-rule (with-build-handler handler exp ...) + "Register HANDLER as a \"build handler\" and invoke THUNK. When +'build-things' is called within the dynamic extent of the call to THUNK, +HANDLER is invoked like so: + + (HANDLER CONTINUE STORE THINGS MODE) + +where CONTINUE is the continuation, and the remaining arguments are those that +were passed to 'build-things'. + +Build handlers are useful to announce a build plan with 'show-what-to-build' +and to implement dry runs (by not invoking CONTINUE) in a way that gracefully +deals with \"dynamic dependencies\" such as grafts---derivations that depend +on the build output of a previous derivation." + (call-with-build-handler handler (lambda () exp ...))) + (define build-things (let ((build (operation (build-things (string-list things) (integer mode)) @@ -1236,20 +1277,24 @@ 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. Alternately, an element of THING can be a derivation/output name pair, in which case the daemon will attempt to substitute just the requested output of -the derivation. Return #t on success." - (let ((things (map (match-lambda - ((drv . output) (string-append drv "!" output)) - (thing thing)) - things))) - (parameterize ((current-store-protocol-version - (store-connection-version store))) - (if (>= (store-connection-minor-version store) 15) - (build store things mode) - (if (= mode (build-mode normal)) - (build/old store things) - (raise (condition (&store-protocol-error - (message "unsupported build mode") - (status 1))))))))))) +the derivation. Return #t on success. + +When a handler is installed with 'with-build-handler', it is called any time +'build-things' is called." + (or (not (invoke-build-handler store things mode)) + (let ((things (map (match-lambda + ((drv . output) (string-append drv "!" output)) + (thing thing)) + things))) + (parameterize ((current-store-protocol-version + (store-connection-version store))) + (if (>= (store-connection-minor-version store) 15) + (build store things mode) + (if (= mode (build-mode normal)) + (build/old store things) + (raise (condition (&store-protocol-error + (message "unsupported build mode") + (status 1)))))))))))) (define-operation (add-temp-root (store-path path)) "Make PATH a temporary root for the duration of the current session. diff --git a/tests/store.scm b/tests/store.scm index 2b14a4af0a..b61a981b28 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, 2019 Ludovic Courtès +;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès ;;; ;;; This file is part of GNU Guix. ;;; @@ -380,6 +380,38 @@ (equal? (valid-derivers %store o) (list (derivation-file-name d)))))) +(test-equal "with-build-handler" + 'success + (let* ((b (add-text-to-store %store "build" "echo $foo > $out" '())) + (s (add-to-store %store "bash" #t "sha256" + (search-bootstrap-binary "bash" + (%current-system)))) + (d1 (derivation %store "the-thing" + s `("-e" ,b) + #:env-vars `(("foo" . ,(random-text))) + #:sources (list b s))) + (d2 (derivation %store "the-thing" + s `("-e" ,b) + #:env-vars `(("foo" . ,(random-text)) + ("bar" . "baz")) + #:sources (list b s))) + (o1 (derivation->output-path d1)) + (o2 (derivation->output-path d2))) + (with-build-handler + (let ((counter 0)) + (lambda (continue store things mode) + (match things + ((drv) + (set! counter (+ 1 counter)) + (if (string=? drv (derivation-file-name d1)) + (continue #t) + (and (string=? drv (derivation-file-name d2)) + (= counter 2) + 'success)))))) + (build-derivations %store (list d1)) + (build-derivations %store (list d2)) + 'fail))) + (test-assert "topologically-sorted, one item" (let* ((a (add-text-to-store %store "a" "a")) (b (add-text-to-store %store "b" "b" (list a))) -- cgit v1.2.3 From 07ce23e011d18460e7ff5553d4ff640f7073075b Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 18 Mar 2020 22:19:05 +0100 Subject: ui: Add a notification build handler. * guix/ui.scm (build-notifier): New variable. --- guix/ui.scm | 38 ++++++++++++++++++++++++++++++++++++++ 1 file changed, 38 insertions(+) (limited to 'guix') diff --git a/guix/ui.scm b/guix/ui.scm index 6f1ca9c0b2..46286c183d 100644 --- a/guix/ui.scm +++ b/guix/ui.scm @@ -93,6 +93,7 @@ string->number* size->number show-derivation-outputs + build-notifier show-what-to-build show-what-to-build* show-manifest-transaction @@ -1045,6 +1046,43 @@ check and report what is prerequisites are available for download." (define show-what-to-build* (store-lift show-what-to-build)) +(define* (build-notifier #:key (dry-run? #f) (use-substitutes? #t)) + "Return a procedure suitable for 'with-build-handler' that, when +'build-things' is called, invokes 'show-what-to-build' to display the build +plan. When DRY-RUN? is true, the 'with-build-handler' form returns without +any build happening." + (define not-comma + (char-set-complement (char-set #\,))) + + (define (read-derivation-from-file* item) + (catch 'system-error + (lambda () + (read-derivation-from-file item)) + (const #f))) + + (lambda (continue store things mode) + (define inputs + ;; List of derivation inputs to build. Filter out non-existent '.drv' + ;; files because the daemon transparently tries to substitute them. + (filter-map (match-lambda + (((? derivation-path? drv) . output) + (let ((drv (read-derivation-from-file* drv)) + (outputs (string-tokenize output not-comma))) + (and drv (derivation-input drv outputs)))) + ((? derivation-path? drv) + (and=> (read-derivation-from-file* drv) + derivation-input)) + (_ + #f)) + things)) + + (show-what-to-build store inputs + #:dry-run? dry-run? + #:use-substitutes? use-substitutes? + #:mode mode) + (unless dry-run? + (continue #t)))) + (define (right-arrow port) "Return either a string containing the 'RIGHT ARROW' character, or an ASCII replacement if PORT is not Unicode-capable." -- cgit v1.2.3 From 62195b9a8fd6846117c5d7698842748300d13e31 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 18 Mar 2020 22:46:39 +0100 Subject: guix build: Use 'with-build-handler'. Fixes . Reported by Andreas Enge . * guix/scripts/build.scm (guix-build): Wrap 'parameterize' in 'with-build-handler'. Remove explicit call to 'show-what-to-build'. Call 'build-derivations' regardless of whether OPTS contains 'dry-run?'. --- guix/scripts/build.scm | 118 ++++++++++++++++++++++++------------------------- 1 file changed, 57 insertions(+), 61 deletions(-) (limited to 'guix') diff --git a/guix/scripts/build.scm b/guix/scripts/build.scm index da2a675ce2..af18d8b6f9 100644 --- a/guix/scripts/build.scm +++ b/guix/scripts/build.scm @@ -952,64 +952,60 @@ needed." ;; Set the build options before we do anything else. (set-build-options-from-command-line store opts) - (parameterize ((current-terminal-columns (terminal-columns)) - - ;; Set grafting upfront in case the user's input - ;; depends on it (e.g., a manifest or code snippet that - ;; calls 'gexp->derivation'). - (%graft? graft?)) - (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)) - ;; If FILE is a .drv that's not in - ;; store, keep it so that it can be - ;; substituted. - (and (or (not (derivation-path? file)) - (not (file-exists? 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?) - ;; Pass 'show-build-log' the output file names, not the - ;; derivation file names, because there can be several - ;; derivations leading to the same output. - (for-each (cut show-build-log store <> urls) - (delete-duplicates - (append (map derivation->output-path 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 (append drv items) - 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-build-handler (build-notifier #:use-substitutes? + (assoc-ref opts 'substitutes?) + #:dry-run? + (assoc-ref opts 'dry-run?)) + (parameterize ((current-terminal-columns (terminal-columns)) + + ;; Set grafting upfront in case the user's input + ;; depends on it (e.g., a manifest or code snippet that + ;; calls 'gexp->derivation'). + (%graft? graft?)) + (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)) + ;; If FILE is a .drv that's not in + ;; store, keep it so that it can be + ;; substituted. + (and (or (not (derivation-path? file)) + (not (file-exists? file))) + file)) + (_ #f)) + opts)) + (roots (filter-map (match-lambda + (('gc-root . root) root) + (_ #f)) + opts))) + + (cond ((assoc-ref opts 'log-file?) + ;; Pass 'show-build-log' the output file names, not the + ;; derivation file names, because there can be several + ;; derivations leading to the same output. + (for-each (cut show-build-log store <> urls) + (delete-duplicates + (append (map derivation->output-path 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)) + (else + (and (build-derivations store (append drv items) + mode) + (for-each show-derivation-outputs drv) + (for-each (cut register-root store <> <>) + (map (lambda (drv) + (map cdr + (derivation->output-paths drv))) + drv) + roots))))))))))) -- cgit v1.2.3 From bdda46a67d5b8d9d45a53a7d6b32d9acb9374ae2 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 18 Mar 2020 22:57:28 +0100 Subject: deploy: Use 'with-build-handler'. Until now, 'guix deploy' would never display what is going to be built. * guix/scripts/deploy.scm (guix-deploy): Wrap 'for-each' in 'with-build-handler'. --- guix/scripts/deploy.scm | 34 ++++++++++++++++++---------------- 1 file changed, 18 insertions(+), 16 deletions(-) (limited to 'guix') diff --git a/guix/scripts/deploy.scm b/guix/scripts/deploy.scm index ad05c333dc..a82dde00a4 100644 --- a/guix/scripts/deploy.scm +++ b/guix/scripts/deploy.scm @@ -108,19 +108,21 @@ Perform the deployment specified by FILE.\n")) (with-status-verbosity (assoc-ref opts 'verbosity) (with-store store (set-build-options-from-command-line store opts) - (for-each (lambda (machine) - (info (G_ "deploying to ~a...~%") - (machine-display-name machine)) - (parameterize ((%graft? (assq-ref opts 'graft?))) - (guard (c ((message-condition? c) - (report-error (G_ "failed to deploy ~a: ~a~%") - (machine-display-name machine) - (condition-message c))) - ((deploy-error? c) - (when (deploy-error-should-roll-back c) - (info (G_ "rolling back ~a...~%") - (machine-display-name machine)) - (run-with-store store (roll-back-machine machine))) - (apply throw (deploy-error-captured-args c)))) - (run-with-store store (deploy-machine machine))))) - machines))))) + (with-build-handler (build-notifier #:use-substitutes? + (assoc-ref opts 'substitutes?)) + (for-each (lambda (machine) + (info (G_ "deploying to ~a...~%") + (machine-display-name machine)) + (parameterize ((%graft? (assq-ref opts 'graft?))) + (guard (c ((message-condition? c) + (report-error (G_ "failed to deploy ~a: ~a~%") + (machine-display-name machine) + (condition-message c))) + ((deploy-error? c) + (when (deploy-error-should-roll-back c) + (info (G_ "rolling back ~a...~%") + (machine-display-name machine)) + (run-with-store store (roll-back-machine machine))) + (apply throw (deploy-error-captured-args c)))) + (run-with-store store (deploy-machine machine))))) + machines)))))) -- cgit v1.2.3 From 5f5e9a5cd63352875ea968f89bc4b8cb4318cc02 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 18 Mar 2020 23:00:13 +0100 Subject: pack: Use 'with-build-handler'. * guix/scripts/pack.scm (guix-pack): Wrap 'parameterize' in 'with-build-handler'. Remove explicit call to 'show-what-to-build'. Call 'build-derivations' regardless of whether OPTS contains 'dry-run?'. --- guix/scripts/pack.scm | 204 +++++++++++++++++++++++++------------------------- 1 file changed, 101 insertions(+), 103 deletions(-) (limited to 'guix') diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm index 652b4c63c4..6829d7265f 100644 --- a/guix/scripts/pack.scm +++ b/guix/scripts/pack.scm @@ -1022,108 +1022,106 @@ Create a bundle of PACKAGE.\n")) ;; Set the build options before we do anything else. (set-build-options-from-command-line store opts) - (parameterize ((%graft? (assoc-ref opts 'graft?)) - (%guile-for-build (package-derivation - store - (if (assoc-ref opts 'bootstrap?) - %bootstrap-guile - (canonical-package guile-2.2)) - (assoc-ref opts 'system) - #:graft? (assoc-ref opts 'graft?)))) - (let* ((dry-run? (assoc-ref opts 'dry-run?)) - (derivation? (assoc-ref opts 'derivation-only?)) - (relocatable? (assoc-ref opts 'relocatable?)) - (proot? (eq? relocatable? 'proot)) - (manifest (let ((manifest (manifest-from-args store opts))) - ;; Note: We cannot honor '--bootstrap' here because - ;; 'glibc-bootstrap' lacks 'libc.a'. - (if relocatable? - (map-manifest-entries - (cut wrapped-manifest-entry <> #:proot? proot?) - manifest) - manifest))) - (pack-format (assoc-ref opts 'format)) - (name (string-append (symbol->string pack-format) - "-pack")) - (target (assoc-ref opts 'target)) - (bootstrap? (assoc-ref opts 'bootstrap?)) - (compressor (if bootstrap? - bootstrap-xz - (assoc-ref opts 'compressor))) - (archiver (if (equal? pack-format 'squashfs) - squashfs-tools - (if bootstrap? - %bootstrap-coreutils&co - tar))) - (symlinks (assoc-ref opts 'symlinks)) - (build-image (match (assq-ref %formats pack-format) - ((? procedure? proc) proc) - (#f - (leave (G_ "~a: unknown pack format~%") - pack-format)))) - (localstatedir? (assoc-ref opts 'localstatedir?)) - (entry-point (assoc-ref opts 'entry-point)) - (profile-name (assoc-ref opts 'profile-name)) - (gc-root (assoc-ref opts 'gc-root))) - (define (lookup-package package) - (manifest-lookup manifest (manifest-pattern (name package)))) - - (when (null? (manifest-entries manifest)) - (warning (G_ "no packages specified; building an empty pack~%"))) - - (when (and (eq? pack-format 'squashfs) - (not (any lookup-package '("bash" "bash-minimal")))) - (warning (G_ "Singularity requires you to provide a shell~%")) - (display-hint (G_ "Add @code{bash} or @code{bash-minimal} \ + (with-build-handler (build-notifier #:dry-run? + (assoc-ref opts 'dry-run?) + #:use-substitutes? + (assoc-ref opts 'substitutes?)) + (parameterize ((%graft? (assoc-ref opts 'graft?)) + (%guile-for-build (package-derivation + store + (if (assoc-ref opts 'bootstrap?) + %bootstrap-guile + (canonical-package guile-2.2)) + (assoc-ref opts 'system) + #:graft? (assoc-ref opts 'graft?)))) + (let* ((derivation? (assoc-ref opts 'derivation-only?)) + (relocatable? (assoc-ref opts 'relocatable?)) + (proot? (eq? relocatable? 'proot)) + (manifest (let ((manifest (manifest-from-args store opts))) + ;; Note: We cannot honor '--bootstrap' here because + ;; 'glibc-bootstrap' lacks 'libc.a'. + (if relocatable? + (map-manifest-entries + (cut wrapped-manifest-entry <> #:proot? proot?) + manifest) + manifest))) + (pack-format (assoc-ref opts 'format)) + (name (string-append (symbol->string pack-format) + "-pack")) + (target (assoc-ref opts 'target)) + (bootstrap? (assoc-ref opts 'bootstrap?)) + (compressor (if bootstrap? + bootstrap-xz + (assoc-ref opts 'compressor))) + (archiver (if (equal? pack-format 'squashfs) + squashfs-tools + (if bootstrap? + %bootstrap-coreutils&co + tar))) + (symlinks (assoc-ref opts 'symlinks)) + (build-image (match (assq-ref %formats pack-format) + ((? procedure? proc) proc) + (#f + (leave (G_ "~a: unknown pack format~%") + pack-format)))) + (localstatedir? (assoc-ref opts 'localstatedir?)) + (entry-point (assoc-ref opts 'entry-point)) + (profile-name (assoc-ref opts 'profile-name)) + (gc-root (assoc-ref opts 'gc-root))) + (define (lookup-package package) + (manifest-lookup manifest (manifest-pattern (name package)))) + + (when (null? (manifest-entries manifest)) + (warning (G_ "no packages specified; building an empty pack~%"))) + + (when (and (eq? pack-format 'squashfs) + (not (any lookup-package '("bash" "bash-minimal")))) + (warning (G_ "Singularity requires you to provide a shell~%")) + (display-hint (G_ "Add @code{bash} or @code{bash-minimal} \ to your package list."))) - (run-with-store store - (mlet* %store-monad ((profile (profile-derivation - manifest - - ;; Always produce relative - ;; symlinks for Singularity (see - ;; ). - #:relative-symlinks? - (or relocatable? - (eq? 'squashfs pack-format)) - - #:hooks (if bootstrap? - '() - %default-profile-hooks) - #:locales? (not bootstrap?) - #:target target)) - (drv (build-image name profile - #:target - target - #:compressor - compressor - #:symlinks - symlinks - #:localstatedir? - localstatedir? - #:entry-point - entry-point - #:profile-name - profile-name - #:archiver - archiver))) - (mbegin %store-monad - (munless derivation? - (show-what-to-build* (list drv) - #:use-substitutes? - (assoc-ref opts 'substitutes?) - #:dry-run? dry-run?)) - (mwhen derivation? - (return (format #t "~a~%" - (derivation-file-name drv)))) - (munless (or derivation? dry-run?) - (built-derivations (list drv)) - (mwhen gc-root - (register-root* (match (derivation->output-paths drv) - (((names . items) ...) - items)) - gc-root)) - (return (format #t "~a~%" - (derivation->output-path drv)))))) - #:system (assoc-ref opts 'system)))))))) + (run-with-store store + (mlet* %store-monad ((profile (profile-derivation + manifest + + ;; Always produce relative + ;; symlinks for Singularity (see + ;; ). + #:relative-symlinks? + (or relocatable? + (eq? 'squashfs pack-format)) + + #:hooks (if bootstrap? + '() + %default-profile-hooks) + #:locales? (not bootstrap?) + #:target target)) + (drv (build-image name profile + #:target + target + #:compressor + compressor + #:symlinks + symlinks + #:localstatedir? + localstatedir? + #:entry-point + entry-point + #:profile-name + profile-name + #:archiver + archiver))) + (mbegin %store-monad + (mwhen derivation? + (return (format #t "~a~%" + (derivation-file-name drv)))) + (munless derivation? + (built-derivations (list drv)) + (mwhen gc-root + (register-root* (match (derivation->output-paths drv) + (((names . items) ...) + items)) + gc-root)) + (return (format #t "~a~%" + (derivation->output-path drv)))))) + #:system (assoc-ref opts 'system))))))))) -- cgit v1.2.3 From 65ffb9388c1c3d870cb07e4cb3ef12c9ac06a161 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 19 Mar 2020 10:42:28 +0100 Subject: guix package, pull: Use 'with-build-handler'. * guix/scripts/package.scm (build-and-use-profile): Remove #:dry-run? and #:use-substitutes?. Remove call to 'show-what-to-build' and 'dry-run?' special case. (process-actions): Adjust accordingly. (guix-package*): Wrap 'parameterize' in 'with-build-handler'. * guix/scripts/pull.scm (build-and-install): Remove #:use-substitutes? and #:dry-run? and adjust 'update-profile' call accordingly. Remove 'dry-run?' conditional. (guix-pull): Wrap body in 'with-build-handler'. --- guix/scripts/package.scm | 29 +++++------- guix/scripts/pull.scm | 120 +++++++++++++++++++++++------------------------ 2 files changed, 72 insertions(+), 77 deletions(-) (limited to 'guix') diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm index e620309e30..b5d16acec0 100644 --- a/guix/scripts/package.scm +++ b/guix/scripts/package.scm @@ -132,8 +132,7 @@ denote ranges as interpreted by 'matching-generations'." #:key (hooks %default-profile-hooks) allow-collisions? - bootstrap? use-substitutes? - dry-run?) + bootstrap?) "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. HOOKS is a list of \"profile @@ -144,12 +143,8 @@ hooks\" run when building the profile." #:hooks (if bootstrap? '() hooks) #:locales? (not bootstrap?)))) (prof (derivation->output-path prof-drv))) - (show-what-to-build store (list prof-drv) - #:use-substitutes? use-substitutes? - #:dry-run? dry-run?) (cond - (dry-run? #t) ((and (file-exists? profile) (and=> (readlink* profile) (cut string=? prof <>))) (format (current-error-port) (G_ "nothing to be done~%"))) @@ -920,9 +915,7 @@ processed, #f otherwise." #:dry-run? dry-run?) (build-and-use-profile store profile new #:allow-collisions? allow-collisions? - #:bootstrap? bootstrap? - #:use-substitutes? substitutes? - #:dry-run? dry-run?))))) + #:bootstrap? bootstrap?))))) ;;; @@ -951,10 +944,14 @@ option processing with 'parse-command-line'." (%graft? (assoc-ref opts 'graft?))) (with-status-verbosity (assoc-ref opts 'verbosity) (set-build-options-from-command-line (%store) opts) - (parameterize ((%guile-for-build - (package-derivation - (%store) - (if (assoc-ref opts 'bootstrap?) - %bootstrap-guile - (canonical-package guile-2.2))))) - (process-actions (%store) opts))))))) + (with-build-handler (build-notifier #:use-substitutes? + (assoc-ref opts 'substitutes?) + #:dry-run? + (assoc-ref opts 'dry-run?)) + (parameterize ((%guile-for-build + (package-derivation + (%store) + (if (assoc-ref opts 'bootstrap?) + %bootstrap-guile + (canonical-package guile-2.2))))) + (process-actions (%store) opts)))))))) diff --git a/guix/scripts/pull.scm b/guix/scripts/pull.scm index 51d4da209a..7fc23e1b47 100644 --- a/guix/scripts/pull.scm +++ b/guix/scripts/pull.scm @@ -389,8 +389,7 @@ previous generation. Return true if there are news to display." (display-channel-news profile)) -(define* (build-and-install instances profile - #:key use-substitutes? dry-run?) +(define* (build-and-install instances profile) "Build the tool from SOURCE, and install it in PROFILE. When DRY-RUN? is true, display what would be built without actually building it." (define update-profile @@ -403,29 +402,27 @@ 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 - #:use-substitutes? use-substitutes? - #:hooks %channel-profile-hooks - #:dry-run? dry-run?) - (munless dry-run? - (return (newline)) - (return - (let ((more? (list (display-profile-news profile #:concise? #t) - (display-channel-news-headlines profile)))) - (when (any ->bool more?) - (display-hint - (G_ "Run @command{guix pull --news} to read all the news."))))) - (if guix-command - (let ((new (map (cut string-append <> "/bin/guix") - (list (user-friendly-profile profile) - profile)))) - ;; Is the 'guix' command previously in $PATH the same as the new - ;; one? If the answer is "no", then suggest 'hash guix'. - (unless (member guix-command new) - (display-hint (format #f (G_ "After setting @code{PATH}, run + #:hooks %channel-profile-hooks) + + (return + (let ((more? (list (display-profile-news profile #:concise? #t) + (display-channel-news-headlines profile)))) + (newline) + (when (any ->bool more?) + (display-hint + (G_ "Run @command{guix pull --news} to read all the news."))))) + (if guix-command + (let ((new (map (cut string-append <> "/bin/guix") + (list (user-friendly-profile profile) + profile)))) + ;; Is the 'guix' command previously in $PATH the same as the new + ;; one? If the answer is "no", then suggest 'hash guix'. + (unless (member guix-command new) + (display-hint (format #f (G_ "After setting @code{PATH}, run @command{hash guix} to make sure your shell refers to @file{~a}.") - (first new)))) - (return #f)) - (return #f)))))) + (first new)))) + (return #f)) + (return #f))))) (define (honor-lets-encrypt-certificates! store) "Tell Guile-Git to use the Let's Encrypt certificates." @@ -760,10 +757,12 @@ Use '~/.config/guix/channels.scm' instead.")) (define (guix-pull . args) (with-error-handling (with-git-error-handling - (let* ((opts (parse-command-line args %options - (list %default-options))) - (channels (channel-list opts)) - (profile (or (assoc-ref opts 'profile) %current-profile))) + (let* ((opts (parse-command-line args %options + (list %default-options))) + (substitutes? (assoc-ref opts 'substitutes?)) + (dry-run? (assoc-ref opts 'dry-run?)) + (channels (channel-list opts)) + (profile (or (assoc-ref opts 'profile) %current-profile))) (cond ((assoc-ref opts 'query) (process-query opts profile)) ((assoc-ref opts 'generation) @@ -773,38 +772,37 @@ Use '~/.config/guix/channels.scm' instead.")) (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))) - (format (current-error-port) - (N_ "Building from this channel:~%" - "Building from these channels:~%" - (length instances))) - (for-each (lambda (instance) - (let ((channel - (channel-instance-channel instance))) - (format (current-error-port) - " ~10a~a\t~a~%" - (channel-name channel) - (channel-url channel) - (string-take - (channel-instance-commit instance) - 7)))) - instances) - (parameterize ((%guile-for-build - (package-derivation - store - (if (assoc-ref opts 'bootstrap?) - %bootstrap-guile - (canonical-package guile-2.2))))) - (with-profile-lock profile - (run-with-store store - (build-and-install instances profile - #:dry-run? - (assoc-ref opts 'dry-run?) - #:use-substitutes? - (assoc-ref opts 'substitutes?))))))))))))))) + (with-build-handler (build-notifier #:use-substitutes? + substitutes? + #:dry-run? dry-run?) + (set-build-options-from-command-line store opts) + (ensure-default-profile) + (honor-x509-certificates store) + + (let ((instances (latest-channel-instances store channels))) + (format (current-error-port) + (N_ "Building from this channel:~%" + "Building from these channels:~%" + (length instances))) + (for-each (lambda (instance) + (let ((channel + (channel-instance-channel instance))) + (format (current-error-port) + " ~10a~a\t~a~%" + (channel-name channel) + (channel-url channel) + (string-take + (channel-instance-commit instance) + 7)))) + instances) + (parameterize ((%guile-for-build + (package-derivation + store + (if (assoc-ref opts 'bootstrap?) + %bootstrap-guile + (canonical-package guile-2.2))))) + (with-profile-lock profile + (run-with-store store + (build-and-install instances profile))))))))))))))) ;;; pull.scm ends here -- cgit v1.2.3 From a0f480d623f71b7f0d93de192b86038317dc625b Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 19 Mar 2020 11:17:34 +0100 Subject: guix system: Use 'with-build-handler'. * guix/scripts/system.scm (reinstall-bootloader): Remove call to 'show-what-to-build*'. (perform-action): Call 'build-derivations' instead of 'maybe-build'. (process-action): Wrap 'run-with-store' in 'with-build-handler'. --- guix/scripts/system.scm | 82 +++++++++++++++++++++++++------------------------ 1 file changed, 42 insertions(+), 40 deletions(-) (limited to 'guix') diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm index ac2475c551..8d1938281a 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, 2019 Ludovic Courtès +;;; Copyright © 2014, 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès ;;; Copyright © 2016 Alex Kost ;;; Copyright © 2016, 2017, 2018 Chris Marusich ;;; Copyright © 2017, 2019 Mathieu Othacehe @@ -403,7 +403,6 @@ STORE is an open connection to the store." #:old-entries old-entries))) (drvs -> (list bootcfg))) (mbegin %store-monad - (show-what-to-build* drvs) (built-derivations drvs) ;; Only install bootloader configuration file. (install-bootloader local-eval bootloader-config bootcfg @@ -837,8 +836,7 @@ static checks." (% (if derivations-only? (return (for-each (compose println derivation-file-name) drvs)) - (maybe-build drvs #:dry-run? dry-run? - #:use-substitutes? use-substitutes?)))) + (built-derivations drvs)))) (if (or dry-run? derivations-only?) (return #f) @@ -1139,42 +1137,46 @@ resulting from command-line parsing." (with-store store (set-build-options-from-command-line store opts) - (run-with-store store - (mbegin %store-monad - (set-guile-for-build (default-guile)) - (case action - ((extension-graph) - (export-extension-graph os (current-output-port))) - ((shepherd-graph) - (export-shepherd-graph os (current-output-port))) - (else - (unless (memq action '(build init)) - (warn-about-old-distro #:suggested-command - "guix system reconfigure")) - - (perform-action action os - #:dry-run? dry? - #:derivations-only? (assoc-ref opts - 'derivations-only?) - #:use-substitutes? (assoc-ref opts 'substitutes?) - #:skip-safety-checks? - (assoc-ref opts 'skip-safety-checks?) - #:file-system-type (assoc-ref opts 'file-system-type) - #:image-size (assoc-ref opts 'image-size) - #:full-boot? (assoc-ref opts 'full-boot?) - #:container-shared-network? - (assoc-ref opts 'container-shared-network?) - #:mappings (filter-map (match-lambda - (('file-system-mapping . m) - m) - (_ #f)) - opts) - #:install-bootloader? bootloader? - #:target target-file - #:bootloader-target bootloader-target - #:gc-root (assoc-ref opts 'gc-root))))) - #:target target - #:system system)) + (with-build-handler (build-notifier #:use-substitutes? + (assoc-ref opts 'substitutes?) + #:dry-run? + (assoc-ref opts 'dry-run?)) + (run-with-store store + (mbegin %store-monad + (set-guile-for-build (default-guile)) + (case action + ((extension-graph) + (export-extension-graph os (current-output-port))) + ((shepherd-graph) + (export-shepherd-graph os (current-output-port))) + (else + (unless (memq action '(build init)) + (warn-about-old-distro #:suggested-command + "guix system reconfigure")) + + (perform-action action os + #:dry-run? dry? + #:derivations-only? (assoc-ref opts + 'derivations-only?) + #:use-substitutes? (assoc-ref opts 'substitutes?) + #:skip-safety-checks? + (assoc-ref opts 'skip-safety-checks?) + #:file-system-type (assoc-ref opts 'file-system-type) + #:image-size (assoc-ref opts 'image-size) + #:full-boot? (assoc-ref opts 'full-boot?) + #:container-shared-network? + (assoc-ref opts 'container-shared-network?) + #:mappings (filter-map (match-lambda + (('file-system-mapping . m) + m) + (_ #f)) + opts) + #:install-bootloader? bootloader? + #:target target-file + #:bootloader-target bootloader-target + #:gc-root (assoc-ref opts 'gc-root))))) + #:target target + #:system system))) (warn-about-disk-space))) (define (resolve-subcommand name) -- cgit v1.2.3 From bec3474107e73fc0ca3821a525025c27dc005288 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sun, 22 Mar 2020 11:50:40 +0100 Subject: ui: 'show-what-to-build' returns true when there are grafts to build. * guix/ui.scm (show-what-to-build): Distinguish between 'build/full' and 'build'. Return true whe 'build/full' is non-empty, thus taking grafts into account. --- guix/ui.scm | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) (limited to 'guix') diff --git a/guix/ui.scm b/guix/ui.scm index 46286c183d..12a998d9c6 100644 --- a/guix/ui.scm +++ b/guix/ui.scm @@ -934,7 +934,7 @@ check and report what is prerequisites are available for download." colorize-store-file-name identity)) - (let*-values (((build download) + (let*-values (((build/full download) (derivation-build-plan store inputs #:mode mode #:substitutable-info @@ -958,7 +958,7 @@ check and report what is prerequisites are available for download." #:hook ,hook #:build ,(cons file build)))))))) '(#:graft () #:hook () #:build ()) - build) + build/full) ((#:graft graft #:hook hook #:build build) (values graft hook build))))) (define installed-size @@ -1041,7 +1041,7 @@ check and report what is prerequisites are available for download." (check-available-space installed-size) - (pair? build))) + (pair? build/full))) (define show-what-to-build* (store-lift show-what-to-build)) -- cgit v1.2.3 From 883a1765a6edb29fb53c3f68eb2de9d839a3b7e1 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sun, 22 Mar 2020 11:52:41 +0100 Subject: ui: 'show-what-to-build' returns two values, for builds and downloads. * guix/ui.scm (show-what-to-build): Return two values. --- guix/ui.scm | 8 +++++--- 1 file changed, 5 insertions(+), 3 deletions(-) (limited to 'guix') diff --git a/guix/ui.scm b/guix/ui.scm index 12a998d9c6..1c0dd11edc 100644 --- a/guix/ui.scm +++ b/guix/ui.scm @@ -913,8 +913,10 @@ that the rest." derivations listed in DRV using MODE, a 'build-mode' value. The elements of DRV can be either derivations or derivation inputs. -Return #t if there's something to build, #f otherwise. When USE-SUBSTITUTES?, -check and report what is prerequisites are available for download." +Return two values: a Boolean indicating whether there's something to build, +and a Boolean indicating whether there's something to download. When +USE-SUBSTITUTES?, check and report what is prerequisites are available for +download." (define inputs (map (match-lambda ((? derivation? drv) (derivation-input drv)) @@ -1041,7 +1043,7 @@ check and report what is prerequisites are available for download." (check-available-space installed-size) - (pair? build/full))) + (values (pair? build/full) (pair? download)))) (define show-what-to-build* (store-lift show-what-to-build)) -- cgit v1.2.3 From 9b771305df5dfc31c06b81fbdeaae753ba5d4afe Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sun, 22 Mar 2020 11:53:21 +0100 Subject: ui: 'build-notifier' invokes continuation when there's nothing to do. * guix/ui.scm (build-notifier): Call CONTINUE when there's nothing to build or download, even when DRY-RUN? is true. --- guix/ui.scm | 15 +++++++++------ 1 file changed, 9 insertions(+), 6 deletions(-) (limited to 'guix') diff --git a/guix/ui.scm b/guix/ui.scm index 1c0dd11edc..b9ba8c0f7a 100644 --- a/guix/ui.scm +++ b/guix/ui.scm @@ -1078,12 +1078,15 @@ any build happening." #f)) things)) - (show-what-to-build store inputs - #:dry-run? dry-run? - #:use-substitutes? use-substitutes? - #:mode mode) - (unless dry-run? - (continue #t)))) + (let-values (((build? download?) + (show-what-to-build store inputs + #:dry-run? dry-run? + #:use-substitutes? use-substitutes? + #:mode mode))) + + (unless (and (or build? download?) + dry-run?) + (continue #t))))) (define (right-arrow port) "Return either a string containing the 'RIGHT ARROW' character, or an ASCII -- cgit v1.2.3 From 7473238f7de28f9c85e364364c3155a3bbb877ac Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sun, 22 Mar 2020 12:19:49 +0100 Subject: copy: Factorize 'with-store' & co. * guix/scripts/copy.scm (send-to-remote-host): Remove 'with-store' and 'set-build-options-from-command-line' call. Add 'local' parameter. (retrieve-from-remote-host): Likewise. (guix-copy): Wrap 'with-status-verbosity' in 'with-store' and add call to 'set-build-options-from-command-line'. --- guix/scripts/copy.scm | 84 +++++++++++++++++++++++++-------------------------- 1 file changed, 41 insertions(+), 43 deletions(-) (limited to 'guix') diff --git a/guix/scripts/copy.scm b/guix/scripts/copy.scm index 664cb32b7c..2542df6b19 100644 --- a/guix/scripts/copy.scm +++ b/guix/scripts/copy.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2016, 2017, 2019 Ludovic Courtès +;;; Copyright © 2016, 2017, 2019, 2020 Ludovic Courtès ;;; ;;; This file is part of GNU Guix. ;;; @@ -61,49 +61,45 @@ number (or #f) corresponding to SPEC." (x (leave (G_ "~a: invalid SSH specification~%") spec)))) -(define (send-to-remote-host target opts) +(define (send-to-remote-host local target opts) "Send ITEMS to TARGET. ITEMS is a list of store items or package names; for ; package names, build the underlying packages before sending them." - (with-store local - (set-build-options-from-command-line local opts) - (let-values (((user host port) - (ssh-spec->user+host+port target)) - ((drv items) - (options->derivations+files local opts))) - (show-what-to-build local drv - #:use-substitutes? (assoc-ref opts 'substitutes?) - #:dry-run? (assoc-ref opts 'dry-run?)) + (let-values (((user host port) + (ssh-spec->user+host+port target)) + ((drv items) + (options->derivations+files local opts))) + (show-what-to-build local drv + #:use-substitutes? (assoc-ref opts 'substitutes?) + #:dry-run? (assoc-ref opts 'dry-run?)) - (and (or (assoc-ref opts 'dry-run?) - (build-derivations local drv)) - (let* ((session (open-ssh-session host #:user user - #:port (or port 22))) - (sent (send-files local items - (connect-to-remote-daemon session) - #:recursive? #t))) - (format #t "~{~a~%~}" sent) - sent))))) + (and (or (assoc-ref opts 'dry-run?) + (build-derivations local drv)) + (let* ((session (open-ssh-session host #:user user + #:port (or port 22))) + (sent (send-files local items + (connect-to-remote-daemon session) + #:recursive? #t))) + (format #t "~{~a~%~}" sent) + sent)))) -(define (retrieve-from-remote-host source opts) +(define (retrieve-from-remote-host local source opts) "Retrieve ITEMS from SOURCE." - (with-store local - (let*-values (((user host port) - (ssh-spec->user+host+port source)) - ((session) - (open-ssh-session host #:user user #:port (or port 22))) - ((remote) - (connect-to-remote-daemon session))) - (set-build-options-from-command-line local opts) - ;; TODO: Here we could to compute and build the derivations on REMOTE - ;; rather than on LOCAL (one-off offloading) but that is currently too - ;; slow due to the many RPC round trips. So we just assume that REMOTE - ;; contains ITEMS. - (let*-values (((drv items) - (options->derivations+files local opts)) - ((retrieved) - (retrieve-files local items remote #:recursive? #t))) - (format #t "~{~a~%~}" retrieved) - retrieved)))) + (let*-values (((user host port) + (ssh-spec->user+host+port source)) + ((session) + (open-ssh-session host #:user user #:port (or port 22))) + ((remote) + (connect-to-remote-daemon session))) + ;; TODO: Here we could to compute and build the derivations on REMOTE + ;; rather than on LOCAL (one-off offloading) but that is currently too + ;; slow due to the many RPC round trips. So we just assume that REMOTE + ;; contains ITEMS. + (let*-values (((drv items) + (options->derivations+files local opts)) + ((retrieved) + (retrieve-files local items remote #:recursive? #t))) + (format #t "~{~a~%~}" retrieved) + retrieved))) ;;; @@ -176,7 +172,9 @@ 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))) - (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'~%")))))))) + (with-store store + (set-build-options-from-command-line store opts) + (with-status-verbosity (assoc-ref opts 'verbosity) + (cond (target (send-to-remote-host store target opts)) + (source (retrieve-from-remote-host store source opts)) + (else (leave (G_ "use '--to' or '--from'~%"))))))))) -- cgit v1.2.3 From 81c0b52bd6301a7ded157b270097a8074c8f2d50 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sun, 22 Mar 2020 12:25:39 +0100 Subject: copy: Actually implement '--dry-run'. * guix/scripts/copy.scm (%options): Add '--dry-run'. --- guix/scripts/copy.scm | 4 ++++ 1 file changed, 4 insertions(+) (limited to 'guix') diff --git a/guix/scripts/copy.scm b/guix/scripts/copy.scm index 2542df6b19..fdb684c6b6 100644 --- a/guix/scripts/copy.scm +++ b/guix/scripts/copy.scm @@ -138,6 +138,10 @@ Copy ITEMS to or from the specified host over SSH.\n")) (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)))) + (option '(#\h "help") #f #f (lambda args (show-help) -- cgit v1.2.3 From 3e6f65be7ae6f895ceb38f9a129c95e08761182b Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sun, 22 Mar 2020 12:26:05 +0100 Subject: copy: Use 'with-build-handler'. * guix/scripts/copy.scm (send-to-remote-host): Remove explicit 'show-what-to-build' call. Call 'build-derivations' unconditionally. (guix-copy): Wrap 'with-status-verbosity' in 'with-build-handler'. --- guix/scripts/copy.scm | 19 +++++++++---------- 1 file changed, 9 insertions(+), 10 deletions(-) (limited to 'guix') diff --git a/guix/scripts/copy.scm b/guix/scripts/copy.scm index fdb684c6b6..2fa31ecf45 100644 --- a/guix/scripts/copy.scm +++ b/guix/scripts/copy.scm @@ -68,12 +68,7 @@ package names, build the underlying packages before sending them." (ssh-spec->user+host+port target)) ((drv items) (options->derivations+files local opts))) - (show-what-to-build local drv - #:use-substitutes? (assoc-ref opts 'substitutes?) - #:dry-run? (assoc-ref opts 'dry-run?)) - - (and (or (assoc-ref opts 'dry-run?) - (build-derivations local drv)) + (and (build-derivations local drv) (let* ((session (open-ssh-session host #:user user #:port (or port 22))) (sent (send-files local items @@ -178,7 +173,11 @@ Copy ITEMS to or from the specified host over SSH.\n")) (target (assoc-ref opts 'destination))) (with-store store (set-build-options-from-command-line store opts) - (with-status-verbosity (assoc-ref opts 'verbosity) - (cond (target (send-to-remote-host store target opts)) - (source (retrieve-from-remote-host store source opts)) - (else (leave (G_ "use '--to' or '--from'~%"))))))))) + (with-build-handler (build-notifier #:use-substitutes? + (assoc-ref opts 'substitutes?) + #:dry-run? + (assoc-ref opts 'dry-run?)) + (with-status-verbosity (assoc-ref opts 'verbosity) + (cond (target (send-to-remote-host store target opts)) + (source (retrieve-from-remote-host store source opts)) + (else (leave (G_ "use '--to' or '--from'~%")))))))))) -- cgit v1.2.3 From 91601790d00bbfcdc943b974779cb3d153341ef6 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sun, 22 Mar 2020 12:31:07 +0100 Subject: packages: 'package-field-location' handles missing source properties. This is a followup to f2b24f01f42c1bad3ddffd140194de1aec38a5f8. * guix/packages.scm (package-field-location): Check whether 'source-properties->location' returns #f. This fixes the case where 'source-properties' returns the empty list. --- guix/packages.scm | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) (limited to 'guix') diff --git a/guix/packages.scm b/guix/packages.scm index 4ab8650340..70b1478c91 100644 --- a/guix/packages.scm +++ b/guix/packages.scm @@ -363,12 +363,12 @@ object." (let ((field (assoc field inits))) (match field ((_ value) - (let ((props (source-properties value))) - (and props + (let ((loc (and=> (source-properties value) + source-properties->location))) + (and loc ;; Preserve the original file name, which may be a ;; relative file name. - (let ((loc (source-properties->location props))) - (set-field loc (location-file) file))))) + (set-field loc (location-file) file)))) (_ #f)))) (_ -- cgit v1.2.3 From 5c79f238634c5adb6657f1b4b1bb4ddb8bb73ef1 Mon Sep 17 00:00:00 2001 From: Danny Milosavljevic Date: Tue, 18 Feb 2020 10:42:07 +0100 Subject: system: Add kernel-loadable-modules to operating-system. * gnu/system.scm (): Add kernel-loadable-modules. (operating-system-directory-base-entries): Use it. * doc/guix.texi (operating-system Reference): Document KERNEL-LOADABLE-MODULES. * gnu/build/linux-modules.scm (depmod): New procedure. (make-linux-module-directory): New procedure. Export it. * guix/profiles.scm (linux-module-database): New procedure. Export it. * gnu/tests/linux-modules.scm: New file. * gnu/local.mk (GNU_SYSTEM_MODULES): Add it. * gnu/packages/linux.scm (make-linux-libre*)[arguments]<#:phases>[install]: Disable depmod. Remove "build" and "source" symlinks. [native-inputs]: Remove kmod. --- doc/guix.texi | 4 ++ gnu/build/linux-modules.scm | 46 +++++++++++++++++++- gnu/local.mk | 1 + gnu/packages/linux.scm | 26 ++++++++--- gnu/system.scm | 16 +++++-- gnu/tests/linux-modules.scm | 103 ++++++++++++++++++++++++++++++++++++++++++++ guix/profiles.scm | 50 ++++++++++++++++++++- 7 files changed, 235 insertions(+), 11 deletions(-) create mode 100644 gnu/tests/linux-modules.scm (limited to 'guix') diff --git a/doc/guix.texi b/doc/guix.texi index 92125abccc..6346cf78a1 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -11221,6 +11221,10 @@ The package object of the operating system kernel to use@footnote{Currently only the Linux-libre kernel is supported. In the future, it will be possible to use the GNU@tie{}Hurd.}. +@item @code{kernel-loadable-modules} (default: '()) +A list of objects (usually packages) to collect loadable kernel modules +from--e.g. @code{(list ddcci-driver-linux)}. + @item @code{kernel-arguments} (default: @code{'("quiet")}) List of strings or gexps representing additional arguments to pass on the command-line of the kernel---e.g., @code{("console=ttyS0")}. diff --git a/gnu/build/linux-modules.scm b/gnu/build/linux-modules.scm index a149eff329..aa1c7cfeae 100644 --- a/gnu/build/linux-modules.scm +++ b/gnu/build/linux-modules.scm @@ -22,12 +22,14 @@ #:use-module (guix elf) #:use-module (guix glob) #:use-module (guix build syscalls) - #:use-module ((guix build utils) #:select (find-files)) + #:use-module ((guix build utils) #:select (find-files invoke)) + #:use-module (guix build union) #:use-module (rnrs io ports) #:use-module (rnrs bytevectors) #:use-module (srfi srfi-1) #:use-module (srfi srfi-11) #:use-module (srfi srfi-26) + #:use-module (ice-9 ftw) #:use-module (ice-9 vlist) #:use-module (ice-9 match) #:use-module (ice-9 rdelim) @@ -56,7 +58,9 @@ write-module-name-database write-module-alias-database - write-module-device-database)) + write-module-device-database + + make-linux-module-directory)) ;;; Commentary: ;;; @@ -631,4 +635,42 @@ be loaded on-demand, such as file system modules." module devname type major minor))) aliases)))) +(define (depmod version directory) + "Given an (existing) DIRECTORY, invoke depmod on it for +kernel version VERSION." + (let ((destination-directory (string-append directory "/lib/modules/" + version)) + ;; Note: "System.map" is an input file. + (maps-file (string-append directory "/System.map")) + ;; Note: "Module.symvers" is an input file. + (symvers-file (string-append directory "/Module.symvers"))) + ;; These files will be regenerated by depmod below. + (for-each (lambda (basename) + (when (and (string-prefix? "modules." basename) + ;; Note: "modules.builtin" is an input file. + (not (string=? "modules.builtin" basename)) + ;; Note: "modules.order" is an input file. + (not (string=? "modules.order" basename))) + (delete-file (string-append destination-directory "/" + basename)))) + (scandir destination-directory)) + (invoke "depmod" + "-e" ; Report symbols that aren't supplied + ;"-w" ; Warn on duplicates + "-b" directory + "-F" maps-file + ;"-E" symvers-file ; using both "-E" and "-F" is not possible. + version))) + +(define (make-linux-module-directory inputs version output) + "Create a new directory OUTPUT and ensure that the directory +OUTPUT/lib/modules/VERSION can be used as a source of Linux +kernel modules for the first kmod in PATH now to eventually +load. Take modules to put into OUTPUT from INPUTS. + +Right now that means it creates @code{modules.*.bin} which +@command{modprobe} will use to find loadable modules." + (union-build output inputs #:create-all-directories? #t) + (depmod version output)) + ;;; linux-modules.scm ends here diff --git a/gnu/local.mk b/gnu/local.mk index e391903473..a080745220 100644 --- a/gnu/local.mk +++ b/gnu/local.mk @@ -635,6 +635,7 @@ GNU_SYSTEM_MODULES = \ %D%/tests/nfs.scm \ %D%/tests/install.scm \ %D%/tests/ldap.scm \ + %D%/tests/linux-modules.scm \ %D%/tests/mail.scm \ %D%/tests/messaging.scm \ %D%/tests/networking.scm \ diff --git a/gnu/packages/linux.scm b/gnu/packages/linux.scm index ffc4776f94..c39c411e3d 100644 --- a/gnu/packages/linux.scm +++ b/gnu/packages/linux.scm @@ -654,7 +654,6 @@ for ARCH and optionally VARIANT, or #f if there is no such configuration." `(("perl" ,perl) ("bc" ,bc) ("openssl" ,openssl) - ("kmod" ,kmod) ("elfutils" ,elfutils) ; Needed to enable CONFIG_STACK_VALIDATION ("flex" ,flex) ("bison" ,bison) @@ -678,6 +677,7 @@ for ARCH and optionally VARIANT, or #f if there is no such configuration." (guix build utils) (srfi srfi-1) (srfi srfi-26) + (ice-9 ftw) (ice-9 match)) #:phases (modify-phases %standard-phases @@ -750,8 +750,7 @@ for ARCH and optionally VARIANT, or #f if there is no such configuration." (lambda* (#:key inputs native-inputs outputs #:allow-other-keys) (let* ((out (assoc-ref outputs "out")) (moddir (string-append out "/lib/modules")) - (dtbdir (string-append out "/lib/dtbs")) - (kmod (assoc-ref (or native-inputs inputs) "kmod"))) + (dtbdir (string-append out "/lib/dtbs"))) ;; Install kernel image, kernel configuration and link map. (for-each (lambda (file) (install-file file out)) (find-files "." "^(\\.config|bzImage|zImage|Image|vmlinuz|System\\.map|Module\\.symvers)$")) @@ -763,12 +762,29 @@ for ARCH and optionally VARIANT, or #f if there is no such configuration." ;; Install kernel modules (mkdir-p moddir) (invoke "make" - (string-append "DEPMOD=" kmod "/bin/depmod") + ;; Disable depmod because the Guix system's module directory + ;; is an union of potentially multiple packages. It is not + ;; possible to use depmod to usefully calculate a dependency + ;; graph while building only one of those packages. + "DEPMOD=true" (string-append "MODULE_DIR=" moddir) (string-append "INSTALL_PATH=" out) (string-append "INSTALL_MOD_PATH=" out) "INSTALL_MOD_STRIP=1" - "modules_install"))))) + "modules_install") + (let* ((versions (filter (lambda (name) + (not (string-prefix? "." name))) + (scandir moddir))) + (version (match versions + ((x) x)))) + ;; There are symlinks to the build and source directory, + ;; both of which will point to target /tmp/guix-build* + ;; and thus not be useful in a profile. Delete the symlinks. + (false-if-file-not-found + (delete-file (string-append moddir "/" version "/build"))) + (false-if-file-not-found + (delete-file (string-append moddir "/" version "/source")))) + #t)))) #:tests? #f)) (home-page "https://www.gnu.org/software/linux-libre/") (synopsis "100% free redistribution of a cleaned Linux kernel") diff --git a/gnu/system.scm b/gnu/system.scm index 06c58c27ba..c90d8c6cbc 100644 --- a/gnu/system.scm +++ b/gnu/system.scm @@ -5,6 +5,7 @@ ;;; Copyright © 2016 Chris Marusich ;;; Copyright © 2017 Mathieu Othacehe ;;; Copyright © 2019 Meiyo Peng +;;; Copyright © 2020 Danny Milosavljevic ;;; ;;; This file is part of GNU Guix. ;;; @@ -168,6 +169,8 @@ (kernel operating-system-kernel ; package (default linux-libre)) + (kernel-loadable-modules operating-system-kernel-loadable-modules + (default '())) ; list of packages (kernel-arguments operating-system-user-kernel-arguments (default '("quiet"))) ; list of gexps/strings (bootloader operating-system-bootloader) ; @@ -472,9 +475,16 @@ OS." "Return the basic entries of the 'system' directory of OS for use as the value of the SYSTEM-SERVICE-TYPE service." (let ((locale (operating-system-locale-directory os))) - (mlet %store-monad ((kernel -> (operating-system-kernel os)) - (initrd -> (operating-system-initrd-file os)) - (params (operating-system-boot-parameters-file os))) + (mlet* %store-monad ((kernel -> (operating-system-kernel os)) + (modules -> + (operating-system-kernel-loadable-modules os)) + (kernel + (profile-derivation + (packages->manifest + (cons kernel modules)) + #:hooks (list linux-module-database))) + (initrd -> (operating-system-initrd-file os)) + (params (operating-system-boot-parameters-file os))) (return `(("kernel" ,kernel) ("parameters" ,params) ("initrd" ,initrd) diff --git a/gnu/tests/linux-modules.scm b/gnu/tests/linux-modules.scm new file mode 100644 index 0000000000..39e11587c6 --- /dev/null +++ b/gnu/tests/linux-modules.scm @@ -0,0 +1,103 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2019 Jakob L. Kreuze +;;; Copyright © 2020 Danny Milosavljevic +;;; +;;; 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 tests linux-modules) + #:use-module (gnu packages linux) + #:use-module (gnu system) + #:use-module (gnu system vm) + #:use-module (gnu tests) + #:use-module (guix derivations) + #:use-module (guix gexp) + #:use-module (guix modules) + #:use-module (guix monads) + #:use-module (guix store) + #:export (%test-loadable-kernel-modules-0 + %test-loadable-kernel-modules-1 + %test-loadable-kernel-modules-2)) + +;;; Commentary: +;;; +;;; Test kernel-loadable-modules. +;;; +;;; Code: + +(define* (module-loader-program os modules) + "Return an executable store item that, upon being evaluated, will dry-run +load MODULES." + (program-file + "load-kernel-modules.scm" + (with-imported-modules (source-module-closure '((guix build utils))) + #~(begin + (use-modules (guix build utils)) + (for-each (lambda (module) + (invoke (string-append #$kmod "/bin/modprobe") "-n" "--" + module)) + '#$modules))))) + +(define* (run-loadable-kernel-modules-test module-packages module-names) + "Run a test of an OS having MODULE-PACKAGES, and modprobe MODULE-NAMES." + (define os + (marionette-operating-system + (operating-system + (inherit (simple-operating-system)) + (kernel-loadable-modules module-packages)) + #:imported-modules '((guix combinators)))) + (define vm (virtual-machine os)) + (define (test script) + (with-imported-modules '((gnu build marionette)) + #~(begin + (use-modules (gnu build marionette) + (srfi srfi-64)) + (define marionette + (make-marionette (list #$vm))) + (mkdir #$output) + (chdir #$output) + (test-begin "loadable-kernel-modules") + (test-assert "script successfully evaluated" + (marionette-eval + '(primitive-load #$script) + marionette)) + (test-end) + (exit (= (test-runner-fail-count (test-runner-current)) 0))))) + (gexp->derivation "loadable-kernel-modules" (test (module-loader-program os module-names)))) + +(define %test-loadable-kernel-modules-0 + (system-test + (name "loadable-kernel-modules-0") + (description "Tests loadable kernel modules facility of +with no extra modules.") + (value (run-loadable-kernel-modules-test '() '())))) + +(define %test-loadable-kernel-modules-1 + (system-test + (name "loadable-kernel-modules-1") + (description "Tests loadable kernel modules facility of +with one extra module.") + (value (run-loadable-kernel-modules-test + (list ddcci-driver-linux) + '("ddcci"))))) + +(define %test-loadable-kernel-modules-2 + (system-test + (name "loadable-kernel-modules-2") + (description "Tests loadable kernel modules facility of +with two extra modules.") + (value (run-loadable-kernel-modules-test + (list acpi-call-linux-module ddcci-driver-linux) + '("acpi_call" "ddcci"))))) diff --git a/guix/profiles.scm b/guix/profiles.scm index 0d38b2513f..20a2973579 100644 --- a/guix/profiles.scm +++ b/guix/profiles.scm @@ -10,6 +10,7 @@ ;;; Copyright © 2017 Maxim Cournoyer ;;; Copyright © 2019 Kyle Meyer ;;; Copyright © 2019 Mathieu Othacehe +;;; Copyright © 2020 Danny Milosavljevic ;;; ;;; This file is part of GNU Guix. ;;; @@ -139,7 +140,9 @@ %current-profile ensure-profile-directory canonicalize-profile - user-friendly-profile)) + user-friendly-profile + + linux-module-database)) ;;; Commentary: ;;; @@ -1137,6 +1140,51 @@ for both major versions of GTK+." (hook . gtk-im-modules))) (return #f))))) +(define (linux-module-database manifest) + "Return a derivation that unites all the kernel modules of the manifest +and creates the dependency graph of all these kernel modules. + +This is meant to be used as a profile hook." + (define kmod ; lazy reference + (module-ref (resolve-interface '(gnu packages linux)) 'kmod)) + (define build + (with-imported-modules + (source-module-closure '((guix build utils) + (gnu build linux-modules))) + #~(begin + (use-modules (ice-9 ftw) + (ice-9 match) + (srfi srfi-1) ; append-map + (gnu build linux-modules)) + (let* ((inputs '#$(manifest-inputs manifest)) + (module-directories + (map (lambda (directory) + (string-append directory "/lib/modules")) + inputs)) + (directory-entries + (lambda (directory) + (scandir directory (lambda (basename) + (not + (string-prefix? "." basename)))))) + ;; Note: Should usually result in one entry. + (versions (delete-duplicates + (append-map directory-entries + module-directories)))) + (match versions + ((version) + (let ((old-path (getenv "PATH"))) + (setenv "PATH" #+(file-append kmod "/bin")) + (make-linux-module-directory inputs version #$output) + (setenv "PATH" old-path))) + (_ (error "Specified Linux kernel and Linux kernel modules +are not all of the same version"))))))) + (gexp->derivation "linux-module-database" build + #:local-build? #t + #:substitutable? #f + #:properties + `((type . profile-hook) + (hook . linux-module-database)))) + (define (xdg-desktop-database manifest) "Return a derivation that builds the @file{mimeinfo.cache} database from desktop files. It's used to query what applications can handle a given -- cgit v1.2.3 From c086c5af1c48f5caf749ff33498d051d5378d361 Mon Sep 17 00:00:00 2001 From: Mathieu Othacehe Date: Fri, 20 Mar 2020 16:13:20 +0100 Subject: build-system: linux-module: Fix cross compilation. * guix/build-system/linux-module.scm (default-kmod, default-gcc): Delete procedures. (system->arch): New procedure. (make-linux-module-builder)[native-inputs]: Move linux... [inputs]: ...to here. (linux-module-build-cross): New procedure. (linux-module-build): Add TARGET. Pass TARGET and ARCH to build side. (lower): Allow cross-compilation. Move "linux" and "linux-module-builder" to host-inputs. Add target-inputs. Call linux-module-build-cross if TARGET is set, linux-module-build otherwise. * guix/build/linux-module-build-system.scm (configure): Add ARCH argument. (linux-module-build): Adjust comment. Signed-off-by: Danny Milosavljevic --- guix/build-system/linux-module.scm | 162 +++++++++++++++++++++++-------- guix/build/linux-module-build-system.scm | 17 ++-- 2 files changed, 132 insertions(+), 47 deletions(-) (limited to 'guix') diff --git a/guix/build-system/linux-module.scm b/guix/build-system/linux-module.scm index 1e1a07d0a2..ca104f7c75 100644 --- a/guix/build-system/linux-module.scm +++ b/guix/build-system/linux-module.scm @@ -1,5 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2019 Danny Milosavljevic +;;; Copyright © 2020 Mathieu Othacehe ;;; ;;; This file is part of GNU Guix. ;;; @@ -45,27 +46,16 @@ (let ((module (resolve-interface '(gnu packages linux)))) (module-ref module 'linux-libre))) -(define (default-kmod) - "Return the default kmod package." - - ;; Do not use `@' to avoid introducing circular dependencies. +(define (system->arch system) (let ((module (resolve-interface '(gnu packages linux)))) - (module-ref module 'kmod))) - -(define (default-gcc) - "Return the default gcc package." - - ;; Do not use `@' to avoid introducing circular dependencies. - (let ((module (resolve-interface '(gnu packages gcc)))) - (module-ref module 'gcc-7))) + ((module-ref module 'system->linux-architecture) system))) (define (make-linux-module-builder linux) (package (inherit linux) (name (string-append (package-name linux) "-module-builder")) - (native-inputs - `(("linux" ,linux) - ,@(package-native-inputs linux))) + (inputs + `(("linux" ,linux))) (arguments (substitute-keyword-arguments (package-arguments linux) ((#:phases phases) @@ -97,33 +87,43 @@ #:rest arguments) "Return a bag for NAME." (define private-keywords - '(#:source #:target #:gcc #:kmod #:linux #:inputs #:native-inputs)) - - (and (not target) ;XXX: no cross-compilation - (bag - (name name) - (system system) - (host-inputs `(,@(if source - `(("source" ,source)) - '()) - ,@inputs - ,@(standard-packages))) - (build-inputs `(("linux" ,linux) ; for "Module.symvers". - ("linux-module-builder" - ,(make-linux-module-builder linux)) - ,@native-inputs - ;; TODO: Remove "gmp", "mpfr", "mpc" since they are - ;; only needed to compile the gcc plugins. Maybe - ;; remove "flex", "bison", "elfutils", "perl", - ;; "openssl". That leaves very little ("bc", "gcc", - ;; "kmod"). - ,@(package-native-inputs linux))) - (outputs outputs) - (build linux-module-build) - (arguments (strip-keyword-arguments private-keywords arguments))))) + `(#:source #:target #:gcc #:kmod #:linux #:inputs #:native-inputs + ,@(if target '() '(#:target)))) + + (bag + (name name) + (system system) (target target) + (build-inputs `(,@(if source + `(("source" ,source)) + '()) + ,@native-inputs + ;; TODO: Remove "gmp", "mpfr", "mpc" since they are + ;; only needed to compile the gcc plugins. Maybe + ;; remove "flex", "bison", "elfutils", "perl", + ;; "openssl". That leaves very little ("bc", "gcc", + ;; "kmod"). + ,@(package-native-inputs linux) + ,@(if target + ;; Use the standard cross inputs of + ;; 'gnu-build-system'. + (standard-cross-packages target 'host) + '()) + ;; Keep the standard inputs of 'gnu-build-system'. + ,@(standard-packages))) + (host-inputs `(,@inputs + ("linux" ,linux) + ("linux-module-builder" + ,(make-linux-module-builder linux)))) + (target-inputs (if target + (standard-cross-packages target 'target) + '())) + (outputs outputs) + (build (if target linux-module-build-cross linux-module-build)) + (arguments (strip-keyword-arguments private-keywords arguments)))) (define* (linux-module-build store name inputs #:key + target (search-paths '()) (tests? #t) (phases '(@ (guix build linux-module-build-system) @@ -152,6 +152,8 @@ search-paths) #:phases ,phases #:system ,system + #:target ,target + #:arch ,(system->arch (or target system)) #:tests? ,tests? #:outputs %outputs #:inputs %build-inputs))) @@ -173,6 +175,88 @@ #:guile-for-build guile-for-build #:substitutable? substitutable?)) +(define* (linux-module-build-cross + store name + #:key + target native-drvs target-drvs + (guile #f) + (outputs '("out")) + (search-paths '()) + (native-search-paths '()) + (tests? #f) + (phases '(@ (guix build linux-module-build-system) + %standard-phases)) + (system (%current-system)) + (substitutable? #t) + (imported-modules + %linux-module-build-system-modules) + (modules '((guix build linux-module-build-system) + (guix build utils)))) + (define builder + `(begin + (use-modules ,@modules) + (let () + (define %build-host-inputs + ',(map (match-lambda + ((name (? derivation? drv) sub ...) + `(,name . ,(apply derivation->output-path drv sub))) + ((name path) + `(,name . ,path))) + native-drvs)) + + (define %build-target-inputs + ',(map (match-lambda + ((name (? derivation? drv) sub ...) + `(,name . ,(apply derivation->output-path drv sub))) + ((name (? package? pkg) sub ...) + (let ((drv (package-cross-derivation store pkg + target system))) + `(,name . ,(apply derivation->output-path drv sub)))) + ((name path) + `(,name . ,path))) + target-drvs)) + + (linux-module-build #:name ,name + #:source ,(match (assoc-ref native-drvs "source") + (((? derivation? source)) + (derivation->output-path source)) + ((source) + source) + (source + source)) + #:system ,system + #:target ,target + #:arch ,(system->arch (or target system)) + #:outputs %outputs + #:inputs %build-target-inputs + #:native-inputs %build-host-inputs + #:search-paths + ',(map search-path-specification->sexp + search-paths) + #:native-search-paths + ',(map + search-path-specification->sexp + native-search-paths) + #:phases ,phases + #:tests? ,tests?)))) + + (define guile-for-build + (match guile + ((? package?) + (package-derivation store guile system #:graft? #f)) + (#f ; the default + (let* ((distro (resolve-interface '(gnu packages commencement))) + (guile (module-ref distro 'guile-final))) + (package-derivation store guile system #:graft? #f))))) + + (build-expression->derivation store name builder + #:system system + #:inputs (append native-drvs target-drvs) + #:outputs outputs + #:modules imported-modules + #:guile-for-build guile-for-build + #:substitutable? substitutable?)) + (define linux-module-build-system (build-system (name 'linux-module) diff --git a/guix/build/linux-module-build-system.scm b/guix/build/linux-module-build-system.scm index 8145d5a724..73d6b101f6 100644 --- a/guix/build/linux-module-build-system.scm +++ b/guix/build/linux-module-build-system.scm @@ -1,5 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2019 Danny Milosavljevic +;;; Copyright © 2020 Mathieu Othacehe ;;; ;;; This file is part of GNU Guix. ;;; @@ -33,14 +34,13 @@ ;; Code: ;; Copied from make-linux-libre's "configure" phase. -(define* (configure #:key inputs target #:allow-other-keys) +(define* (configure #:key inputs target arch #:allow-other-keys) (setenv "KCONFIG_NOTIMESTAMP" "1") (setenv "KBUILD_BUILD_TIMESTAMP" (getenv "SOURCE_DATE_EPOCH")) - ;(let ((arch ,(system->linux-architecture - ; (or (%current-target-system) - ; (%current-system))))) - ; (setenv "ARCH" arch) - ; (format #t "`ARCH' set to `~a'~%" (getenv "ARCH"))) + + (setenv "ARCH" arch) + (format #t "`ARCH' set to `~a'~%" (getenv "ARCH")) + (when target (setenv "CROSS_COMPILE" (string-append target "-")) (format #t "`CROSS_COMPILE' set to `~a'~%" @@ -85,8 +85,9 @@ (replace 'install install))) (define* (linux-module-build #:key inputs (phases %standard-phases) - #:allow-other-keys #:rest args) - "Build the given package, applying all of PHASES in order, with a Linux kernel in attendance." + #:allow-other-keys #:rest args) + "Build the given package, applying all of PHASES in order, with a Linux +kernel in attendance." (apply gnu:gnu-build #:inputs inputs #:phases phases args)) -- cgit v1.2.3 From 9acacb71c958218fd69cf0fb9df0b439a980a0f2 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sun, 22 Mar 2020 15:58:49 +0100 Subject: Remove workaround for 'time-monotonic' in Guile 2.2.2. This is a followup to e688c2df3924423b67892cc9939ca099c729d1cb. * build-aux/hydra/evaluate.scm : Remove 'time-monotonic' definition. * guix/cache.scm: Likewise. * guix/progress.scm: Likewise. * guix/scripts/substitute.scm: Likewise. * guix/scripts/weather.scm: Likewise. * tests/cache.scm: Likewise. --- build-aux/hydra/evaluate.scm | 7 ------- guix/cache.scm | 9 +-------- guix/progress.scm | 9 +-------- guix/scripts/substitute.scm | 7 ------- guix/scripts/weather.scm | 7 ------- tests/cache.scm | 9 +-------- 6 files changed, 3 insertions(+), 45 deletions(-) (limited to 'guix') diff --git a/build-aux/hydra/evaluate.scm b/build-aux/hydra/evaluate.scm index 6e63a149bd..c74fcdb763 100644 --- a/build-aux/hydra/evaluate.scm +++ b/build-aux/hydra/evaluate.scm @@ -42,13 +42,6 @@ (beautify-user-module! m) m)) -(cond-expand - (guile-2.2 - ;; Guile 2.2.2 has a bug whereby 'time-monotonic' objects have seconds and - ;; nanoseconds swapped (fixed in Guile commit 886ac3e). Work around it. - (define time-monotonic time-tai)) - (else #t)) - (define (call-with-time thunk kont) "Call THUNK and pass KONT the elapsed time followed by THUNK's return values." diff --git a/guix/cache.scm b/guix/cache.scm index 1dc0083f1d..feff131068 100644 --- a/guix/cache.scm +++ b/guix/cache.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, 2020 Ludovic Courtès ;;; ;;; This file is part of GNU Guix. ;;; @@ -33,13 +33,6 @@ ;;; ;;; Code: -(cond-expand - (guile-2.2 - ;; Guile 2.2.2 has a bug whereby 'time-monotonic' objects have seconds and - ;; nanoseconds swapped (fixed in Guile commit 886ac3e). Work around it. - (define time-monotonic time-tai)) - (else #t)) - (define (obsolete? date now ttl) "Return #t if DATE is obsolete compared to NOW + TTL seconds." (time>? (subtract-duration now (make-time time-duration 0 ttl)) diff --git a/guix/progress.scm b/guix/progress.scm index c7567a35fd..fec65b424c 100644 --- a/guix/progress.scm +++ b/guix/progress.scm @@ -1,7 +1,7 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2017 Sou Bunnbu ;;; Copyright © 2015 Steve Sprang -;;; Copyright © 2017, 2018, 2019 Ludovic Courtès +;;; Copyright © 2017, 2018, 2019, 2020 Ludovic Courtès ;;; Copyright © 2018 Clément Lassieur ;;; ;;; This file is part of GNU Guix. @@ -96,13 +96,6 @@ stopped." ;;; File download progress report. ;;; -(cond-expand - (guile-2.2 - ;; Guile 2.2.2 has a bug whereby 'time-monotonic' objects have seconds and - ;; nanoseconds swapped (fixed in Guile commit 886ac3e). Work around it. - (define time-monotonic time-tai)) - (else #t)) - (define (nearest-exact-integer x) "Given a real number X, return the nearest exact integer, with ties going to the nearest exact even integer." diff --git a/guix/scripts/substitute.scm b/guix/scripts/substitute.scm index dfb975a24a..95b47a7816 100755 --- a/guix/scripts/substitute.scm +++ b/guix/scripts/substitute.scm @@ -102,13 +102,6 @@ ;;; ;;; Code: -(cond-expand - (guile-2.2 - ;; Guile 2.2.2 has a bug whereby 'time-monotonic' objects have seconds and - ;; nanoseconds swapped (fixed in Guile commit 886ac3e). Work around it. - (define time-monotonic time-tai)) - (else #t)) - (define %narinfo-cache-directory ;; A local cache of narinfos, to avoid going to the network. Most of the ;; time, 'guix substitute' is called by guix-daemon as root and stores its diff --git a/guix/scripts/weather.scm b/guix/scripts/weather.scm index a9e0cba92a..eb76771452 100644 --- a/guix/scripts/weather.scm +++ b/guix/scripts/weather.scm @@ -106,13 +106,6 @@ scope." '() packages))))) -(cond-expand - (guile-2.2 - ;; Guile 2.2.2 has a bug whereby 'time-monotonic' objects have seconds and - ;; nanoseconds swapped (fixed in Guile commit 886ac3e). Work around it. - (define time-monotonic time-tai)) - (else #t)) - (define (call-with-time thunk kont) "Call THUNK and pass KONT the elapsed time followed by THUNK's return values." diff --git a/tests/cache.scm b/tests/cache.scm index e46cdd816d..80b44d69aa 100644 --- a/tests/cache.scm +++ b/tests/cache.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2017 Ludovic Courtès +;;; Copyright © 2017, 2020 Ludovic Courtès ;;; ;;; This file is part of GNU Guix. ;;; @@ -24,13 +24,6 @@ #:use-module ((guix utils) #:select (call-with-temporary-directory)) #:use-module (ice-9 match)) -(cond-expand - (guile-2.2 - ;; Guile 2.2.2 has a bug whereby 'time-monotonic' objects have seconds and - ;; nanoseconds swapped (fixed in Guile commit 886ac3e). Work around it. - (define time-monotonic time-tai)) - (else #t)) - (test-begin "cache") (test-equal "remove-expired-cache-entries" -- cgit v1.2.3 From afc6b1c0b635e3268795c0f766be408c5e9858e7 Mon Sep 17 00:00:00 2001 From: Maxim Cournoyer Date: Sun, 22 Mar 2020 10:42:44 -0400 Subject: build: emacs-utils: Add an option to select scoping for batch eval. In Emacs 27, --eval now evaluates using lexical scoping. This change adds an option to select dynamic scoping, by using a workaround proposed in . * guix/build/emacs-utils.scm (emacs-batch-eval): Add a DYNAMIC? keyword argument. Wrap the EXPR with a call to EVAL that makes use of the argument to select the scoping mode. (emacs-generate-autoloads): Use it. --- guix/build/emacs-utils.scm | 13 ++++++++----- 1 file changed, 8 insertions(+), 5 deletions(-) (limited to 'guix') diff --git a/guix/build/emacs-utils.scm b/guix/build/emacs-utils.scm index ab64e3714c..5f7ba71244 100644 --- a/guix/build/emacs-utils.scm +++ b/guix/build/emacs-utils.scm @@ -1,7 +1,7 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2014, 2018 Mark H Weaver ;;; Copyright © 2014 Alex Kost -;;; Copyright © 2018 Maxim Cournoyer +;;; Copyright © 2018, 2020 Maxim Cournoyer ;;; Copyright © 2019 Leo Prikler ;;; ;;; This file is part of GNU Guix. @@ -21,6 +21,7 @@ (define-module (guix build emacs-utils) #:use-module (guix build utils) + #:use-module (ice-9 format) #:export (%emacs emacs-batch-eval emacs-batch-edit-file @@ -47,10 +48,12 @@ expr (format #f "~s" expr))) -(define (emacs-batch-eval expr) - "Run Emacs in batch mode, and execute the elisp code EXPR." +(define* (emacs-batch-eval expr #:key dynamic?) + "Run Emacs in batch mode, and execute the Elisp code EXPR. If DYNAMIC? is +true, evaluate using dynamic scoping." (invoke (%emacs) "--quick" "--batch" - (string-append "--eval=" (expr->string expr)))) + (format #f "--eval=(eval '~a ~:[t~;nil~])" + (expr->string expr) dynamic?))) (define (emacs-batch-edit-file file expr) "Load FILE in Emacs using batch mode, and execute the elisp code EXPR." @@ -70,7 +73,7 @@ (expr `(let ((backup-inhibited t) (generated-autoload-file ,file)) (update-directory-autoloads ,directory)))) - (emacs-batch-eval expr))) + (emacs-batch-eval expr #:dynamic? #t))) (define* (emacs-byte-compile-directory dir) "Byte compile all files in DIR and its sub-directories." -- cgit v1.2.3 From 8f53d73493a2949e2db28cd7d689a690b2d9479a Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 23 Mar 2020 10:08:41 +0100 Subject: ssh: 'send-files' reports missing modules on the remote host. Reported by Mikael Djurfeldt in . * guix/ssh.scm (send-files)[inferior-remote-eval*]: New procedure. [missing]: Use it. Add an explicit 'resolve-module' call. (report-inferior-exception): New procedure. --- guix/ssh.scm | 22 ++++++++++++++++++++-- 1 file changed, 20 insertions(+), 2 deletions(-) (limited to 'guix') diff --git a/guix/ssh.scm b/guix/ssh.scm index 56b49b177f..2d7ca7d01d 100644 --- a/guix/ssh.scm +++ b/guix/ssh.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2016, 2017, 2018, 2019 Ludovic Courtès +;;; Copyright © 2016, 2017, 2018, 2019, 2020 Ludovic Courtès ;;; ;;; This file is part of GNU Guix. ;;; @@ -405,11 +405,24 @@ to the system ACL file if it has not yet been authorized." "Send the subset of FILES from LOCAL (a local store) that's missing to REMOTE, a remote store. When RECURSIVE? is true, send the closure of FILES. Return the list of store items actually sent." + (define (inferior-remote-eval* exp session) + (guard (c ((inferior-exception? c) + (match (inferior-exception-arguments c) + (('quit 7) + (report-module-error (remote-store-host remote))) + (_ + (report-inferior-exception c (remote-store-host remote)))))) + (inferior-remote-eval exp session))) + ;; Compute the subset of FILES missing on SESSION and send them. (let* ((files (if recursive? (requisites local files) files)) (session (channel-get-session (store-connection-socket remote))) - (missing (inferior-remote-eval + (missing (inferior-remote-eval* `(begin + (eval-when (load expand eval) + (unless (resolve-module '(guix) #:ensure #f) + (exit 7))) + (use-modules (guix) (srfi srfi-1) (srfi srfi-26)) @@ -567,4 +580,9 @@ own module directory. Run @command{ssh ~A env | grep GUILE_LOAD_PATH} to check.") host))) +(define (report-inferior-exception exception host) + "Report EXCEPTION, an &inferior-exception that occurred on HOST." + (raise-error (G_ "exception occurred on remote host '~A': ~s") + host (inferior-exception-arguments exception))) + ;;; ssh.scm ends here -- cgit v1.2.3 From 7b322d3c4cb266a0d84f5e3a8ceedd302f9f73df Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 20 Mar 2020 12:44:43 +0100 Subject: ui: Add 'indented-string'. * guix/scripts/pull.scm (display-news-entry): Remove extra space in format string for 'indented-string'. (indented-string): Remove. (display-new/upgraded-packages)[pretty]: Pass #:initial-indent? to 'indented-string'. * guix/ui.scm (indented-string): New procedure. --- guix/scripts/pull.scm | 17 ++--------------- guix/ui.scm | 18 ++++++++++++++++++ 2 files changed, 20 insertions(+), 15 deletions(-) (limited to 'guix') diff --git a/guix/scripts/pull.scm b/guix/scripts/pull.scm index 7fc23e1b47..b7e0a4a416 100644 --- a/guix/scripts/pull.scm +++ b/guix/scripts/pull.scm @@ -269,7 +269,7 @@ code, to PORT." (let ((body (or (assoc-ref body language) (assoc-ref body (%default-message-language)) ""))) - (format port " ~a~%" + (format port "~a~%" (indented-string (parameterize ((%text-width (- (%text-width) 4))) (string-trim-right @@ -520,19 +520,6 @@ true, display what would be built without actually building it." ;;; Queries. ;;; -(define (indented-string str indent) - "Return STR with each newline preceded by IDENT spaces." - (define indent-string - (make-list indent #\space)) - - (list->string - (string-fold-right (lambda (chr result) - (if (eqv? chr #\newline) - (cons chr (append indent-string result)) - (cons chr result))) - '() - str))) - (define profile-package-alist (mlambda (profile) "Return a name/version alist representing the packages in PROFILE." @@ -589,7 +576,7 @@ Return true when there is more package info to display." (define (pretty str column) (indented-string (fill-paragraph str (- (%text-width) 4) column) - 4)) + 4 #:initial-indent? #f)) (define concise/max-item-count ;; Maximum number of items to display when CONCISE? is true. diff --git a/guix/ui.scm b/guix/ui.scm index b9ba8c0f7a..a469494d78 100644 --- a/guix/ui.scm +++ b/guix/ui.scm @@ -104,6 +104,7 @@ read/eval read/eval-package-expression check-available-space + indented-string fill-paragraph %text-width texi->plain-text @@ -1206,6 +1207,23 @@ replacement if PORT is not Unicode-capable." (lambda () body ...))))) +(define* (indented-string str indent + #:key (initial-indent? #t)) + "Return STR with each newline preceded by IDENT spaces. When +INITIAL-INDENT? is true, the first line is also indented." + (define indent-string + (make-list indent #\space)) + + (list->string + (string-fold-right (lambda (chr result) + (if (eqv? chr #\newline) + (cons chr (append indent-string result)) + (cons chr result))) + '() + (if initial-indent? + (string-append (list->string indent-string) str) + str)))) + (define* (fill-paragraph str width #:optional (column 0)) "Fill STR such that each line contains at most WIDTH characters, assuming that the first character is at COLUMN. -- cgit v1.2.3 From 1bb248d0b10af77379096f4456ce6f5c5d1c23ac Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 20 Mar 2020 12:46:06 +0100 Subject: deploy: Show what machines will be deployed. * guix/scripts/deploy.scm (show-what-to-deploy): New procedure. (guix-deploy): Call it. --- guix/scripts/deploy.scm | 19 +++++++++++++++++++ 1 file changed, 19 insertions(+) (limited to 'guix') diff --git a/guix/scripts/deploy.scm b/guix/scripts/deploy.scm index a82dde00a4..d4d07bea5a 100644 --- a/guix/scripts/deploy.scm +++ b/guix/scripts/deploy.scm @@ -1,6 +1,7 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2019 David Thompson ;;; Copyright © 2019 Jakob L. Kreuze +;;; Copyright © 2020 Ludovic Courtès ;;; ;;; This file is part of GNU Guix. ;;; @@ -97,6 +98,22 @@ Perform the deployment specified by FILE.\n")) environment-modules)))) (load* file module))) +(define (show-what-to-deploy machines) + "Show the list of machines to deploy, MACHINES." + (let ((count (length machines))) + (format (current-error-port) + (N_ "The following ~*machine will be deployed:~%" + "The following ~d machines will be deployed:~%" + count) + count) + (display (indented-string + (fill-paragraph (string-join (map machine-display-name machines) + ", ") + (- (%text-width) 2) 2) + 2) + (current-error-port)) + (display "\n\n" (current-error-port)))) + (define (guix-deploy . args) (define (handle-argument arg result) (alist-cons 'file arg result)) @@ -105,6 +122,8 @@ Perform the deployment specified by FILE.\n")) #:argument-handler handle-argument)) (file (assq-ref opts 'file)) (machines (or (and file (load-source-file file)) '()))) + (show-what-to-deploy machines) + (with-status-verbosity (assoc-ref opts 'verbosity) (with-store store (set-build-options-from-command-line store opts) -- cgit v1.2.3 From 129237272505d58e121c40b938c7227f294ecb82 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 20 Mar 2020 14:52:01 +0100 Subject: deploy: Write a message upon successful deployment. * guix/scripts/deploy.scm (guix-deploy): Write message upon successful deployment. --- guix/scripts/deploy.scm | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/scripts/deploy.scm b/guix/scripts/deploy.scm index d4d07bea5a..f70d41f35c 100644 --- a/guix/scripts/deploy.scm +++ b/guix/scripts/deploy.scm @@ -143,5 +143,7 @@ Perform the deployment specified by FILE.\n")) (machine-display-name machine)) (run-with-store store (roll-back-machine machine))) (apply throw (deploy-error-captured-args c)))) - (run-with-store store (deploy-machine machine))))) + (run-with-store store (deploy-machine machine)) + (info (G_ "successfully deployed ~a~%") + (machine-display-name machine))))) machines)))))) -- cgit v1.2.3 From 5d33e789c2d8f90fa010b2974f6237aef23f4aec Mon Sep 17 00:00:00 2001 From: Arun Isaac Date: Thu, 5 Dec 2019 16:30:09 +0530 Subject: licenses: Add Open Government Licence for Public Sector Information. * guix/licenses.scm (ogl-psi1.0): New variable. Signed-off-by: Guillaume Le Vaillant --- guix/licenses.scm | 6 ++++++ 1 file changed, 6 insertions(+) (limited to 'guix') diff --git a/guix/licenses.scm b/guix/licenses.scm index 9153c3ccae..deafe847db 100644 --- a/guix/licenses.scm +++ b/guix/licenses.scm @@ -75,6 +75,7 @@ ms-pl ncsa nmap + ogl-psi1.0 openldap2.8 openssl perl-license psfl public-domain @@ -517,6 +518,11 @@ at URI, which may be a file:// URI pointing the package's tree." "https://svn.nmap.org/nmap/COPYING" "https://fedoraproject.org/wiki/Licensing/Nmap")) +(define ogl-psi1.0 + (license "Open Government Licence for Public Sector Information" + "https://www.nationalarchives.gov.uk/doc/open-government-licence/version/1/" + #f)) + (define openssl (license "OpenSSL" "http://directory.fsf.org/wiki/License:OpenSSL" -- cgit v1.2.3 From d13d28265fb831b905bc00edeb45cd550cd43ffe Mon Sep 17 00:00:00 2001 From: Arun Isaac Date: Thu, 5 Dec 2019 16:31:50 +0530 Subject: licenses: Add QWT 1.0 license. * guix/licenses.scm (qwt1.0): New variable. Signed-off-by: Guillaume Le Vaillant --- guix/licenses.scm | 6 ++++++ 1 file changed, 6 insertions(+) (limited to 'guix') diff --git a/guix/licenses.scm b/guix/licenses.scm index deafe847db..ab2ad3f169 100644 --- a/guix/licenses.scm +++ b/guix/licenses.scm @@ -80,6 +80,7 @@ perl-license psfl public-domain qpl + qwt1.0 repoze ruby sgifreeb2.0 @@ -555,6 +556,11 @@ at URI, which may be a file:// URI pointing the package's tree." "http://directory.fsf.org/wiki/License:QPLv1.0" "http://www.gnu.org/licenses/license-list.html#QPL")) +(define qwt1.0 + (license "QWT 1.0" + "http://qwt.sourceforge.net/qwtlicense.html" + "GNU Lesser General Public License with exceptions")) + (define repoze (license "Repoze" "http://repoze.org/LICENSE.txt" -- cgit v1.2.3 From cf2b91aad04172b49c8716ea8c27a07d512c04f1 Mon Sep 17 00:00:00 2001 From: Martin Becze Date: Thu, 30 Jan 2020 10:52:28 -0500 Subject: import: crate: Deduplicate dependencies. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit * guix/import/crate.scm (crate-version-dependencies): Deduplicate crate dependencies. Signed-off-by: Ludovic Courtès --- guix/import/crate.scm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/import/crate.scm b/guix/import/crate.scm index 57823c3639..0b4482e876 100644 --- a/guix/import/crate.scm +++ b/guix/import/crate.scm @@ -112,7 +112,7 @@ record or #f if it was not found." (url (string-append (%crate-base-url) path))) (match (assoc-ref (or (json-fetch url) '()) "dependencies") ((? vector? vector) - (map json->crate-dependency (vector->list vector))) + (delete-duplicates (map json->crate-dependency (vector->list vector)))) (_ '())))) -- cgit v1.2.3 From 3e5ab0a7a9399bb098b9ced46bf3cbf4085c6bab Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 24 Mar 2020 14:08:51 +0100 Subject: ui: 'show-manifest-transaction' tabulates upgraded package lists. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit This also changes "1.0.0 → 1.0.0" to "(dependencies changed)", which is probably less confusing. * guix/ui.scm (tabulate): New procedure. (show-manifest-transaction)[upgrade-string]: Rewrite to take lists of names, versions, and outputs instead of single elements. Use 'tabulate'. Adjust callers accordingly. --- guix/ui.scm | 65 ++++++++++++++++++++++++++++++++++++++++++++++++++----------- 1 file changed, 54 insertions(+), 11 deletions(-) (limited to 'guix') diff --git a/guix/ui.scm b/guix/ui.scm index a469494d78..2dd9ba9673 100644 --- a/guix/ui.scm +++ b/guix/ui.scm @@ -1104,6 +1104,43 @@ replacement if PORT is not Unicode-capable." (lambda (key . args) "->")))) +(define* (tabulate rows #:key (initial-indent 0) (max-width 25) + (inter-column " ")) + "Return a list of strings where each string is a tabulated representation of +an element of ROWS. All the ROWS must be lists of the same number of cells. + +Add INITIAL-INDENT white space at the beginning of each row. Ensure that +columns are at most MAX-WIDTH characters wide. Use INTER-COLUMN as a +separator between subsequent columns." + (define column-widths + ;; List of column widths. + (let loop ((rows rows) + (widths '())) + (match rows + (((? null?) ...) + (reverse widths)) + (((column rest ...) ...) + (loop rest + (cons (min (apply max (map string-length column)) + max-width) + widths)))))) + + (define indent + (make-string initial-indent #\space)) + + (define (string-pad-right* str len) + (if (> (string-length str) len) + str + (string-pad-right str len))) + + (map (lambda (row) + (string-trim-right + (string-append indent + (string-join + (map string-pad-right* row column-widths) + inter-column)))) + rows)) + (define* (show-manifest-transaction store manifest transaction #:key dry-run?) "Display what will/would be installed/removed from MANIFEST by TRANSACTION." @@ -1120,13 +1157,18 @@ replacement if PORT is not Unicode-capable." (define → ;an arrow that can be represented on stderr (right-arrow (current-error-port))) - (define (upgrade-string name old-version new-version output item) - (format #f " ~a~:[:~a~;~*~]\t~a ~a ~a\t~a" - name (equal? output "out") output - old-version → new-version - (if (package? item) - (package-output store item output) - item))) + (define (upgrade-string names old-version new-version outputs) + (tabulate (zip (map (lambda (name output) + (if (string=? output "out") + name + (string-append name ":" output))) + names outputs) + (map (lambda (old new) + (if (string=? old new) + (G_ "(dependencies changed)") + (string-append old " " → " " new))) + old-version new-version)) + #:initial-indent 3)) (let-values (((remove install upgrade downgrade) (manifest-transaction-effects manifest transaction))) @@ -1150,8 +1192,8 @@ replacement if PORT is not Unicode-capable." (((($ name old-version) . ($ _ new-version output item)) ..1) (let ((len (length name)) - (downgrade (map upgrade-string - name old-version new-version output item))) + (downgrade (upgrade-string name old-version new-version + output))) (if dry-run? (format (current-error-port) (N_ "The following package would be downgraded:~%~{~a~%~}~%" @@ -1168,8 +1210,9 @@ replacement if PORT is not Unicode-capable." (((($ name old-version) . ($ _ new-version output item)) ..1) (let ((len (length name)) - (upgrade (map upgrade-string - name old-version new-version output item))) + (upgrade (upgrade-string name + old-version new-version + output))) (if dry-run? (format (current-error-port) (N_ "The following package would be upgraded:~%~{~a~%~}~%" -- cgit v1.2.3 From 8465f1f680ee67c2cca265d1c5871b46284f55f9 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 24 Mar 2020 14:38:28 +0100 Subject: ui: 'show-manifest-transaction' tabulates package lists for install/remove. It also removes the store file name from the output. * guix/ui.scm (show-manifest-transaction)[package-strings]: Rewrite to use 'tabulate'. Remove 'item' parameter and adjust callers. --- guix/ui.scm | 21 ++++++++++----------- 1 file changed, 10 insertions(+), 11 deletions(-) (limited to 'guix') diff --git a/guix/ui.scm b/guix/ui.scm index 2dd9ba9673..1e24fe5dca 100644 --- a/guix/ui.scm +++ b/guix/ui.scm @@ -1144,15 +1144,14 @@ separator between subsequent columns." (define* (show-manifest-transaction store manifest transaction #:key dry-run?) "Display what will/would be installed/removed from MANIFEST by TRANSACTION." - (define (package-strings name version output item) - (map (lambda (name version output item) - (format #f " ~a~:[:~a~;~*~]\t~a\t~a" - name - (equal? output "out") output version - (if (package? item) - (package-output store item output) - item))) - name version output item)) + (define (package-strings names versions outputs) + (tabulate (zip (map (lambda (name output) + (if (string=? output "out") + name + (string-append name ":" output))) + names outputs) + versions) + #:initial-indent 3)) (define → ;an arrow that can be represented on stderr (right-arrow (current-error-port))) @@ -1175,7 +1174,7 @@ separator between subsequent columns." (match remove ((($ name version output item) ..1) (let ((len (length name)) - (remove (package-strings name version output item))) + (remove (package-strings name version output))) (if dry-run? (format (current-error-port) (N_ "The following package would be removed:~%~{~a~%~}~%" @@ -1228,7 +1227,7 @@ separator between subsequent columns." (match install ((($ name version output item _) ..1) (let ((len (length name)) - (install (package-strings name version output item))) + (install (package-strings name version output))) (if dry-run? (format (current-error-port) (N_ "The following package would be installed:~%~{~a~%~}~%" -- cgit v1.2.3 From 53c594cb3f1f783fea18be6da23a863b00c14f5f Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 24 Mar 2020 16:56:19 +0100 Subject: pack: Do not store extended attributes in squashfs images. * guix/scripts/pack.scm (squashfs-image)[build](mksquashfs): Pass "-no-xattrs". --- guix/scripts/pack.scm | 4 ++++ 1 file changed, 4 insertions(+) (limited to 'guix') diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm index 6829d7265f..b6fb73838d 100644 --- a/guix/scripts/pack.scm +++ b/guix/scripts/pack.scm @@ -373,6 +373,10 @@ added to the pack." ;; file system since it's useless in this case. "-no-recovery" + ;; Do not attempt to store extended attributes. + ;; See . + "-no-xattrs" + ;; Set file times and the file system creation time to ;; one second after the Epoch. "-all-time" "1" "-mkfs-time" "1" -- cgit v1.2.3 From 637db76d7ad1af5323a6a6b87b8a6a2e6dfed754 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 24 Mar 2020 18:12:30 +0100 Subject: guix system: Fix mistaken 'guix pull' warning upon 'reconfigure'. Fixes . Reported by Florian Pelz . * guix/scripts/system.scm (maybe-suggest-running-guix-pull): Check whether 'current-profile' returns true instead of checking for the existence of ~root/.config/guix/current. That way, "sudo guix system reconfigure" no longer emits a warning in that case. --- guix/scripts/system.scm | 16 ++++++---------- 1 file changed, 6 insertions(+), 10 deletions(-) (limited to 'guix') diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm index 8d1938281a..61a3c95dbd 100644 --- a/guix/scripts/system.scm +++ b/guix/scripts/system.scm @@ -27,6 +27,7 @@ #:use-module ((guix status) #:select (with-status-verbosity)) #:use-module (guix store) #:autoload (guix store database) (register-path) + #:use-module (guix describe) #:use-module (guix grafts) #:use-module (guix gexp) #:use-module (guix derivations) @@ -718,16 +719,11 @@ checking this by themselves in their 'check' procedure." (define (maybe-suggest-running-guix-pull) "Suggest running 'guix pull' if this has never been done before." - ;; The reason for this is that the 'guix' binding that we see here comes - ;; from either ~/.config/latest or, if it's missing, from the - ;; globally-installed Guix, which is necessarily older. See - ;; for - ;; a discussion. - (define latest - (string-append (config-directory) "/current")) - - (unless (file-exists? latest) - (warning (G_ "~a not found: 'guix pull' was never run~%") latest) + ;; Check whether we're running a 'guix pull'-provided 'guix' command. When + ;; 'current-profile' returns #f, we may be running the globally-installed + ;; 'guix' and thus run the risk of deploying an older 'guix'. See + ;; + (unless (or (current-profile) (getenv "GUIX_UNINSTALLED")) (warning (G_ "Consider running 'guix pull' before 'reconfigure'.~%")) (warning (G_ "Failing to do that may downgrade your system!~%")))) -- cgit v1.2.3 From 3874dc5ef2e0d301dc708bf433e13362e0759a0a Mon Sep 17 00:00:00 2001 From: Christopher Baines Date: Sun, 15 Mar 2020 18:48:01 +0000 Subject: lint: Add a requires-store? field to the checker record. This can then be used to mark checkers that require a store connection, which will enable passing a connection in, avoiding the overhead of establishing a connection inside the check function when it's run for lots of different packages. * guix/lint.scm (): Add requires-store? to the record type. --- guix/lint.scm | 7 +++++-- 1 file changed, 5 insertions(+), 2 deletions(-) (limited to 'guix') diff --git a/guix/lint.scm b/guix/lint.scm index 40bddd0a41..a324858f68 100644 --- a/guix/lint.scm +++ b/guix/lint.scm @@ -100,7 +100,8 @@ lint-checker? lint-checker-name lint-checker-description - lint-checker-check)) + lint-checker-check + lint-checker-requires-store?)) ;;; @@ -155,7 +156,9 @@ ;; 'certainty' level. (name lint-checker-name) (description lint-checker-description) - (check lint-checker-check)) + (check lint-checker-check) + (requires-store? lint-checker-requires-store? + (default #f))) (define (properly-starts-sentence? s) (string-match "^[(\"'`[:upper:][:digit:]]" s)) -- cgit v1.2.3 From d84ad6a24ed0a51f72db0a17df093e79cd600f6d Mon Sep 17 00:00:00 2001 From: Christopher Baines Date: Sun, 15 Mar 2020 18:48:24 +0000 Subject: lint: Mark the derivation checker as requiring a store connection. * guix/lint.scm (%local-checkers): Mark the derivation checker as requiring a store connection. --- guix/lint.scm | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) (limited to 'guix') diff --git a/guix/lint.scm b/guix/lint.scm index a324858f68..631ba3b59d 100644 --- a/guix/lint.scm +++ b/guix/lint.scm @@ -1331,9 +1331,10 @@ or a list thereof") (description "Check for autogenerated tarballs") (check check-source-unstable-tarball)) (lint-checker - (name 'derivation) - (description "Report failure to compile a package to a derivation") - (check check-derivation)) + (name 'derivation) + (description "Report failure to compile a package to a derivation") + (check check-derivation) + (requires-store? #t)) (lint-checker (name 'patch-file-names) (description "Validate file names and availability of patches") -- cgit v1.2.3 From 7826fbc02b19727e4bd56dd3a4dc3046f2770b84 Mon Sep 17 00:00:00 2001 From: Christopher Baines Date: Sun, 15 Mar 2020 20:53:02 +0000 Subject: lint: Add a #:store argument to check-derivation This can then be used to avoid opening up a store connection each time a package needs checking. * guix/lint.scm (check-derivation): Add a #:store argument, and pull the handling of the store connection out of the try function. --- guix/lint.scm | 36 ++++++++++++++++++++---------------- 1 file changed, 20 insertions(+), 16 deletions(-) (limited to 'guix') diff --git a/guix/lint.scm b/guix/lint.scm index 631ba3b59d..2be3cc3ee3 100644 --- a/guix/lint.scm +++ b/guix/lint.scm @@ -918,9 +918,9 @@ descriptions maintained upstream." (define exception-with-kind-and-args? (const #f)))) -(define (check-derivation package) +(define* (check-derivation package #:key store) "Emit a warning if we fail to compile PACKAGE to a derivation." - (define (try system) + (define (try store system) (catch #t ;TODO: Remove 'catch' when Guile 2.x is no longer supported. (lambda () (guard (c ((store-protocol-error? c) @@ -939,25 +939,29 @@ descriptions maintained upstream." (G_ "failed to create ~a derivation: ~a") (list system (condition-message c))))) - (with-store store - ;; Disable grafts since it can entail rebuilds. - (parameterize ((%graft? #f)) - (package-derivation store package system #:graft? #f) - - ;; If there's a replacement, make sure we can compute its - ;; derivation. - (match (package-replacement package) - (#f #t) - (replacement - (package-derivation store replacement system - #:graft? #f))))))) + (parameterize ((%graft? #f)) + (package-derivation store package system #:graft? #f) + + ;; If there's a replacement, make sure we can compute its + ;; derivation. + (match (package-replacement package) + (#f #t) + (replacement + (package-derivation store replacement system + #:graft? #f)))))) (lambda args (make-warning package (G_ "failed to create ~a derivation: ~s") (list system args))))) - (filter lint-warning? - (map try (package-supported-systems package)))) + (define (check-with-store store) + (filter lint-warning? + (map (cut try store <>) (package-supported-systems package)))) + + ;; For backwards compatability, don't rely on store being set + (or (and=> store check-with-store) + (with-store store + (check-with-store store)))) (define (check-license package) "Warn about type errors of the 'license' field of PACKAGE." -- cgit v1.2.3 From 57e12aad6dfc2d12567164144dd15161e66f32d5 Mon Sep 17 00:00:00 2001 From: Christopher Baines Date: Sun, 15 Mar 2020 20:54:50 +0000 Subject: scripts: lint: Handle store connections for lint checkers. Rather than individual checkers opening up a connection to the store for each package to check, if any checker requires a store connection, open a connection and pass it to all checkers that would use it. This makes running the derivation checker much faster for multiple packages. * guix/scripts/lint.scm (run-checkers): Add a #:store argument, and pass the store to checkers if they require a store connection. (guix-lint): Establish a store connection if any checker requires one, and pass it through to run-checkers. --- guix/scripts/lint.scm | 38 ++++++++++++++++++++++++++++---------- 1 file changed, 28 insertions(+), 10 deletions(-) (limited to 'guix') diff --git a/guix/scripts/lint.scm b/guix/scripts/lint.scm index 8d08c484f5..97ffd57301 100644 --- a/guix/scripts/lint.scm +++ b/guix/scripts/lint.scm @@ -30,6 +30,7 @@ #:use-module (guix packages) #:use-module (guix lint) #:use-module (guix ui) + #:use-module (guix store) #:use-module (guix scripts) #:use-module (guix scripts build) #:use-module (gnu packages) @@ -53,7 +54,7 @@ (lint-warning-message lint-warning)))) warnings)) -(define (run-checkers package checkers) +(define* (run-checkers package checkers #:key store) "Run the given CHECKERS on PACKAGE." (let ((tty? (isatty? (current-error-port)))) (for-each (lambda (checker) @@ -63,7 +64,9 @@ (lint-checker-name checker)) (force-output (current-error-port))) (emit-warnings - ((lint-checker-check checker) package))) + (if (lint-checker-requires-store? checker) + ((lint-checker-check checker) package #:store store) + ((lint-checker-check checker) package)))) checkers) (when tty? (format (current-error-port) "\x1b[K") @@ -167,12 +170,27 @@ run the checkers on all packages.\n")) (_ #f)) (reverse opts))) (checkers (or (assoc-ref opts 'checkers) %all-checkers))) - (cond - ((assoc-ref opts 'list?) + + (when (assoc-ref opts 'list?) (list-checkers-and-exit checkers)) - ((null? args) - (fold-packages (lambda (p r) (run-checkers p checkers)) '())) - (else - (for-each (lambda (spec) - (run-checkers (specification->package spec) checkers)) - args))))) + + (let ((any-lint-checker-requires-store? + (any lint-checker-requires-store? checkers))) + + (define (call-maybe-with-store proc) + (if any-lint-checker-requires-store? + (with-store store + (proc store)) + (proc #f))) + + (call-maybe-with-store + (lambda (store) + (cond + ((null? args) + (fold-packages (lambda (p r) (run-checkers p checkers + #:store store)) '())) + (else + (for-each (lambda (spec) + (run-checkers (specification->package spec) checkers + #:store store)) + args)))))))) -- cgit v1.2.3 From b005c240bb5e436ffe9d55c2dd75c9af85aa0fdd Mon Sep 17 00:00:00 2001 From: Ricardo Wurmus Date: Wed, 25 Mar 2020 09:36:58 +0100 Subject: import/cran: Support importing from Mercurial repositories. * guix/import/cran.scm (download): Accept keyword #:method; add case for hg method. (fetch-description): Handle hg repository. (description->package): Add cases for hg repositories and update call of DOWNLOAD procedure. (cran->guix-package): Retry importing from Bioconductor when hg import failed. --- guix/import/cran.scm | 96 +++++++++++++++++++++++++++++++++++++++++----------- 1 file changed, 77 insertions(+), 19 deletions(-) (limited to 'guix') diff --git a/guix/import/cran.scm b/guix/import/cran.scm index bb8226f714..9929f3cfae 100644 --- a/guix/import/cran.scm +++ b/guix/import/cran.scm @@ -21,6 +21,7 @@ (define-module (guix import cran) #:use-module (ice-9 match) #:use-module (ice-9 regex) + #:use-module (ice-9 popen) #:use-module ((ice-9 rdelim) #:select (read-string read-line)) #:use-module (srfi srfi-1) #:use-module (srfi srfi-2) @@ -37,7 +38,10 @@ #:use-module (guix base32) #:use-module ((guix download) #:select (download-to-store)) #:use-module (guix import utils) - #:use-module ((guix build utils) #:select (find-files)) + #:use-module ((guix build utils) + #:select (find-files + delete-file-recursively + with-directory-excursion)) #:use-module (guix utils) #:use-module (guix git) #:use-module ((guix build-system r) #:select (cran-uri bioconductor-uri)) @@ -191,11 +195,26 @@ bioconductor package NAME, or #F if the package is unknown." ;; Little helper to download URLs only once. (define download (memoize - (lambda* (url #:optional git) + (lambda* (url #:key method) (with-store store - (if git - (latest-repository-commit store url) - (download-to-store store url)))))) + (cond + ((eq? method 'git) + (latest-repository-commit store url)) + ((eq? method 'hg) + (call-with-temporary-directory + (lambda (dir) + (unless (zero? (system* "hg" "clone" url dir)) + (leave (G_ "~A: hg download failed~%") url)) + (with-directory-excursion dir + (let* ((port (open-pipe* OPEN_READ "hg" "id" "--id")) + (changeset (string-trim-right (read-string port)))) + (close-pipe port) + (for-each delete-file-recursively + (find-files dir "^\\.hg$" #:directories? #t)) + (let ((store-directory + (add-to-store store (basename url) #t "sha256" dir))) + (values store-directory changeset))))))) + (else (download-to-store store url))))))) (define (fetch-description repository name) "Return an alist of the contents of the DESCRIPTION file for the R package @@ -244,13 +263,25 @@ from ~s: ~a (~s)~%" (and (string-prefix? "http" name) ;; Download the git repository at "NAME" (call-with-values - (lambda () (download name #t)) + (lambda () (download name #:method 'git)) (lambda (dir commit) (and=> (description->alist (with-input-from-file (string-append dir "/DESCRIPTION") read-string)) (lambda (meta) (cons* `(git . ,name) `(git-commit . ,commit) + meta))))))) + ((hg) + (and (string-prefix? "http" name) + ;; Download the mercurial repository at "NAME" + (call-with-values + (lambda () (download name #:method 'hg)) + (lambda (dir changeset) + (and=> (description->alist (with-input-from-file + (string-append dir "/DESCRIPTION") read-string)) + (lambda (meta) + (cons* `(hg . ,name) + `(hg-changeset . ,changeset) meta))))))))) (define (listify meta field) @@ -404,11 +435,13 @@ from the alist META, which was derived from the R package's DESCRIPTION file." (let* ((base-url (case repository ((cran) %cran-url) ((bioconductor) %bioconductor-url) - ((git) #f))) + ((git) #f) + ((hg) #f))) (uri-helper (case repository ((cran) cran-uri) ((bioconductor) bioconductor-uri) - ((git) #f))) + ((git) #f) + ((hg) #f))) (name (assoc-ref meta "Package")) (synopsis (assoc-ref meta "Title")) (version (assoc-ref meta "Version")) @@ -416,11 +449,13 @@ from the alist META, which was derived from the R package's DESCRIPTION file." ;; Some packages have multiple home pages. Some have none. (home-page (case repository ((git) (assoc-ref meta 'git)) + ((hg) (assoc-ref meta 'hg)) (else (match (listify meta "URL") ((url rest ...) url) (_ (string-append base-url name)))))) (source-url (case repository ((git) (assoc-ref meta 'git)) + ((hg) (assoc-ref meta 'hg)) (else (match (apply uri-helper name version (case repository @@ -431,9 +466,13 @@ from the alist META, which was derived from the R package's DESCRIPTION file." ((? string? url) url) (_ #f))))) (git? (assoc-ref meta 'git)) - (source (download source-url git?)) + (hg? (assoc-ref meta 'hg)) + (source (download source-url #:method (cond + (git? 'git) + (hg? 'hg) + (else #f)))) (sysdepends (append - (if (needs-zlib? source (not git?)) '("zlib") '()) + (if (needs-zlib? source (not (or git? hg?))) '("zlib") '()) (filter (lambda (name) (not (member name invalid-packages))) (map string-downcase (listify meta "SystemRequirements"))))) @@ -451,33 +490,45 @@ from the alist META, which was derived from the R package's DESCRIPTION file." (version ,(case repository ((git) `(git-version ,version revision commit)) + ((hg) + `(string-append ,version "-" revision "." changeset)) (else version))) (source (origin - (method ,(if git? - 'git-fetch - 'url-fetch)) + (method ,(cond + (git? 'git-fetch) + (hg? 'hg-fetch) + (else 'url-fetch))) (uri ,(case repository ((git) `(git-reference (url ,(assoc-ref meta 'git)) (commit commit))) + ((hg) + `(hg-reference + (url ,(assoc-ref meta 'hg)) + (changeset changeset))) (else `(,(procedure-name uri-helper) ,name version ,@(or (and=> (assoc-ref meta 'bioconductor-type) (lambda (type) (list (list 'quote type)))) '()))))) - ,@(if git? - '((file-name (git-file-name name version))) - '()) + ,@(cond + (git? + '((file-name (git-file-name name version)))) + (hg? + '((file-name (string-append name "-" version "-checkout")))) + (else '())) (sha256 (base32 ,(bytevector->nix-base32-string (case repository ((git) (file-hash source (negate vcs-file?) #t)) + ((hg) + (file-hash source (negate vcs-file?) #t)) (else (file-sha256 source)))))))) - ,@(if (not (and git? + ,@(if (not (and git? hg? (equal? (string-append "r-" name) (cran-guix-name name)))) `((properties ,`(,'quasiquote ((,'upstream-name . ,name))))) @@ -486,9 +537,9 @@ from the alist META, which was derived from the R package's DESCRIPTION file." ,@(maybe-inputs sysdepends) ,@(maybe-inputs (map cran-guix-name propagate) 'propagated-inputs) ,@(maybe-inputs - `(,@(if (needs-fortran? source (not git?)) + `(,@(if (needs-fortran? source (not (or git? hg?))) '("gfortran") '()) - ,@(if (needs-pkg-config? source (not git?)) + ,@(if (needs-pkg-config? source (not (or git? hg?))) '("pkg-config") '()) ,@(if (needs-knitr? meta) '("r-knitr") '())) @@ -506,6 +557,10 @@ from the alist META, which was derived from the R package's DESCRIPTION file." `(let ((commit ,(assoc-ref meta 'git-commit)) (revision "1")) ,package)) + ((hg) + `(let ((changeset ,(assoc-ref meta 'hg-changeset)) + (revision "1")) + ,package)) (else package)) propagate))) @@ -521,6 +576,9 @@ s-expression corresponding to that package, or #f on failure." ((git) ;; Retry import from Bioconductor (cran->guix-package package-name 'bioconductor)) + ((hg) + ;; Retry import from Bioconductor + (cran->guix-package package-name 'bioconductor)) ((bioconductor) ;; Retry import from CRAN (cran->guix-package package-name 'cran)) -- cgit v1.2.3 From 2d5ee2c6e886ef3b717954b80c2c54c47c1805d2 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 25 Mar 2020 14:55:08 +0100 Subject: archive: Use 'with-build-handler'. * guix/scripts/archive.scm (export-from-store): Remove call to 'show-what-to-build' and dry-run? condition. (guix-archive): Wrap 'cond' in 'with-build-handler'. --- guix/scripts/archive.scm | 50 ++++++++++++++++++++++++------------------------ 1 file changed, 25 insertions(+), 25 deletions(-) (limited to 'guix') diff --git a/guix/scripts/archive.scm b/guix/scripts/archive.scm index 4f39920fe7..80f3b704d7 100644 --- a/guix/scripts/archive.scm +++ b/guix/scripts/archive.scm @@ -259,12 +259,7 @@ 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))) - (show-what-to-build store drv - #:use-substitutes? (assoc-ref opts 'substitutes?) - #:dry-run? (assoc-ref opts 'dry-run?)) - - (if (or (assoc-ref opts 'dry-run?) - (build-derivations store drv)) + (if (build-derivations store drv) (export-paths store files (current-output-port) #:recursive? (assoc-ref opts 'export-recursive?)) (leave (G_ "unable to export the given packages~%"))))) @@ -382,22 +377,27 @@ output port." (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 'list) - (list-contents (current-input-port))) - ((assoc-ref opts 'extract) - => - (lambda (target) - (restore-file (current-input-port) target))) - (else - (leave - (G_ "either '--export' or '--import' \ -must be specified~%")))))))))))) + (with-build-handler + (build-notifier #:use-substitutes? + (assoc-ref opts 'substitutes?) + #:dry-run? + (assoc-ref opts 'dry-run?)) + (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 'list) + (list-contents (current-input-port))) + ((assoc-ref opts 'extract) + => + (lambda (target) + (restore-file (current-input-port) target))) + (else + (leave + (G_ "either '--export' or '--import' \ +must be specified~%"))))))))))))) -- cgit v1.2.3 From c74f19d758c786d30ee238e3bc8c4e3f8893ba4b Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 25 Mar 2020 15:01:15 +0100 Subject: environment: Use 'with-build-handler'. * guix/scripts/environment.scm (build-environment): Remove. (guix-environment): Wrap 'with-status-verbosity' in 'with-build-handler'. Remove 'dry-run?' conditional. Use 'built-derivations' instead of 'build-environment'. --- guix/scripts/environment.scm | 144 ++++++++++++++++++++----------------------- 1 file changed, 66 insertions(+), 78 deletions(-) (limited to 'guix') diff --git a/guix/scripts/environment.scm b/guix/scripts/environment.scm index f04363750e..ca12346815 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, 2019 Ludovic Courtès +;;; Copyright © 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès ;;; Copyright © 2018 Mike Gerwitz ;;; ;;; This file is part of GNU Guix. @@ -364,19 +364,6 @@ for the corresponding packages." opts) manifest-entry=?))) -(define* (build-environment derivations opts) - "Build the DERIVATIONS required by the environment using the build options -in OPTS." - (let ((substitutes? (assoc-ref opts 'substitutes?)) - (dry-run? (assoc-ref opts 'dry-run?))) - (mbegin %store-monad - (show-what-to-build* derivations - #:use-substitutes? substitutes? - #:dry-run? dry-run?) - (if dry-run? - (return #f) - (built-derivations derivations))))) - (define (manifest->derivation manifest system bootstrap?) "Return the derivation for a profile of MANIFEST. BOOTSTRAP? specifies whether to use the bootstrap Guile to build the profile." @@ -720,67 +707,68 @@ message if any test fails." (with-store store - (with-status-verbosity (assoc-ref opts 'verbosity) - (define manifest - (options/resolve-packages store opts)) - - (set-build-options-from-command-line store opts) - - ;; Use the bootstrap Guile when requested. - (parameterize ((%graft? (assoc-ref opts 'graft?)) - (%guile-for-build - (package-derivation - store - (if bootstrap? - %bootstrap-guile - (canonical-package guile-2.2))))) - (run-with-store store - ;; Containers need a Bourne shell at /bin/sh. - (mlet* %store-monad ((bash (environment-bash container? - bootstrap? - system)) - (prof-drv (manifest->derivation - manifest system bootstrap?)) - (profile -> (derivation->output-path prof-drv)) - (gc-root -> (assoc-ref opts 'gc-root))) - - ;; First build the inputs. This is necessary even for - ;; --search-paths. Additionally, we might need to build bash for - ;; a container. - (mbegin %store-monad - (build-environment (if (derivation? bash) - (list prof-drv bash) - (list prof-drv)) - opts) - (mwhen gc-root - (register-gc-root profile gc-root)) - - (cond - ((assoc-ref opts 'dry-run?) - (return #t)) - ((assoc-ref opts 'search-paths) - (show-search-paths profile manifest #:pure? pure?) - (return #t)) - (container? - (let ((bash-binary - (if bootstrap? - (derivation->output-path bash) - (string-append (derivation->output-path bash) - "/bin/sh")))) - (launch-environment/container #:command command - #:bash bash-binary - #:user user - #:user-mappings mappings - #:profile profile - #:manifest manifest - #:white-list white-list - #:link-profile? link-prof? - #:network? network? - #:map-cwd? (not no-cwd?)))) - - (else - (return - (exit/status - (launch-environment/fork command profile manifest - #:white-list white-list - #:pure? pure?)))))))))))))) + (with-build-handler (build-notifier #:use-substitutes? + (assoc-ref opts 'substitutes?) + #:dry-run? + (assoc-ref opts 'dry-run?)) + (with-status-verbosity (assoc-ref opts 'verbosity) + (define manifest + (options/resolve-packages store opts)) + + (set-build-options-from-command-line store opts) + + ;; Use the bootstrap Guile when requested. + (parameterize ((%graft? (assoc-ref opts 'graft?)) + (%guile-for-build + (package-derivation + store + (if bootstrap? + %bootstrap-guile + (canonical-package guile-2.2))))) + (run-with-store store + ;; Containers need a Bourne shell at /bin/sh. + (mlet* %store-monad ((bash (environment-bash container? + bootstrap? + system)) + (prof-drv (manifest->derivation + manifest system bootstrap?)) + (profile -> (derivation->output-path prof-drv)) + (gc-root -> (assoc-ref opts 'gc-root))) + + ;; First build the inputs. This is necessary even for + ;; --search-paths. Additionally, we might need to build bash for + ;; a container. + (mbegin %store-monad + (built-derivations (if (derivation? bash) + (list prof-drv bash) + (list prof-drv))) + (mwhen gc-root + (register-gc-root profile gc-root)) + + (cond + ((assoc-ref opts 'search-paths) + (show-search-paths profile manifest #:pure? pure?) + (return #t)) + (container? + (let ((bash-binary + (if bootstrap? + (derivation->output-path bash) + (string-append (derivation->output-path bash) + "/bin/sh")))) + (launch-environment/container #:command command + #:bash bash-binary + #:user user + #:user-mappings mappings + #:profile profile + #:manifest manifest + #:white-list white-list + #:link-profile? link-prof? + #:network? network? + #:map-cwd? (not no-cwd?)))) + + (else + (return + (exit/status + (launch-environment/fork command profile manifest + #:white-list white-list + #:pure? pure?))))))))))))))) -- cgit v1.2.3 From 9e1798901712d5858d2f2eaf00d41a36f3b8ff39 Mon Sep 17 00:00:00 2001 From: Ricardo Wurmus Date: Wed, 25 Mar 2020 16:27:22 +0100 Subject: import/cran: Import missing module. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit This is a follow-up to commit b005c240bb5e436ffe9d55c2dd75c9af85aa0fdd. Reported-by: Ludovic Courtès * guix/import/cran.scm: Import (guix ui) module. --- guix/import/cran.scm | 1 + 1 file changed, 1 insertion(+) (limited to 'guix') diff --git a/guix/import/cran.scm b/guix/import/cran.scm index 9929f3cfae..53b930acd0 100644 --- a/guix/import/cran.scm +++ b/guix/import/cran.scm @@ -45,6 +45,7 @@ #:use-module (guix utils) #:use-module (guix git) #:use-module ((guix build-system r) #:select (cran-uri bioconductor-uri)) + #:use-module (guix ui) #:use-module (guix upstream) #:use-module (guix packages) #:use-module (gnu packages) -- cgit v1.2.3 From e7570ec2da04af83eba695ded92eb824172b15c3 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 26 Mar 2020 12:25:37 +0100 Subject: profiles: 'profile-derivation' sets a 'type' property. * guix/profiles.scm (profile-derivation): Pass #:properties to 'gexp->derivation'. --- guix/profiles.scm | 8 +++++++- 1 file changed, 7 insertions(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/profiles.scm b/guix/profiles.scm index 20a2973579..3a6498993c 100644 --- a/guix/profiles.scm +++ b/guix/profiles.scm @@ -1590,7 +1590,13 @@ are cross-built for TARGET." ;; Disable substitution because it would trigger a ;; connection to the substitute server, which is likely ;; to have no substitute to offer. - #:substitutable? #f))) + #:substitutable? #f + + #:properties `((type . profile) + (profile + (count + . ,(length + (manifest-entries manifest)))))))) (define* (profile-search-paths profile #:optional (manifest (profile-manifest profile)) -- cgit v1.2.3 From 260eae789369170cad76ac0ef94fe9ae5af44ce0 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 26 Mar 2020 12:26:41 +0100 Subject: status: Display synthetic information about profiles being built. * guix/status.scm (print-build-event): Add 'profile case. * guix/scripts/package.scm (build-and-use-profile): Remove now redundant message. --- guix/scripts/package.scm | 4 ---- guix/status.scm | 10 +++++++++- 2 files changed, 9 insertions(+), 5 deletions(-) (limited to 'guix') diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm index b5d16acec0..110d4f2977 100644 --- a/guix/scripts/package.scm +++ b/guix/scripts/package.scm @@ -161,10 +161,6 @@ hooks\" run when building the profile." (switch-symlinks profile (basename name)) (unless (string=? profile %current-profile) (register-gc-root store name)) - (format #t (N_ "~a package in profile~%" - "~a packages in profile~%" - count) - count) (display-search-path-hint entries profile))) (warn-about-disk-space profile)))))) diff --git a/guix/status.scm b/guix/status.scm index cbea4151f2..4b2edc2f3c 100644 --- a/guix/status.scm +++ b/guix/status.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2017, 2018, 2019 Ludovic Courtès +;;; Copyright © 2017, 2018, 2019, 2020 Ludovic Courtès ;;; Copyright © 2018, 2019 Ricardo Wurmus ;;; ;;; This file is part of GNU Guix. @@ -476,6 +476,14 @@ addition to build events." "applying ~a grafts for ~a..." count)) count drv))) + ('profile + (let ((count (match (assq-ref properties 'profile) + (#f 0) + (lst (or (assq-ref lst 'count) 0))))) + (format port (info (N_ "building profile with ~a package..." + "building profile with ~a packages..." + count)) + count))) ('profile-hook (let ((hook-type (assq-ref properties 'hook))) (or (and=> (hook-message hook-type) -- cgit v1.2.3 From 2b6fe60599d52b449bbf531cfdc4dbf18a14eb2c Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 27 Mar 2020 18:36:20 +0100 Subject: packages: Use Guile 3.0 for grafts. * guix/packages.scm (guile-2.0): Rename to... (guile-for-grafts): ... this, and adjust callers. Refer to 'guile-3.0' instead of 'guile-2.0'. --- guix/packages.scm | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) (limited to 'guix') diff --git a/guix/packages.scm b/guix/packages.scm index 70b1478c91..2552f8bf7c 100644 --- a/guix/packages.scm +++ b/guix/packages.scm @@ -444,12 +444,12 @@ derivations." (let ((distro (resolve-interface '(gnu packages commencement)))) (module-ref distro 'guile-final))) -(define (guile-2.0) - "Return Guile 2.0." - ;; FIXME: This is used as a workaround for when +(define (guile-for-grafts) + "Return the Guile package used to build grafting derivations." + ;; Guile 2.2 would not work due to when ;; grafting packages. (let ((distro (resolve-interface '(gnu packages guile)))) - (module-ref distro 'guile-2.0))) + (module-ref distro 'guile-3.0))) (define* (default-guile-derivation #:optional (system (%current-system))) "Return the derivation for SYSTEM of the default Guile package used to run @@ -1269,7 +1269,7 @@ This is an internal procedure." (() drv) (grafts - (let ((guile (package-derivation store (guile-2.0) + (let ((guile (package-derivation store (guile-for-grafts) system #:graft? #f))) ;; TODO: As an optimization, we can simply graft the tip ;; of the derivation graph since 'graft-derivation' @@ -1295,7 +1295,7 @@ system identifying string)." (graft-derivation store drv grafts #:system system #:guile - (package-derivation store (guile-2.0) + (package-derivation store (guile-for-grafts) system #:graft? #f)))) drv)))) -- cgit v1.2.3 From 388b432cea4ae2bb9bf4b044026b7764ab002e1e Mon Sep 17 00:00:00 2001 From: Marius Bakke Date: Sat, 28 Mar 2020 15:55:13 +0100 Subject: deploy: Remove use of '~*' in format string. ...since 'msgfmt' fails to interpret it. Reported by Vagrant Cascadian in . See also . * guix/scripts/deploy.scm (show-what-to-deploy): Use ~d instead of ~* when displaying machines that will be deployed. --- guix/scripts/deploy.scm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/scripts/deploy.scm b/guix/scripts/deploy.scm index f70d41f35c..5c871cd6ed 100644 --- a/guix/scripts/deploy.scm +++ b/guix/scripts/deploy.scm @@ -102,7 +102,7 @@ Perform the deployment specified by FILE.\n")) "Show the list of machines to deploy, MACHINES." (let ((count (length machines))) (format (current-error-port) - (N_ "The following ~*machine will be deployed:~%" + (N_ "The following ~d machine will be deployed:~%" "The following ~d machines will be deployed:~%" count) count) -- cgit v1.2.3