From adbdf188c28c503a9c875b793bc88548d3cd702f Mon Sep 17 00:00:00 2001 From: Maxim Cournoyer Date: Mon, 10 Feb 2020 15:06:50 -0500 Subject: scripts: system: Do not validate network file systems. Fixes . * guix/scripts/system.scm (check-file-system-availability): Ignore file systems of the NFS type. --- guix/scripts/system.scm | 2 ++ 1 file changed, 2 insertions(+) (limited to 'guix') diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm index e69a3b6c97..b5e3a5630e 100644 --- a/guix/scripts/system.scm +++ b/guix/scripts/system.scm @@ -571,6 +571,8 @@ any, are available. Raise an error if they're not." (and (file-system-mount? fs) (not (member (file-system-type fs) %pseudo-file-system-types)) + ;; Don't try to validate network file systems. + (not (string-prefix? "nfs" (file-system-type fs))) (not (memq 'bind-mount (file-system-flags fs))))) file-systems)) -- cgit v1.2.3 From 35f35111678e6622301b414f3d464acb71e106bb Mon Sep 17 00:00:00 2001 From: Lars-Dominik Braun Date: Wed, 19 Feb 2020 11:13:54 +0100 Subject: ssh: Add Kerberos-support to ssh:// daemon URLs MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit * guix/ssh.scm (open-ssh-session): Fall back to GSSAPI if public key authentication does not work Signed-off-by: Ludovic Courtès --- guix/ssh.scm | 15 ++++++++++----- 1 file changed, 10 insertions(+), 5 deletions(-) (limited to 'guix') diff --git a/guix/ssh.scm b/guix/ssh.scm index 291ce20b61..56b49b177f 100644 --- a/guix/ssh.scm +++ b/guix/ssh.scm @@ -157,11 +157,16 @@ server at '~a': ~a") (session-set! session 'timeout timeout) session) (x - (disconnect! session) - (raise (condition - (&message - (message (format #f (G_ "SSH authentication failed for '~a': ~a~%") - host (get-error session))))))))) + (match (userauth-gssapi! session) + ('success + (session-set! session 'timeout timeout) + session) + (x + (disconnect! session) + (raise (condition + (&message + (message (format #f (G_ "SSH authentication failed for '~a': ~a~%") + host (get-error session))))))))))) (x ;; Connection failed or timeout expired. (raise (condition -- cgit v1.2.3 From e90e64049ce160d28d1e8b3014badcc2b214627c Mon Sep 17 00:00:00 2001 From: Pierre Neidhardt Date: Fri, 14 Feb 2020 10:30:31 +0100 Subject: build-system: Add copy-build-system. * guix/build-system/copy.scm: New file. * guix/build/copy-build-system.scm: New file. * Makefile.am (MODULES): Add them. * doc/guix.texi (Build Systems): Document 'copy-build-system'. --- guix/build-system/copy.scm | 143 +++++++++++++++++++++++++++++++++ guix/build/copy-build-system.scm | 165 +++++++++++++++++++++++++++++++++++++++ 2 files changed, 308 insertions(+) create mode 100644 guix/build-system/copy.scm create mode 100644 guix/build/copy-build-system.scm (limited to 'guix') diff --git a/guix/build-system/copy.scm b/guix/build-system/copy.scm new file mode 100644 index 0000000000..5fd0da4493 --- /dev/null +++ b/guix/build-system/copy.scm @@ -0,0 +1,143 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2019 Julien Lepiller +;;; Copyright © 2020 Pierre Neidhardt +;;; +;;; This file is part of GNU Guix. +;;; +;;; GNU Guix is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; GNU Guix is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with GNU Guix. If not, see . + +(define-module (guix build-system copy) + #:use-module (guix store) + #:use-module (guix utils) + #:use-module (guix derivations) + #:use-module (guix search-paths) + #:use-module (guix build-system) + #:use-module (guix build-system gnu) + #:use-module (guix packages) + #:use-module (ice-9 match) + #:use-module (srfi srfi-1) + #:export (%copy-build-system-modules + default-glibc + lower + copy-build + copy-build-system)) + +;; Commentary: +;; +;; Standard build procedure for simple packages that don't require much +;; compilation, mostly just copying files around. This is implemented as an +;; extension of `gnu-build-system'. +;; +;; Code: + +(define %copy-build-system-modules + ;; Build-side modules imported by default. + `((guix build copy-build-system) + ,@%gnu-build-system-modules)) + +(define (default-glibc) + "Return the default glibc package." + ;; Do not use `@' to avoid introducing circular dependencies. + (let ((module (resolve-interface '(gnu packages base)))) + (module-ref module 'glibc))) + +(define* (lower name + #:key source inputs native-inputs outputs system target + (glibc (default-glibc)) + #:allow-other-keys + #:rest arguments) + "Return a bag for NAME from the given arguments." + (define private-keywords + '(#:source #:target #:inputs #:native-inputs)) + + (bag + (name name) + (system system) + (host-inputs `(,@(if source + `(("source" ,source)) + '()) + ,@inputs + ;; Keep the standard inputs of 'gnu-build-system'. + ,@(standard-packages))) + (build-inputs native-inputs) + (outputs outputs) + (build copy-build) + (arguments (strip-keyword-arguments private-keywords arguments)))) + +(define* (copy-build store name inputs + #:key (guile #f) + (outputs '("out")) + (install-plan ''(("." (".") "./"))) + (search-paths '()) + (out-of-source? #t) + (validate-runpath? #t) + (patch-shebangs? #t) + (strip-binaries? #t) + (strip-flags ''("--strip-debug")) + (strip-directories ''("lib" "lib64" "libexec" + "bin" "sbin")) + (phases '(@ (guix build copy-build-system) + %standard-phases)) + (system (%current-system)) + (imported-modules %copy-build-system-modules) + (modules '((guix build copy-build-system) + (guix build utils)))) + "Build SOURCE using INSTALL-PLAN, and with INPUTS." + (define builder + `(begin + (use-modules ,@modules) + (copy-build #:source ,(match (assoc-ref inputs "source") + (((? derivation? source)) + (derivation->output-path source)) + ((source) + source) + (source + source)) + #:system ,system + #:outputs %outputs + #:inputs %build-inputs + #:install-plan ,install-plan + #:search-paths ',(map search-path-specification->sexp + search-paths) + #:phases ,phases + #:out-of-source? ,out-of-source? + #:validate-runpath? ,validate-runpath? + #:patch-shebangs? ,patch-shebangs? + #:strip-binaries? ,strip-binaries? + #:strip-flags ,strip-flags + #:strip-directories ,strip-directories))) + + (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 inputs + #:modules imported-modules + #:outputs outputs + #:guile-for-build guile-for-build)) + +(define copy-build-system + (build-system + (name 'copy) + (description "The standard copy build system") + (lower lower))) + +;;; copy.scm ends here diff --git a/guix/build/copy-build-system.scm b/guix/build/copy-build-system.scm new file mode 100644 index 0000000000..6d9dc8f93b --- /dev/null +++ b/guix/build/copy-build-system.scm @@ -0,0 +1,165 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2019 Julien Lepiller +;;; Copyright © 2020 Pierre Neidhardt +;;; +;;; This file is part of GNU Guix. +;;; +;;; GNU Guix is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; GNU Guix is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with GNU Guix. If not, see . + +(define-module (guix build copy-build-system) + #:use-module ((guix build gnu-build-system) #:prefix gnu:) + #:use-module (guix build utils) + #:use-module (ice-9 match) + #:use-module (ice-9 ftw) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-26) + #:export (%standard-phases + copy-build)) + +;; Commentary: +;; +;; System for building packages that don't require much compilation, mostly +;; only to copy files around. +;; +;; Code: + +(define* (install #:key install-plan outputs #:allow-other-keys) + "Copy files from the \"source\" build input to the \"out\" output according to INSTALL-PLAN. + +An install plan is a list of plans in the form: + + (SOURCE TARGET [FILTERS]) + +In the above, FILTERS are optional. + +- When SOURCE matches a file or directory without trailing slash, install it to + TARGET. + - If TARGET has a trailing slash, install SOURCE basename beneath TARGET. + - Otherwise install SOURCE as TARGET. + +- When SOURCE is a directory with a trailing slash, or when FILTERS are used, + the trailing slash of TARGET is implied. + - Without FILTERS, install the full SOURCE _content_ to TARGET. + The paths relative to SOURCE are preserved within TARGET. + - With FILTERS among `#:include`, `#:include-regexp`, `#:exclude`, + `#:exclude-regexp`: + - With `#:include`, install only the paths which suffix exactly matches + one of the elements in the list. + - With `#:include-regexp`, install subpaths matching the regexps in the list. + - The `#:exclude*` FILTERS work similarly. Without `#:include*` flags, + install every subpath but the files matching the `#:exlude*` filters. + If both `#:include*` and `#:exclude*` are specified, the exclusion is done + on the inclusion list. + +Examples: + +- `(\"foo/bar\" \"share/my-app/\")`: Install bar to \"share/my-app/bar\". +- `(\"foo/bar\" \"share/my-app/baz\")`: Install bar to \"share/my-app/baz\". +- `(\"foo/\" \"share/my-app\")`: Install the content of foo inside \"share/my-app\", + e.g. install \"foo/sub/file\" to \"share/my-app/sub/file\". +- `(\"foo/\" \"share/my-app\" #:include (\"sub/file\"))`: Install only \"foo/sub/file\" to +\"share/my-app/sub/file\". +- `(\"foo/sub\" \"share/my-app\" #:include (\"file\"))`: Install \"foo/sub/file\" to +\"share/my-app/file\"." + (define (install-simple source target) + "Install SOURCE to TARGET. +TARGET must point to a store location. +SOURCE may be a file or a directory. +If a directory, the directory itself is installed, not its content. +if TARGET ends with a '/', the source is installed underneath." + (let ((target (if (string-suffix? "/" target) + (string-append target (basename source)) + target))) + (mkdir-p (dirname target)) + (copy-recursively source target))) + + (define (install-file file target) + (let ((dest (string-append target + (if (string-suffix? "/" target) + (string-append "/" file) + file)))) + (format (current-output-port) "`~a' -> `~a'~%" file dest) + (mkdir-p (dirname dest)) + (copy-file file dest))) + + (define* (make-file-predicate suffixes matches-regexp #:optional (default-value #t)) + "Return a predicate that returns #t if its file argument matches the +SUFFIXES or the MATCHES-REGEXP. If neither SUFFIXES nor MATCHES-REGEXP is +given, then the predicate always returns DEFAULT-VALUE." + (if (or suffixes matches-regexp) + (let* ((suffixes (or suffixes '())) + (regexps (map make-regexp (or matches-regexp '()))) + (predicates (append + (map (lambda (str) + (cut string-suffix? str <>)) + suffixes) + (map (lambda (regexp) + (cut regexp-exec regexp <>)) + regexps)))) + (lambda (file) + (any (cut <> file) predicates))) + (const default-value))) + + (define* (install-file-list source target #:key include exclude include-regexp exclude-regexp) + ;; We must use switch current directory to source so that `find-files' + ;; returns file paths relative to source. + (with-directory-excursion source + (let* ((exclusion-pred (negate (make-file-predicate exclude exclude-regexp #f))) + (inclusion-pred (make-file-predicate include include-regexp)) + (file-list + (filter! exclusion-pred + (find-files "." (lambda (file _stat) + (inclusion-pred file)))))) + (map (cut install-file <> (if (string-suffix? "/" target) + target + (string-append target "/"))) + file-list)))) + + (define* (install source target #:key include exclude include-regexp exclude-regexp) + (set! target (string-append (assoc-ref outputs "out") "/" target)) + (let ((filters? (or include exclude include-regexp exclude-regexp))) + (when (and (not (file-is-directory? source)) + filters?) + (error "Cannot use filters when SOURCE is a file.")) + (let ((multi-files-in-source? + (or (string-suffix? "/" source) + (and (file-is-directory? source) + filters?)))) + (if multi-files-in-source? + (install-file-list source target + #:include include + #:exclude exclude + #:include-regexp include-regexp + #:exclude-regexp exclude-regexp) + (install-simple source target))))) + + (for-each (lambda (plan) (apply install plan)) install-plan) + #t) + +(define %standard-phases + ;; Everything is as with the GNU Build System except for the `configure' + ;; , `build', `check' and `install' phases. + (modify-phases gnu:%standard-phases + (delete 'bootstrap) + (delete 'configure) + (delete 'build) + (delete 'check) + (replace 'install install))) + +(define* (copy-build #:key inputs (phases %standard-phases) + #:allow-other-keys #:rest args) + "Build the given package, applying all of PHASES in order." + (apply gnu:gnu-build #:inputs inputs #:phases phases args)) + +;;; copy-build-system.scm ends here -- cgit v1.2.3 From 4cb63a564d413c745983a608790a943ac07f8d67 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Sat, 22 Feb 2020 00:40:30 +0100 Subject: deduplication: Use nix-base32 encoding for link names. Fixes . * guix/store/deduplication.scm (deduplicate): Use 'bytevector->nix-base32-string' instead of 'bytevector->base16-string'. --- guix/store/deduplication.scm | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) (limited to 'guix') diff --git a/guix/store/deduplication.scm b/guix/store/deduplication.scm index d42c40932c..80868692c0 100644 --- a/guix/store/deduplication.scm +++ b/guix/store/deduplication.scm @@ -1,6 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2017 Caleb Ristvedt -;;; Copyright © 2018, 2019 Ludovic Courtès +;;; Copyright © 2018, 2019, 2020 Ludovic Courtès ;;; ;;; This file is part of GNU Guix. ;;; @@ -23,7 +23,7 @@ (define-module (guix store deduplication) #:use-module (gcrypt hash) #:use-module (guix build utils) - #:use-module (guix base16) + #:use-module (guix base32) #:use-module (srfi srfi-11) #:use-module (rnrs io ports) #:use-module (ice-9 ftw) @@ -140,7 +140,7 @@ PATH so that future duplicates can hardlink to it. PATH is assumed to be under STORE." (let* ((links-directory (string-append store "/.links")) (link-file (string-append links-directory "/" - (bytevector->base16-string hash)))) + (bytevector->nix-base32-string hash)))) (mkdir-p links-directory) (if (eq? 'directory (stat:type (lstat path))) ;; Can't hardlink directories, so hardlink their atoms. -- cgit v1.2.3 From 3d1e42321f091b815835e28b54b37b7e9c79b9bb Mon Sep 17 00:00:00 2001 From: Matt Wette Date: Sat, 22 Feb 2020 11:48:29 +0100 Subject: import: github: Use HTTP "Authorization" header for access tokens. Fixes . The "access_token" query parameter is now deprecated: https://developer.github.com/changes/2019-11-05-deprecated-passwords-and-authorizations-api/#authenticating-using-query-parameters * guix/import/github.scm (fetch-releases-or-tags)[headers]: Add "Authorization" header when (%github-token) is true. [decorate]: Remove, and remove callers. --- guix/import/github.scm | 14 ++++++-------- 1 file changed, 6 insertions(+), 8 deletions(-) (limited to 'guix') diff --git a/guix/import/github.scm b/guix/import/github.scm index df5f6ff32f..7136e7a34f 100644 --- a/guix/import/github.scm +++ b/guix/import/github.scm @@ -154,18 +154,16 @@ empty list." ;; Ask for version 3 of the API as suggested at ;; . `((Accept . "application/vnd.github.v3+json") - (user-agent . "GNU Guile"))) + (user-agent . "GNU Guile") + ,@(if (%github-token) + `((Authorization . ,(string-append "token " (%github-token)))) + '()))) - (define (decorate url) - (if (%github-token) - (string-append url "?access_token=" (%github-token)) - url)) - - (match (json-fetch (decorate release-url) #:headers headers) + (match (json-fetch release-url #:headers headers) (#() ;; We got the empty list, presumably because the user didn't use GitHub's ;; "release" mechanism, but hopefully they did use Git tags. - (json-fetch (decorate tag-url) #:headers headers)) + (json-fetch tag-url #:headers headers)) (x x))) (define (latest-released-version url package-name) -- cgit v1.2.3 From 6a3911b88f84eff6b3268b4687caea405f43e39b Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Jakub=20K=C4=85dzio=C5=82ka?= Date: Sun, 23 Feb 2020 12:06:31 +0100 Subject: swh: Handle absolute URLs being returned by the API. * guix/swh.scm (swh-url): Don't prepend (%swh-base-url) if a domain is already present. This fixes the "guix lint: warning: while connecting to Software Heritage: host lookup failure: Name or service not known" error message. --- guix/swh.scm | 12 ++++++++++-- 1 file changed, 10 insertions(+), 2 deletions(-) (limited to 'guix') diff --git a/guix/swh.scm b/guix/swh.scm index 8bdf9965f6..ec744fed2f 100644 --- a/guix/swh.scm +++ b/guix/swh.scm @@ -1,5 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2018, 2019, 2020 Ludovic Courtès +;;; Copyright © 2020 Jakub Kądziołka ;;; ;;; This file is part of GNU Guix. ;;; @@ -126,9 +127,16 @@ (make-parameter "https://archive.softwareheritage.org")) (define (swh-url path . rest) + ;; URLs returned by the API may be relative or absolute. This has changed + ;; without notice before. Handle both cases by detecting whether the path + ;; starts with a domain. + (define root + (if (string-prefix? "/" path) + (string-append (%swh-base-url) path) + path)) + (define url - (string-append (%swh-base-url) path - (string-join rest "/" 'prefix))) + (string-append root (string-join rest "/" 'prefix))) ;; Ensure there's a trailing slash or we get a redirect. (if (string-suffix? "/" url) -- cgit v1.2.3 From fa99c4bbc7acdb8def9ce14a05aacb73f99fe3b1 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Sun, 23 Feb 2020 12:42:58 +0100 Subject: ui: (size->number "1.M") is correctly parsed. Reported by Pierre Neidhardt . * guix/ui.scm (size->number)[unit-pos]: Add #\. to CHAR-SET:DIGIT. * tests/ui.scm ("size->number, 1.M"): New test. --- guix/ui.scm | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/ui.scm b/guix/ui.scm index dce97fb7b9..db932ecacb 100644 --- a/guix/ui.scm +++ b/guix/ui.scm @@ -591,7 +591,8 @@ nicely." \"1MiB\", to a number of bytes. Raise an error if STR could not be interpreted." (define unit-pos - (string-rindex str char-set:digit)) + (string-rindex str + (char-set-union (char-set #\.) char-set:digit))) (define unit (and unit-pos (substring str (+ 1 unit-pos)))) -- cgit v1.2.3 From d7545a6b538813e88195d084f75a3e87065c999e Mon Sep 17 00:00:00 2001 From: zimoun Date: Mon, 17 Feb 2020 14:16:53 +0100 Subject: ui: Only display link in capable terminals. * guix/ui.scm (display-generation): Display generation path on new line. * guix/scripts/describe.scm (channel-commit-hyperlink): Add TRANSFORMER argument. (display-profile-content): Use TRANSFORMER argument to display URL explicitly when terminal does not support hyperlinks. --- guix/scripts/describe.scm | 15 +++++++++++---- guix/ui.scm | 2 +- 2 files changed, 12 insertions(+), 5 deletions(-) (limited to 'guix') diff --git a/guix/scripts/describe.scm b/guix/scripts/describe.scm index f13f221da9..5e00067ef8 100644 --- a/guix/scripts/describe.scm +++ b/guix/scripts/describe.scm @@ -201,7 +201,11 @@ way and displaying details about the channel's source code." (format #t (G_ " commit: ~a~%") (if (supports-hyperlinks?) (channel-commit-hyperlink channel commit) - commit)))) + commit)) + (when (not (supports-hyperlinks?)) + (format #t (G_ " URL: ~a~%") + (channel-commit-hyperlink channel commit + (lambda (url msg) url)))))) (_ #f))) ;; Show most recently installed packages last. @@ -233,9 +237,12 @@ way and displaying details about the channel's source code." (define* (channel-commit-hyperlink channel #:optional - (commit (channel-commit channel))) + (commit (channel-commit channel)) + (transformer hyperlink)) "Return a hyperlink for COMMIT in CHANNEL, using COMMIT as the hyperlink's -text. The hyperlink links to a web view of COMMIT, when available." +text. The hyperlink links to a web view of COMMIT, when available. +TRANSFORMER is a procedure of 2 arguments, a URI and text, and returns a +string for display." (let* ((url (channel-url channel)) (uri (string->uri url)) (host (and uri (uri-host uri)))) @@ -244,7 +251,7 @@ text. The hyperlink links to a web view of COMMIT, when available." (#f commit) ((_ template) - (hyperlink (template url commit) commit))) + (transformer (template url commit) commit))) commit))) diff --git a/guix/ui.scm b/guix/ui.scm index db932ecacb..371af4e047 100644 --- a/guix/ui.scm +++ b/guix/ui.scm @@ -1637,7 +1637,7 @@ DURATION-RELATION with the current time." (let* ((file (generation-file-name profile number)) (link (if (supports-hyperlinks?) (cut file-hyperlink file <>) - identity)) + (cut format #f (G_ "~a~%file: ~a") <> file))) (header (format #f (link (highlight (G_ "Generation ~a\t~a"))) number (date->string -- cgit v1.2.3 From 672d3d4a87839b0692c307df0edb66cd16bcbf1a Mon Sep 17 00:00:00 2001 From: Pierre Neidhardt Date: Mon, 17 Feb 2020 14:27:52 +0100 Subject: ui: Don't disable colors when INSIDE_EMACS is set. * guix/colors.scm (color-output?): Remove INSIDE_EMACS condition. --- guix/colors.scm | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) (limited to 'guix') diff --git a/guix/colors.scm b/guix/colors.scm index b63ac37027..3031f54799 100644 --- a/guix/colors.scm +++ b/guix/colors.scm @@ -131,8 +131,7 @@ that subsequent output will not have any colors in effect." (define (color-output? port) "Return true if we should write colored output to PORT." - (and (not (getenv "INSIDE_EMACS")) - (not (getenv "NO_COLOR")) + (and (not (getenv "NO_COLOR")) (isatty?* port))) (define (coloring-procedure color) -- cgit v1.2.3 From 9b7f9e6f9ba8dc9ea8b99573e0862856ff1b9475 Mon Sep 17 00:00:00 2001 From: Pierre Neidhardt Date: Mon, 17 Feb 2020 14:38:48 +0100 Subject: ui: Don't truncate search output when inside Emacs. * guix/ui.scm (display-search-results): Loop over all results when INSIDE_EMACS is set. --- guix/ui.scm | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/ui.scm b/guix/ui.scm index 371af4e047..22a6d6c8e3 100644 --- a/guix/ui.scm +++ b/guix/ui.scm @@ -1473,7 +1473,8 @@ them. If PORT is a terminal, print at most a full screen of results." #:hyperlinks? links? #:extra-fields `((relevance . ,score))))))) - (if (and max-rows + (if (and (not (getenv "INSIDE_EMACS")) + max-rows (> (port-line port) first-line) ;print at least one result (> (+ 4 (line-count text) (port-line port)) max-rows)) -- cgit v1.2.3 From 9ea458c57a1c539669e0976011215d021a79d614 Mon Sep 17 00:00:00 2001 From: Pierre Neidhardt Date: Mon, 24 Feb 2020 11:22:02 +0100 Subject: build-system: Fix copy-build-system default install plan. * guix/build-system/copy.scm (copy-build): Set install-plan default value to copy everything from source to the output. --- guix/build-system/copy.scm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/build-system/copy.scm b/guix/build-system/copy.scm index 5fd0da4493..d1bf8fb654 100644 --- a/guix/build-system/copy.scm +++ b/guix/build-system/copy.scm @@ -78,7 +78,7 @@ (define* (copy-build store name inputs #:key (guile #f) (outputs '("out")) - (install-plan ''(("." (".") "./"))) + (install-plan ''(("." "./"))) (search-paths '()) (out-of-source? #t) (validate-runpath? #t) -- cgit v1.2.3 From c23b42dd55e014a5a79032cc0ef85e775cb02e8b Mon Sep 17 00:00:00 2001 From: Julien Lepiller Date: Tue, 25 Feb 2020 00:26:16 +0100 Subject: guix: node-build-system: Do not symlink /bin. * guix/build/node-build-system.scm (install): Do not add a symlink for /bin. --- guix/build/node-build-system.scm | 5 +---- 1 file changed, 1 insertion(+), 4 deletions(-) (limited to 'guix') diff --git a/guix/build/node-build-system.scm b/guix/build/node-build-system.scm index 3c0ac2a12b..7799f03595 100644 --- a/guix/build/node-build-system.scm +++ b/guix/build/node-build-system.scm @@ -133,10 +133,7 @@ the @file{bin} directory." (symlink (string-append target "/node_modules/" modulename "/" value) (string-append binaries "/" key)))))) - binary-configuration)) - (else - (symlink (string-append target "/node_modules/" modulename "/bin") - binaries))) + binary-configuration))) (when dependencies (mkdir-p (string-append target "/node_modules/" modulename "/node_modules")) -- cgit v1.2.3 From 12f0aefd1418443823450fdd111259269ad3d9cb Mon Sep 17 00:00:00 2001 From: Danny Milosavljevic Date: Tue, 18 Feb 2020 10:42:06 +0100 Subject: build-system/linux-module: Disable depmod. * guix/build/linux-module-build-system.scm (install): Disable depmod. --- guix/build/linux-module-build-system.scm | 9 ++++++--- 1 file changed, 6 insertions(+), 3 deletions(-) (limited to 'guix') diff --git a/guix/build/linux-module-build-system.scm b/guix/build/linux-module-build-system.scm index cd76df2de7..8145d5a724 100644 --- a/guix/build/linux-module-build-system.scm +++ b/guix/build/linux-module-build-system.scm @@ -60,15 +60,18 @@ ;; part. (define* (install #:key inputs native-inputs outputs #:allow-other-keys) (let* ((out (assoc-ref outputs "out")) - (moddir (string-append out "/lib/modules")) - (kmod (assoc-ref (or native-inputs inputs) "kmod"))) + (moddir (string-append out "/lib/modules"))) ;; Install kernel modules (mkdir-p moddir) (invoke "make" "-C" (string-append (assoc-ref inputs "linux-module-builder") "/lib/modules/build") (string-append "M=" (getcwd)) - (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) -- cgit v1.2.3 From fb7eec3a84afd7464027d2492a8b551a61df2725 Mon Sep 17 00:00:00 2001 From: Pierre Neidhardt Date: Tue, 25 Feb 2020 11:23:30 +0100 Subject: scripts: Emit GC hint if free space is lower than absolute and relative threshold. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit * guix/scripts.scm (%disk-space-warning-absolute): New variable. (warn-about-disk-space): Test against %disk-space-warning-absolute. Fix error in display-hint due to extraneous 'profile' argument. Signed-off-by: Ludovic Courtès --- guix/scripts.scm | 65 ++++++++++++++++++++++++++++++++++++++++++++------------ 1 file changed, 51 insertions(+), 14 deletions(-) (limited to 'guix') diff --git a/guix/scripts.scm b/guix/scripts.scm index 77cbf12350..7ad1d5194c 100644 --- a/guix/scripts.scm +++ b/guix/scripts.scm @@ -181,32 +181,69 @@ Show what and how will/would be built." (newline (guix-warning-port)))) (define %disk-space-warning - ;; The fraction (between 0 and 1) of free disk space below which a warning - ;; is emitted. - (make-parameter (match (and=> (getenv "GUIX_DISK_SPACE_WARNING") - string->number) - (#f .05) ;5% - (threshold (/ threshold 100.))))) + ;; Return a pair of absolute threshold (number of bytes) and relative + ;; threshold (fraction between 0 and 1) for the free disk space below which + ;; a warning is emitted. + ;; GUIX_DISK_SPACE_WARNING can contain both thresholds. A value in [0;100) + ;; is a relative threshold, otherwise it's absolute. The following + ;; example values are valid: + ;; - 1GiB;10% ;1 GiB absolute, and 10% relative. + ;; - 15G ;15 GiB absolute, and default relative. + ;; - 99% ;99% relative, and default absolute. + ;; - 99 ;Same. + ;; - 100 ;100 absolute, and default relative. + (let* ((default-absolute-threshold (size->number "5GiB")) + (default-relative-threshold 0.05) + (percentage->float (lambda (percentage) + (or (and=> (string->number + (car (string-split percentage #\%))) + (lambda (n) (/ n 100.0))) + default-relative-threshold))) + (size->number* (lambda (size) + (or (false-if-exception (size->number size)) + default-absolute-threshold))) + (absolute? (lambda (size) + (not (or (string-suffix? "%" size) + (false-if-exception (< (size->number size) 100))))))) + (make-parameter + (match (getenv "GUIX_DISK_SPACE_WARNING") + (#f (list default-absolute-threshold + default-relative-threshold)) + (env-string (match (string-split env-string #\;) + ((threshold) + (if (absolute? threshold) + (list (size->number* threshold) + default-relative-threshold) + (list default-absolute-threshold + (percentage->float threshold)))) + ((threshold1 threshold2) + (if (absolute? threshold1) + (list (size->number* threshold1) + (percentage->float threshold2)) + (list (size->number* threshold2) + (percentage->float threshold1)))))))))) (define* (warn-about-disk-space #:optional profile #:key - (threshold (%disk-space-warning))) + (thresholds (%disk-space-warning))) "Display a hint about 'guix gc' if less than THRESHOLD of /gnu/store is -available." +available. +THRESHOLD is a pair of (ABSOLUTE-THRESHOLD RELATIVE-THRESHOLD)." (let* ((stats (statfs (%store-prefix))) (block-size (file-system-block-size stats)) (available (* block-size (file-system-blocks-available stats))) (total (* block-size (file-system-block-count stats))) - (ratio (/ available total 1.))) - (when (< ratio threshold) - (warning (G_ "only ~,1f% of free space available on ~a~%") - (* ratio 100) (%store-prefix)) + (relative-threshold-in-bytes (* total (cadr thresholds))) + (absolute-threshold-in-bytes (* 1024 1024 1024 (car thresholds)))) + (when (< available (min relative-threshold-in-bytes + absolute-threshold-in-bytes)) + (warning (G_ "only ~,1f GiB of free space available on ~a~%") + available (%store-prefix)) (display-hint (format #f (G_ "Consider deleting old profile generations and collecting garbage, along these lines: @example guix gc --delete-generations=1m -@end example\n") - profile))))) +@end example\n")))))) ;;; scripts.scm ends here -- cgit v1.2.3 From 9659459f0640ebfd2f662c26e939f38b0a4abf2b Mon Sep 17 00:00:00 2001 From: Maxim Cournoyer Date: Fri, 6 Dec 2019 15:12:32 +0900 Subject: emacs-build-system: Byte compile the autoload files. * guix/build/emacs-build-system.scm (enable-autoloads-compilation) (validate-compiled-autoloads): Add procedures. (%standard-phases): Register the new procedures. * gnu/packages/aux-files/emacs/guix-emacs.el (guix-emacs-find-autoloads): Remove duplicates in the list of autoload files found. * guix/build/emacs-utils.scm (expr->string): Add procedure. (emacs-batch-eval, emacs-batch-edit-file): Use it. --- guix/build/emacs-build-system.scm | 22 ++++++++++++++++++++-- guix/build/emacs-utils.scm | 10 ++++++++-- 2 files changed, 28 insertions(+), 4 deletions(-) (limited to 'guix') diff --git a/guix/build/emacs-build-system.scm b/guix/build/emacs-build-system.scm index 09de244993..219310cf08 100644 --- a/guix/build/emacs-build-system.scm +++ b/guix/build/emacs-build-system.scm @@ -225,6 +225,21 @@ parallel. PARALLEL-TESTS? is ignored when using a non-make TEST-COMMAND." (parameterize ((%emacs emacs)) (emacs-generate-autoloads elpa-name site-lisp)))) +(define* (enable-autoloads-compilation #:key outputs #:allow-other-keys) + "Remove the NO-BYTE-COMPILATION local variable embedded in the generated +autoload files." + (let* ((out (assoc-ref outputs "out")) + (autoloads (find-files out "-autoloads.el$"))) + (substitute* autoloads + ((";; no-byte-compile.*") "")) + #t)) + +(define* (validate-compiled-autoloads #:key outputs #:allow-other-keys) + "Verify whether the byte compiled autoloads load fine." + (let* ((out (assoc-ref outputs "out")) + (autoloads (find-files out "-autoloads.elc$"))) + (emacs-batch-eval (format #f "(mapc #'load '~s)" autoloads)))) + (define (emacs-package? name) "Check if NAME correspond to the name of an Emacs package." (string-prefix? "emacs-" name)) @@ -253,10 +268,13 @@ second hyphen. This corresponds to 'name-version' as used in ELPA packages." (replace 'check check) (replace 'install install) (add-after 'install 'make-autoloads make-autoloads) - (add-after 'make-autoloads 'patch-el-files patch-el-files) + (add-after 'make-autoloads 'enable-autoloads-compilation + enable-autoloads-compilation) + (add-after 'enable-autoloads-compilation 'patch-el-files patch-el-files) ;; The .el files are byte compiled directly in the store. (add-after 'patch-el-files 'build build) - (add-after 'build 'move-doc move-doc))) + (add-after 'build 'validate-compiled-autoloads validate-compiled-autoloads) + (add-after 'validate-compiled-autoloads 'move-doc move-doc))) (define* (emacs-build #:key inputs (phases %standard-phases) #:allow-other-keys #:rest args) diff --git a/guix/build/emacs-utils.scm b/guix/build/emacs-utils.scm index 885fd0a217..ab64e3714c 100644 --- a/guix/build/emacs-utils.scm +++ b/guix/build/emacs-utils.scm @@ -41,16 +41,22 @@ ;; The `emacs' command. (make-parameter "emacs")) +(define (expr->string expr) + "Converts EXPR, an expression, into a string." + (if (string? expr) + expr + (format #f "~s" expr))) + (define (emacs-batch-eval expr) "Run Emacs in batch mode, and execute the elisp code EXPR." (invoke (%emacs) "--quick" "--batch" - (format #f "--eval=~S" expr))) + (string-append "--eval=" (expr->string expr)))) (define (emacs-batch-edit-file file expr) "Load FILE in Emacs using batch mode, and execute the elisp code EXPR." (invoke (%emacs) "--quick" "--batch" (string-append "--visit=" file) - (format #f "--eval=~S" expr))) + (string-append "--eval=" (expr->string expr)))) (define (emacs-batch-disable-compilation file) (emacs-batch-edit-file file -- cgit v1.2.3 From 6b0653e7ec8a9a842fb62e28fe83c9677f40d552 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Thu, 27 Feb 2020 23:24:56 +0100 Subject: guix package: Don't error out when failing to create ~/.guix-profile. This is a followup to 7842ddcbc118cbc2799e22651732b7cdc06b93ee, which broke tests when 'HOME' is unset. * guix/scripts/package.scm (ensure-default-profile): Silently ignore 'symlink' exceptions. --- guix/scripts/package.scm | 7 +++++-- 1 file changed, 5 insertions(+), 2 deletions(-) (limited to 'guix') diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm index 1cb0d382bf..d2f4f1ccd3 100644 --- a/guix/scripts/package.scm +++ b/guix/scripts/package.scm @@ -81,12 +81,15 @@ "Ensure the default profile symlink and directory exist and are writable." (ensure-profile-directory) - ;; Create ~/.guix-profile if it doesn't exist yet. + ;; Try to create ~/.guix-profile if it doesn't exist yet. (when (and %user-profile-directory %current-profile (not (false-if-exception (lstat %user-profile-directory)))) - (symlink %current-profile %user-profile-directory))) + (catch 'system-error + (lambda () + (symlink %current-profile %user-profile-directory)) + (const #t)))) (define (delete-generations store profile generations) "Delete GENERATIONS from PROFILE. -- cgit v1.2.3 From 71c3c3df92375ca9b4bd28b2be90dda67288fa5c Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Thu, 27 Feb 2020 23:56:14 +0100 Subject: scripts: Adjust disk-space warning functionality. This is a followup to fb7eec3a84afd7464027d2492a8b551a61df2725. * guix/scripts.scm (warn-about-disk-space): Do not multiply ABSOLUTE-THRESHOLD-IN-BYTES by 2^30. Compare AVAILABLE to the max of RELATIVE-THRESHOLD-IN-BYTES and ABSOLUTE-THRESHOLD-IN-BYTES, not the min. Display AVAILABLE divided by 2^30. --- guix/scripts.scm | 12 +++++++----- 1 file changed, 7 insertions(+), 5 deletions(-) (limited to 'guix') diff --git a/guix/scripts.scm b/guix/scripts.scm index 7ad1d5194c..e235c8d4c3 100644 --- a/guix/scripts.scm +++ b/guix/scripts.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2013, 2014, 2015, 2017, 2018, 2019 Ludovic Courtès +;;; Copyright © 2013, 2014, 2015, 2017, 2018, 2019, 2020 Ludovic Courtès ;;; Copyright © 2014 Deck Pickard ;;; Copyright © 2015, 2016 Alex Kost ;;; @@ -228,17 +228,19 @@ Show what and how will/would be built." (thresholds (%disk-space-warning))) "Display a hint about 'guix gc' if less than THRESHOLD of /gnu/store is available. -THRESHOLD is a pair of (ABSOLUTE-THRESHOLD RELATIVE-THRESHOLD)." +THRESHOLDS is a pair (ABSOLUTE-THRESHOLD . RELATIVE-THRESHOLD)." + (define GiB (expt 2 30)) + (let* ((stats (statfs (%store-prefix))) (block-size (file-system-block-size stats)) (available (* block-size (file-system-blocks-available stats))) (total (* block-size (file-system-block-count stats))) (relative-threshold-in-bytes (* total (cadr thresholds))) - (absolute-threshold-in-bytes (* 1024 1024 1024 (car thresholds)))) - (when (< available (min relative-threshold-in-bytes + (absolute-threshold-in-bytes (car thresholds))) + (when (< available (max relative-threshold-in-bytes absolute-threshold-in-bytes)) (warning (G_ "only ~,1f GiB of free space available on ~a~%") - available (%store-prefix)) + (/ available 1. GiB) (%store-prefix)) (display-hint (format #f (G_ "Consider deleting old profile generations and collecting garbage, along these lines: -- cgit v1.2.3 From c2f9ea2b502a617bb69227d5f858eee9d4288a6a Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Fri, 28 Feb 2020 00:03:34 +0100 Subject: Revert "ui: Only display link in capable terminals." This reverts commit d7545a6b538813e88195d084f75a3e87065c999e. The commit led to a test failure in 'tests/guix-package-net.sh'. It also led to disagreements discussed here: https://lists.gnu.org/archive/html/guix-devel/2020-02/msg00353.html Reverting until these are addressed. --- guix/scripts/describe.scm | 15 ++++----------- guix/ui.scm | 2 +- 2 files changed, 5 insertions(+), 12 deletions(-) (limited to 'guix') diff --git a/guix/scripts/describe.scm b/guix/scripts/describe.scm index 5e00067ef8..f13f221da9 100644 --- a/guix/scripts/describe.scm +++ b/guix/scripts/describe.scm @@ -201,11 +201,7 @@ way and displaying details about the channel's source code." (format #t (G_ " commit: ~a~%") (if (supports-hyperlinks?) (channel-commit-hyperlink channel commit) - commit)) - (when (not (supports-hyperlinks?)) - (format #t (G_ " URL: ~a~%") - (channel-commit-hyperlink channel commit - (lambda (url msg) url)))))) + commit)))) (_ #f))) ;; Show most recently installed packages last. @@ -237,12 +233,9 @@ way and displaying details about the channel's source code." (define* (channel-commit-hyperlink channel #:optional - (commit (channel-commit channel)) - (transformer hyperlink)) + (commit (channel-commit channel))) "Return a hyperlink for COMMIT in CHANNEL, using COMMIT as the hyperlink's -text. The hyperlink links to a web view of COMMIT, when available. -TRANSFORMER is a procedure of 2 arguments, a URI and text, and returns a -string for display." +text. The hyperlink links to a web view of COMMIT, when available." (let* ((url (channel-url channel)) (uri (string->uri url)) (host (and uri (uri-host uri)))) @@ -251,7 +244,7 @@ string for display." (#f commit) ((_ template) - (transformer (template url commit) commit))) + (hyperlink (template url commit) commit))) commit))) diff --git a/guix/ui.scm b/guix/ui.scm index 22a6d6c8e3..fbe2b70485 100644 --- a/guix/ui.scm +++ b/guix/ui.scm @@ -1638,7 +1638,7 @@ DURATION-RELATION with the current time." (let* ((file (generation-file-name profile number)) (link (if (supports-hyperlinks?) (cut file-hyperlink file <>) - (cut format #f (G_ "~a~%file: ~a") <> file))) + identity)) (header (format #f (link (highlight (G_ "Generation ~a\t~a"))) number (date->string -- cgit v1.2.3 From a3b1f878dfeddfc8516fba8483e3191a3e4c887e Mon Sep 17 00:00:00 2001 From: Leo Prikler Date: Thu, 27 Feb 2020 14:49:11 +0100 Subject: build-system: copy-build-system: Keep symlinks symbolic. guix/build/copy-build-system.scm (install)[install-file]: Read symlinks as is done in install-simple through copy-recursively. Signed-off-by: Pierre Neidhardt --- guix/build/copy-build-system.scm | 8 +++++++- 1 file changed, 7 insertions(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/build/copy-build-system.scm b/guix/build/copy-build-system.scm index 6d9dc8f93b..a86f0cde29 100644 --- a/guix/build/copy-build-system.scm +++ b/guix/build/copy-build-system.scm @@ -91,7 +91,13 @@ if TARGET ends with a '/', the source is installed underneath." file)))) (format (current-output-port) "`~a' -> `~a'~%" file dest) (mkdir-p (dirname dest)) - (copy-file file dest))) + (let ((stat (lstat file))) + (case (stat:type stat) + ((symlink) + (let ((target (readlink file))) + (symlink target dest))) + (else + (copy-file file dest)))))) (define* (make-file-predicate suffixes matches-regexp #:optional (default-value #t)) "Return a predicate that returns #t if its file argument matches the -- cgit v1.2.3 From 99e676db43389af3a9e4c21734987c086fcaa8ed Mon Sep 17 00:00:00 2001 From: Maxim Cournoyer Date: Tue, 11 Feb 2020 23:56:45 -0500 Subject: file-systems: Add a 'file-system-device->string' procedure. * gnu/system/file-systems.scm (file-system-device->string): New procedure. * gnu/system.scm (bootable-kernel-arguments): Use it. * gnu/system/vm.scm (operating-system-uuid): Likewise. * guix/scripts/system.scm (display-system-generation): Likewise. --- guix/scripts/system.scm | 7 +------ 1 file changed, 1 insertion(+), 6 deletions(-) (limited to 'guix') diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm index b5e3a5630e..ac2475c551 100644 --- a/guix/scripts/system.scm +++ b/guix/scripts/system.scm @@ -517,12 +517,7 @@ list of services." (cond ((uuid? root-device) 0) ((file-system-label? root-device) 1) (else 2)) - (cond ((uuid? root-device) - (uuid->string root-device)) - ((file-system-label? root-device) - (file-system-label->string root-device)) - (else - root-device))) + (file-system-device->string root-device)) (format #t (G_ " kernel: ~a~%") kernel) -- cgit v1.2.3 From c8abbe1468bc69b5f2b481aa11da62bc59168b26 Mon Sep 17 00:00:00 2001 From: Lars-Dominik Braun Date: Wed, 4 Mar 2020 09:42:17 +0100 Subject: import: pypi: Add more licenses * guix/import/pypi.scm (string->license): Add the BSD 2-clause and MPL 2.0 licenses, and add more strings for BSD 3-clause and Expat license. Signed-off-by: Leo Famulari --- guix/import/pypi.scm | 7 +++++-- 1 file changed, 5 insertions(+), 2 deletions(-) (limited to 'guix') diff --git a/guix/import/pypi.scm b/guix/import/pypi.scm index 6897f42be3..10450155a0 100644 --- a/guix/import/pypi.scm +++ b/guix/import/pypi.scm @@ -6,6 +6,7 @@ ;;; Copyright © 2018 Ricardo Wurmus ;;; Copyright © 2019 Maxim Cournoyer ;;; Copyright © 2020 Jakub Kądziołka +;;; Copyright © 2020 Lars-Dominik Braun ;;; ;;; This file is part of GNU Guix. ;;; @@ -439,10 +440,12 @@ VERSION, SOURCE-URL, HOME-PAGE, SYNOPSIS, DESCRIPTION, and LICENSE." (match str ("GNU LGPL" license:lgpl2.0) ("GPL" license:gpl3) - ((or "BSD" "BSD License") license:bsd-3) - ((or "MIT" "MIT license" "Expat license") license:expat) + ((or "BSD" "BSD-3" "BSD License") license:bsd-3) + ("BSD-2-Clause" license:bsd-2) + ((or "MIT" "MIT license" "MIT License" "Expat license") license:expat) ("Public domain" license:public-domain) ((or "Apache License, Version 2.0" "Apache 2.0") license:asl2.0) + ("MPL 2.0" license:mpl2.0) (_ #f))) (define (pypi-package? package) -- cgit v1.2.3