diff options
Diffstat (limited to 'guix')
100 files changed, 3411 insertions, 1325 deletions
diff --git a/guix/build-system/copy.scm b/guix/build-system/copy.scm index bf7fcaedba..e15dc9f616 100644 --- a/guix/build-system/copy.scm +++ b/guix/build-system/copy.scm @@ -2,6 +2,7 @@ ;;; Copyright © 2019 Julien Lepiller <julien@lepiller.eu> ;;; Copyright © 2020 Pierre Neidhardt <mail@ambrevar.xyz> ;;; Copyright © 2021, 2022 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2023 Jonathan Brielmaier <jonathan.brielmaier@web.de> ;;; ;;; This file is part of GNU Guix. ;;; @@ -94,6 +95,7 @@ %standard-phases)) (system (%current-system)) (target #f) + (substitutable? #t) (imported-modules %copy-build-system-modules) (modules '((guix build copy-build-system) (guix build utils)))) @@ -130,6 +132,7 @@ (gexp->derivation name builder #:system system #:target #f + #:substitutable? substitutable? #:guile-for-build guile))) (define copy-build-system diff --git a/guix/build-system/gnu.scm b/guix/build-system/gnu.scm index 8054f9893a..e37785010b 100644 --- a/guix/build-system/gnu.scm +++ b/guix/build-system/gnu.scm @@ -541,7 +541,9 @@ platform." (map search-path-specification->sexp native-search-paths)) - #:phases #$phases + #:phases #$(if (pair? phases) + (sexp->gexp phases) + phases) #:locale #$locale #:bootstrap-scripts #$bootstrap-scripts #:configure-flags #$configure-flags diff --git a/guix/build-system/go.scm b/guix/build-system/go.scm index 4b3b67b08f..0a9761aac7 100644 --- a/guix/build-system/go.scm +++ b/guix/build-system/go.scm @@ -38,6 +38,7 @@ go-build-system go-pseudo-version? + go-target go-version->git-ref)) ;; Commentary: diff --git a/guix/build-system/linux-module.scm b/guix/build-system/linux-module.scm index 94a293da13..e46195b53c 100644 --- a/guix/build-system/linux-module.scm +++ b/guix/build-system/linux-module.scm @@ -66,7 +66,7 @@ (replace 'build (lambda _ (invoke "make" "modules_prepare"))) - (delete 'strip) ; faster + (delete 'strip) ;faster (replace 'install (lambda* (#:key inputs #:allow-other-keys) (let ((out-lib-build (string-append #$output "/lib/modules/build"))) @@ -210,6 +210,7 @@ (tests? #f) (phases '%standard-phases) (system (%current-system)) + (source-directory ".") (substitutable? #t) (imported-modules %linux-module-build-system-modules) @@ -229,6 +230,7 @@ (linux-module-build #:name #$name #:source #+source + #:source-directory #$source-directory #:system #$system #:target #$target #:arch #$(system->arch (or target system)) diff --git a/guix/build-system/meson.scm b/guix/build-system/meson.scm index ba3ffa6b1c..0948ad92b5 100644 --- a/guix/build-system/meson.scm +++ b/guix/build-system/meson.scm @@ -55,6 +55,7 @@ for TRIPLET." ((target-x86-64? triplet) "x86_64") ((target-arm32? triplet) "arm") ((target-aarch64? triplet) "aarch64") + ((target-mips64el? triplet) "mips64") ((target-powerpc? triplet) (if (target-64bit? triplet) "ppc64" diff --git a/guix/build-system/ocaml.scm b/guix/build-system/ocaml.scm index 67bb718e12..5f4308a46e 100644 --- a/guix/build-system/ocaml.scm +++ b/guix/build-system/ocaml.scm @@ -32,6 +32,8 @@ strip-ocaml4.07-variant package-with-ocaml4.09 strip-ocaml4.09-variant + package-with-ocaml5.0 + strip-ocaml5.0-variant default-findlib default-ocaml lower @@ -111,6 +113,18 @@ (let ((module (resolve-interface '(gnu packages ocaml)))) (module-ref module 'ocaml4.09-dune))) +(define (default-ocaml5.0) + (let ((ocaml (resolve-interface '(gnu packages ocaml)))) + (module-ref ocaml 'ocaml-5.0))) + +(define (default-ocaml5.0-findlib) + (let ((module (resolve-interface '(gnu packages ocaml)))) + (module-ref module 'ocaml5.0-findlib))) + +(define (default-ocaml5.0-dune) + (let ((module (resolve-interface '(gnu packages ocaml)))) + (module-ref module 'ocaml5.0-dune))) + (define* (package-with-explicit-ocaml ocaml findlib dune old-prefix new-prefix #:key variant-property) "Return a procedure of one argument, P. The procedure creates a package @@ -199,6 +213,19 @@ pre-defined variants." (inherit p) (properties (alist-delete 'ocaml4.09-variant (package-properties p))))) +(define package-with-ocaml5.0 + (package-with-explicit-ocaml (delay (default-ocaml5.0)) + (delay (default-ocaml5.0-findlib)) + (delay (default-ocaml5.0-dune)) + "ocaml-" "ocaml5.0-" + #:variant-property 'ocaml5.0-variant)) + +(define (strip-ocaml5.0-variant p) + "Remove the 'ocaml5.0-variant' property from P." + (package + (inherit p) + (properties (alist-delete 'ocaml5.0-variant (package-properties p))))) + (define* (lower name #:key source inputs native-inputs outputs system target (ocaml (default-ocaml)) diff --git a/guix/build-system/pyproject.scm b/guix/build-system/pyproject.scm new file mode 100644 index 0000000000..8f3b562ca3 --- /dev/null +++ b/guix/build-system/pyproject.scm @@ -0,0 +1,147 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2021 Lars-Dominik Braun <lars@6xq.net> +;;; Copyright © 2022 Marius Bakke <marius@gnu.org> +;;; +;;; 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 <http://www.gnu.org/licenses/>. + +(define-module (guix build-system pyproject) + #:use-module ((gnu packages) #:select (search-auxiliary-file)) + #:use-module (guix gexp) + #:use-module (guix store) + #:use-module (guix utils) + #:use-module (guix memoization) + #:use-module (guix gexp) + #:use-module (guix monads) + #:use-module (guix packages) + #:use-module (guix derivations) + #:use-module (guix search-paths) + #:use-module (guix build-system) + #:use-module (guix build-system gnu) + #:use-module (guix build-system python) + #:use-module (ice-9 match) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-26) + #:export (%pyproject-build-system-modules + default-python + pyproject-build + pyproject-build-system)) + +;; Commentary: +;; +;; Standard build procedure for Python packages using 'pyproject.toml'. +;; This is implemented as an extension of 'python-build-system'. +;; +;; Code: + +(define %pyproject-build-system-modules + ;; Build-side modules imported by default. + `((guix build pyproject-build-system) + (guix build json) + ,@%python-build-system-modules)) + +(define (default-python) + "Return the default Python package." + ;; Lazily resolve the binding to avoid a circular dependency. + (let ((python (resolve-interface '(gnu packages python)))) + (module-ref python 'python-toolchain))) + +(define sanity-check.py + ;; TODO: Merge with sanity-check.py in the next rebuild cycle. + (search-auxiliary-file "python/sanity-check-next.py")) + +(define* (lower name + #:key source inputs native-inputs outputs system target + (python (default-python)) + #:allow-other-keys + #:rest arguments) + "Return a bag for NAME." + (define private-keywords + '(#:target #:python #:inputs #:native-inputs)) + + (and (not target) ;XXX: no cross-compilation + (bag + (name name) + (system system) + (host-inputs `(,@(if source + `(("source" ,source)) + '()) + ,@inputs + + ;; Keep the standard inputs of 'gnu-build-system'. + ,@(standard-packages))) + (build-inputs `(("python" ,python) + ("sanity-check.py" ,(local-file sanity-check.py)) + ,@native-inputs)) + (outputs (append outputs '(wheel))) + (build pyproject-build) + (arguments (strip-keyword-arguments private-keywords arguments))))) + +(define* (pyproject-build name inputs + #:key source + (tests? #t) + (configure-flags ''()) + (build-backend #f) + (test-backend #f) + (test-flags ''()) + (phases '%standard-phases) + (outputs '("out" "wheel")) + (search-paths '()) + (system (%current-system)) + (guile #f) + (imported-modules %pyproject-build-system-modules) + (modules '((guix build pyproject-build-system) + (guix build utils)))) + "Build SOURCE using PYTHON, and with INPUTS." + (define build + (with-imported-modules imported-modules + #~(begin + (use-modules #$@(sexp->gexp modules)) + + #$(with-build-variables inputs outputs + #~(pyproject-build + #:name #$name + #:source #+source + #:configure-flags #$configure-flags + #:system #$system + #:build-backend #$build-backend + #:test-backend #$test-backend + #:test-flags #$test-flags + #:tests? #$tests? + #:phases #$(if (pair? phases) + (sexp->gexp phases) + phases) + #:outputs %outputs + #:search-paths '#$(sexp->gexp + (map search-path-specification->sexp + search-paths)) + #:inputs %build-inputs))))) + + + (mlet %store-monad ((guile (package->derivation (or guile (default-guile)) + system #:graft? #f))) + (gexp->derivation name build + #:system system + #:graft? #f ;consistent with 'gnu-build' + #:target #f + #:guile-for-build guile))) + +(define pyproject-build-system + (build-system + (name 'pyproject) + (description "The PEP517-compliant Python build system") + (lower lower))) + +;;; pyproject.scm ends here diff --git a/guix/build-system/python.scm b/guix/build-system/python.scm index efade6f74b..c8f04b2298 100644 --- a/guix/build-system/python.scm +++ b/guix/build-system/python.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2021 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2013-2017, 2021-2022 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2013 Andreas Enge <andreas@enge.fr> ;;; Copyright © 2013 Nikita Karetnikov <nikita@karetnikov.org> ;;; Copyright © 2021 Lars-Dominik Braun <lars@6xq.net> @@ -212,6 +212,7 @@ provides a 'setup.py' file as its build system." system #:graft? #f))) (gexp->derivation name build #:system system + #:graft? #f ;consistent with 'gnu-build' #:target #f #:guile-for-build guile))) diff --git a/guix/build-system/qt.scm b/guix/build-system/qt.scm index ba5c84347a..25fd18f8a8 100644 --- a/guix/build-system/qt.scm +++ b/guix/build-system/qt.scm @@ -180,6 +180,7 @@ provides a 'CMakeLists.txt' file as its build system." (mlet %store-monad ((guile (package->derivation (or guile (default-guile)) system #:graft? #f))) (gexp->derivation name builder + #:graft? #f ;consistent with 'gnu-build' #:system system #:guile-for-build guile))) @@ -266,6 +267,7 @@ build system." (mlet %store-monad ((guile (package->derivation (or guile (default-guile)) system #:graft? #f))) (gexp->derivation name builder + #:graft? #f ;consistent with 'gnu-build' #:system system #:guile-for-build guile))) diff --git a/guix/build-system/r.scm b/guix/build-system/r.scm index 620822b870..9b360ae581 100644 --- a/guix/build-system/r.scm +++ b/guix/build-system/r.scm @@ -61,7 +61,7 @@ release corresponding to NAME and VERSION." "/src/contrib/" name "_" version ".tar.gz") ;; TODO: use %bioconductor-version from (guix import cran) - (string-append "https://bioconductor.org/packages/3.15" + (string-append "https://bioconductor.org/packages/3.16" type-url-part "/src/contrib/" name "_" version ".tar.gz")))) diff --git a/guix/build-system/scons.scm b/guix/build-system/scons.scm index e38213e8e0..7a02fa8a0f 100644 --- a/guix/build-system/scons.scm +++ b/guix/build-system/scons.scm @@ -100,7 +100,9 @@ provides a 'SConstruct' file as its build system." #$(with-build-variables inputs outputs #~(scons-build #:name #$name #:source #+source - #:scons-flags #$(sexp->gexp scons-flags) + #:scons-flags #$(if (pair? scons-flags) + (sexp->gexp scons-flags) + scons-flags) #:system #$system #:build-targets #$build-targets #:test-target #$test-target diff --git a/guix/build/ant-build-system.scm b/guix/build/ant-build-system.scm index fae1b47ec5..d29912bf59 100644 --- a/guix/build/ant-build-system.scm +++ b/guix/build/ant-build-system.scm @@ -19,7 +19,6 @@ (define-module (guix build ant-build-system) #:use-module ((guix build gnu-build-system) #:prefix gnu:) - #:use-module (guix build syscalls) #:use-module (guix build utils) #:use-module (sxml simple) #:use-module (ice-9 match) @@ -201,7 +200,7 @@ dependencies of this jar file." repack them. This is necessary to ensure that archives are reproducible." (define (repack-archive jar) (format #t "repacking ~a\n" jar) - (let* ((dir (mkdtemp! "jar-contents.XXXXXX")) + (let* ((dir (mkdtemp "jar-contents.XXXXXX")) (manifest (string-append dir "/META-INF/MANIFEST.MF"))) (with-directory-excursion dir (invoke "jar" "xf" jar)) diff --git a/guix/build/cargo-build-system.scm b/guix/build/cargo-build-system.scm index 0a95672b00..41766228c2 100644 --- a/guix/build/cargo-build-system.scm +++ b/guix/build/cargo-build-system.scm @@ -2,7 +2,7 @@ ;;; Copyright © 2016 David Craven <david@craven.ch> ;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com> ;;; Copyright © 2019 Ivan Petkov <ivanppetkov@gmail.com> -;;; Copyright © 2019, 2020, 2021 Efraim Flashner <efraim@flashner.co.il> +;;; Copyright © 2019-2022 Efraim Flashner <efraim@flashner.co.il> ;;; Copyright © 2020 Jakub Kądziołka <kuba@kadziolka.net> ;;; Copyright © 2020 Marius Bakke <marius@gnu.org> ;;; @@ -135,7 +135,8 @@ Cargo.toml file present at its root." ;; so that we can generate any cargo checksums. ;; The --strip-components argument is needed to prevent creating ;; an extra directory within `crate-dir`. - (invoke "tar" "xvf" path "-C" crate-dir "--strip-components" "1"))))) + (format #t "Unpacking ~a~%" name) + (invoke "tar" "xf" path "-C" crate-dir "--strip-components" "1"))))) inputs) ;; Configure cargo to actually use this new directory. diff --git a/guix/build/clojure-build-system.scm b/guix/build/clojure-build-system.scm index cacbefb386..2cb153b6db 100644 --- a/guix/build/clojure-build-system.scm +++ b/guix/build/clojure-build-system.scm @@ -22,7 +22,6 @@ ant-build)) #:use-module (guix build clojure-utils) #:use-module (guix build java-utils) - #:use-module (guix build syscalls) #:use-module (guix build utils) #:use-module (ice-9 match) #:use-module (ice-9 regex) @@ -129,7 +128,7 @@ and repack them. This is necessary to ensure that archives are reproducible." ;; Note: .class files need to be strictly newer than source files, ;; otherwise the Clojure compiler will recompile sources. (let* ((early-1980 315619200) ; 1980-01-02 UTC - (dir (mkdtemp! "jar-contents.XXXXXX")) + (dir (mkdtemp "jar-contents.XXXXXX")) (manifest (string-append dir "/META-INF/MANIFEST.MF"))) (with-directory-excursion dir (invoke "jar" "xf" jar)) diff --git a/guix/build/debug-link.scm b/guix/build/debug-link.scm index f3284f74c4..80941df2fc 100644 --- a/guix/build/debug-link.scm +++ b/guix/build/debug-link.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2018 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2018, 2023 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -175,7 +175,15 @@ directories." outputs)) (append-map (lambda (directory) - (filter elf-file? + (filter (lambda (file) + (catch 'system-error + (lambda () + (elf-file? file)) + (lambda args + ;; FILE might be a dangling symlink. + (if (= ENOENT (system-error-errno args)) + #f + (apply throw args))))) (with-error-to-port (%make-void-port "w") (lambda () (find-files directory))))) diff --git a/guix/build/dub-build-system.scm b/guix/build/dub-build-system.scm index 9ee0433ffd..c9bc2af3a5 100644 --- a/guix/build/dub-build-system.scm +++ b/guix/build/dub-build-system.scm @@ -20,7 +20,6 @@ (define-module (guix build dub-build-system) #:use-module ((guix build gnu-build-system) #:prefix gnu:) - #:use-module (guix build syscalls) #:use-module (guix build utils) #:use-module (ice-9 popen) #:use-module (ice-9 rdelim) @@ -52,7 +51,7 @@ to do this (instead of just using /gnu/store as the directory) because we want to hide the libraries in subdirectories lib/dub/... instead of polluting the user's profile root." - (let* ((dir (mkdtemp! "/tmp/dub.XXXXXX")) + (let* ((dir (mkdtemp "/tmp/dub.XXXXXX")) (vendor-dir (string-append dir "/vendor"))) (setenv "HOME" dir) (mkdir vendor-dir) diff --git a/guix/build/dune-build-system.scm b/guix/build/dune-build-system.scm index e9ccc71057..f311cd37f1 100644 --- a/guix/build/dune-build-system.scm +++ b/guix/build/dune-build-system.scm @@ -42,13 +42,13 @@ build-flags))) #t) -(define* (check #:key (test-flags '()) (test-target "test") tests? +(define* (check #:key (test-flags '()) tests? (jbuild? #f) (package #f) (dune-release-flags '()) #:allow-other-keys) "Test the given package." (when tests? (let ((program (if jbuild? "jbuilder" "dune"))) - (apply invoke program "runtest" test-target + (apply invoke program "runtest" (append (if package (list "-p" package) dune-release-flags) test-flags)))) diff --git a/guix/build/emacs-utils.scm b/guix/build/emacs-utils.scm index b2280ae70c..850b1f5f2a 100644 --- a/guix/build/emacs-utils.scm +++ b/guix/build/emacs-utils.scm @@ -75,10 +75,15 @@ true, evaluate using dynamic scoping." (string-append "--visit=" file) (string-append "--eval=" (expr->string expr)))) -(define (emacs-batch-disable-compilation file) +(define* (emacs-batch-disable-compilation file #:key native?) + "Disable byte compilation for FILE. +If NATIVE?, only disable native compilation." (emacs-batch-edit-file file - '(progn - (add-file-local-variable 'no-byte-compile t) + `(progn + (add-file-local-variable ',(if native? + 'no-native-compile + 'no-byte-compile) + t) (basic-save-buffer)))) (define-condition-type &emacs-batch-error &error @@ -220,7 +225,7 @@ useful to avoid double quotes being added when the replacement is provided as a string." ((_ file (variable replacement modifier ...) ...) (emacs-substitute-sexps file - ((string-append "(def[a-z]+[[:space:]\n]+" variable "\\>") + ((string-append "(def[a-z]+[[:space:]\n]+" variable "\\_>") replacement modifier ...) ...)))) diff --git a/guix/build/java-utils.scm b/guix/build/java-utils.scm index 87c3ac43c9..6025c81667 100644 --- a/guix/build/java-utils.scm +++ b/guix/build/java-utils.scm @@ -21,7 +21,6 @@ (define-module (guix build java-utils) #:use-module (guix build utils) - #:use-module (guix build syscalls) #:use-module (guix build maven pom) #:use-module (guix build maven plugin) #:use-module (ice-9 match) @@ -83,7 +82,7 @@ fetched." "Unpack the jar archive, add the pom file, and repack it. This is necessary to ensure that maven can find dependencies." (format #t "adding ~a to ~a\n" pom-file jar) - (let* ((dir (mkdtemp! "jar-contents.XXXXXX")) + (let* ((dir (mkdtemp "jar-contents.XXXXXX")) (manifest (string-append dir "/META-INF/MANIFEST.MF")) (pom (get-pom pom-file)) (artifact (pom-artifactid pom)) diff --git a/guix/build/kconfig.scm b/guix/build/kconfig.scm new file mode 100644 index 0000000000..0c9ef6baff --- /dev/null +++ b/guix/build/kconfig.scm @@ -0,0 +1,181 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2020 Stefan <stefan-guix@vodafonemail.de> +;;; +;;; 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 <http://www.gnu.org/licenses/>. + +(define-module (guix build kconfig) + #:use-module (ice-9 rdelim) + #:use-module (ice-9 regex) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-26) + #:export (modify-defconfig + verify-config)) + +;; Commentary: +;; +;; Builder-side code to modify configurations for the Kconfig build system as +;; used by Linux and U-Boot. +;; +;; Code: + +(define (pair->config-string pair) + "Convert a PAIR back to a config-string." + (let* ((key (first pair)) + (value (cdr pair))) + (if (string? key) + (if (string? value) + (string-append key "=" value) + (string-append "# " key " is not set")) + value))) + +(define (config-string->pair config-string) + "Parse a configuration string like \"CONFIG_EXAMPLE=m\" into a key-value pair. +An error is thrown for invalid configurations. + +\"CONFIG_A=y\" -> '(\"CONFIG_A\" . \"y\") +\"CONFIG_B=\\\"\\\"\" -> '(\"CONFIG_B\" . \"\\\"\\\"\") +\"CONFIG_C=\" -> '(\"CONFIG_C\" . \"\") +\"# CONFIG_E is not set\" -> '(\"CONFIG_E\" . #f) +\"CONFIG_D\" -> '(\"CONFIG_D\" . #f) +\"# Any comment\" -> '(#f . \"# Any comment\") +\"\" -> '(#f . \"\") +\"# CONFIG_E=y\" -> (error \"Invalid configuration\") +\"CONFIG_E is not set\" -> (error \"Invalid configuration\") +\"Anything else\" -> (error \"Invalid configuration\")" + (define config-regexp + (make-regexp + ;; (match:substring (string-match "=(.*)" "=") 1) returns "", but the + ;; pattern "=(.+)?" makes it return #f instead. From a "CONFIG_A=" we like + ;; to get "", which later emits "CONFIG_A=" again. + (string-append "^ *(#[\\t ]*)?(CONFIG_[a-zA-Z0-9_]+)([\\t ]*=" + "[\\t ]*(.*)|([\\t ]+is[\\t ]+not[\\t ]+set))?$"))) + + (define config-comment-regexp + (make-regexp "^([\\t ]*(#.*)?)$")) + + (let ((match (regexp-exec config-regexp (string-trim-right config-string)))) + (if match + (let* ((comment (match:substring match 1)) + (key (match:substring match 2)) + (unset (match:substring match 5)) + (value (and (not comment) + (not unset) + (match:substring match 4)))) + (if (eq? (not comment) (not unset)) + ;; The key is uncommented and set or commented and unset. + (cons key value) + ;; The key is set or unset ambigiously. + (error (format #f "invalid configuration, did you mean \"~a\"?" + (pair->config-string (cons key #f))) + config-string))) + ;; This is not a valid or ambigious config-string, but maybe a + ;; comment. + (if (regexp-exec config-comment-regexp config-string) + (cons #f config-string) ;keep valid comments + (error "Invalid configuration" config-string))))) + +(define (defconfig->alist defconfig) + "Convert the content of a DEFCONFIG (or .config) file into an alist." + (with-input-from-file defconfig + (lambda () + (let loop ((alist '()) + (line (read-line))) + (if (eof-object? line) + ;; Building the alist is done, now check for duplicates. + ;; Note: the filter invocation is used to remove comments. + (let loop ((keys (map first (filter first alist))) + (duplicates '())) + (if (null? keys) + ;; The search for duplicates is done. + ;; Return the alist or throw an error on duplicates. + (if (null? duplicates) + (reverse alist) + (error + (format #f "duplicate configurations in ~a" defconfig) + (reverse duplicates))) + ;; Continue the search for duplicates. + (loop (cdr keys) + (if (member (first keys) (cdr keys)) + (cons (first keys) duplicates) + duplicates)))) + ;; Build the alist. + (loop (cons (config-string->pair line) alist) + (read-line))))))) + +(define (modify-defconfig defconfig configs) + "This function can modify a given DEFCONFIG (or .config) file by adding, +changing or removing the list of strings in CONFIGS. This allows customization +of Kconfig based projects like the kernel Linux or the bootloader 'Das U-Boot'. + +These are examples for CONFIGS to add, change or remove configurations to/from +DEFCONFIG: + +'(\"CONFIG_A=\\\"a\\\"\" + \"CONFIG_B=0\" + \"CONFIG_C=y\" + \"CONFIG_D=m\" + \"CONFIG_E=\" + \"# CONFIG_G is not set\" + ;; For convenience this abbrevation can be used for not set configurations. + \"CONFIG_F\") + +Instead of a list, CONFIGS can be a string with one configuration per line." + ;; Normalize CONFIGS to a list of configuration pairs. + (let* ((config-pairs (map config-string->pair + (append-map (cut string-split <> #\newline) + (if (string? configs) + (list configs) + configs)))) + ;; Generate a blocklist from all valid keys in config-pairs. + (blocklist (delete #f (map first config-pairs))) + ;; Generate an alist from the defconfig without the keys in blocklist. + (filtered-defconfig-pairs (remove (lambda (pair) + (member (first pair) blocklist)) + (defconfig->alist defconfig)))) + (with-output-to-file defconfig + (lambda () + (for-each (lambda (pair) + (display (pair->config-string pair)) + (newline)) + (append filtered-defconfig-pairs config-pairs)))))) + +(define (verify-config config defconfig) + "Verify that the CONFIG file contains all configurations from the DEFCONFIG +file. When the verification fails, raise an error with the mismatching keys +and their values." + (let* ((config-pairs (defconfig->alist config)) + (defconfig-pairs (defconfig->alist defconfig)) + (mismatching-pairs + (remove (lambda (pair) + ;; Remove all configurations, whose values are #f and + ;; whose keys are not in config-pairs, as not in + ;; config-pairs means unset, ... + (and (not (cdr pair)) + (not (assoc-ref config-pairs (first pair))))) + ;; ... from the defconfig-pairs different to config-pairs. + (lset-difference equal? + ;; Remove comments by filtering with first. + (filter first defconfig-pairs) + config-pairs)))) + (unless (null? mismatching-pairs) + (error (format #f "Mismatching configurations in ~a and ~a" + config defconfig) + (map (lambda (mismatching-pair) + (let* ((key (first mismatching-pair)) + (defconfig-value (cdr mismatching-pair)) + (config-value (assoc-ref config-pairs key))) + (cons key (list (list config-value defconfig-value))))) + mismatching-pairs))))) diff --git a/guix/build/pyproject-build-system.scm b/guix/build/pyproject-build-system.scm new file mode 100644 index 0000000000..c69ccc9d64 --- /dev/null +++ b/guix/build/pyproject-build-system.scm @@ -0,0 +1,381 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2021 Lars-Dominik Braun <lars@6xq.net> +;;; Copyright © 2022 Marius Bakke <marius@gnu.org> +;;; +;;; 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 <http://www.gnu.org/licenses/>. + +(define-module (guix build pyproject-build-system) + #:use-module ((guix build python-build-system) #:prefix python:) + #:use-module (guix build utils) + #:use-module (guix build json) + #:use-module (ice-9 match) + #:use-module (ice-9 ftw) + #:use-module (ice-9 format) + #:use-module (ice-9 rdelim) + #:use-module (ice-9 regex) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-26) + #:use-module (srfi srfi-34) + #:use-module (srfi srfi-35) + #:export (%standard-phases + add-installed-pythonpath + site-packages + python-version + pyproject-build)) + +;;; Commentary: +;;; +;;; PEP 517-compatible build system for Python packages. +;;; +;;; PEP 517 mandates the use of a TOML file called pyproject.toml at the +;;; project root, describing build and runtime dependencies, as well as the +;;; build system, which can be different from setuptools. This module uses +;;; that file to extract the build system used and call its wheel-building +;;; entry point build_wheel (see 'build). setuptools’ wheel builder is +;;; used as a fallback if either no pyproject.toml exists or it does not +;;; declare a build-system. It supports config_settings through the +;;; standard #:configure-flags argument. +;;; +;;; This wheel, which is just a ZIP file with a file structure defined +;;; by PEP 427 (https://www.python.org/dev/peps/pep-0427/), is then unpacked +;;; and its contents are moved to the appropriate locations in 'install. +;;; +;;; Then entry points, as defined by the PyPa Entry Point Specification +;;; (https://packaging.python.org/specifications/entry-points/) are read +;;; from a file called entry_points.txt in the package’s site-packages +;;; subdirectory and scripts are written to bin/. These are not part of a +;;; wheel and expected to be created by the installing utility. +;;; TODO: Add support for PEP-621 entry points. +;;; +;;; Caveats: +;;; - There is no support for in-tree build backends. +;;; +;;; Code: +;;; + +;; Re-export these variables from python-build-system as many packages +;; rely on these. +(define python-version python:python-version) +(define site-packages python:site-packages) +(define add-installed-pythonpath python:add-installed-pythonpath) + +;; Base error type. +(define-condition-type &python-build-error &error python-build-error?) + +;; Raised when 'check cannot find a valid test system in the inputs. +(define-condition-type &test-system-not-found &python-build-error + test-system-not-found?) + +;; Raised when multiple wheels are created by 'build. +(define-condition-type &cannot-extract-multiple-wheels &python-build-error + cannot-extract-multiple-wheels?) + +;; Raised, when no wheel has been built by the build system. +(define-condition-type &no-wheels-built &python-build-error no-wheels-built?) + +(define* (build #:key outputs build-backend configure-flags #:allow-other-keys) + "Build a given Python package." + + (define (pyproject.toml->build-backend file) + "Look up the build backend in a pyproject.toml file." + (call-with-input-file file + (lambda (in) + (let loop + ((line (read-line in 'concat))) + (if (eof-object? line) #f + (let ((m (string-match "build-backend = [\"'](.+)[\"']" line))) + (if m + (match:substring m 1) + (loop (read-line in 'concat))))))))) + + (let* ((wheel-output (assoc-ref outputs "wheel")) + (wheel-dir (if wheel-output wheel-output "dist")) + ;; There is no easy way to get data from Guile into Python via + ;; s-expressions, but we have JSON serialization already, which Python + ;; also supports out-of-the-box. + (config-settings (call-with-output-string + (cut write-json configure-flags <>))) + ;; python-setuptools’ default backend supports setup.py *and* + ;; pyproject.toml. Allow overriding this automatic detection via + ;; build-backend. + (auto-build-backend (if (file-exists? "pyproject.toml") + (pyproject.toml->build-backend + "pyproject.toml") + #f)) + ;; Use build system detection here and not in importer, because a) we + ;; have alot of legacy packages and b) the importer cannot update arbitrary + ;; fields in case a package switches its build system. + (use-build-backend (or build-backend + auto-build-backend + "setuptools.build_meta"))) + (format #t + "Using '~a' to build wheels, auto-detected '~a', override '~a'.~%" + use-build-backend auto-build-backend build-backend) + (mkdir-p wheel-dir) + ;; Call the PEP 517 build function, which drops a .whl into wheel-dir. + (invoke "python" "-c" + "import sys, importlib, json +config_settings = json.loads (sys.argv[3]) +builder = importlib.import_module(sys.argv[1]) +builder.build_wheel(sys.argv[2], config_settings=config_settings)" + use-build-backend + wheel-dir + config-settings))) + +(define* (check #:key tests? test-backend test-flags #:allow-other-keys) + "Run the test suite of a given Python package." + (if tests? + ;; Unfortunately with PEP 517 there is no common method to specify test + ;; systems. Guess test system based on inputs instead. + (let* ((pytest (which "pytest")) + (nosetests (which "nosetests")) + (nose2 (which "nose2")) + (have-setup-py (file-exists? "setup.py")) + (use-test-backend + (or test-backend + ;; Prefer pytest + (if pytest 'pytest #f) + (if nosetests 'nose #f) + (if nose2 'nose2 #f) + ;; But fall back to setup.py, which should work for most + ;; packages. XXX: would be nice not to depend on setup.py here? + ;; fails more often than not to find any tests at all. Maybe + ;; we can run `python -m unittest`? + (if have-setup-py 'setup.py #f)))) + (format #t "Using ~a~%" use-test-backend) + (match use-test-backend + ('pytest + (apply invoke pytest "-vv" test-flags)) + ('nose + (apply invoke nosetests "-v" test-flags)) + ('nose2 + (apply invoke nose2 "-v" "--pretty-assert" test-flags)) + ('setup.py + (apply invoke "python" "setup.py" + (if (null? test-flags) + '("test" "-v") + test-flags))) + ;; The developer should explicitly disable tests in this case. + (else (raise (condition (&test-system-not-found)))))) + (format #t "test suite not run~%"))) + +(define* (install #:key inputs outputs #:allow-other-keys) + "Install a wheel file according to PEP 427" + ;; See https://www.python.org/dev/peps/pep-0427/#installing-a-wheel-distribution-1-0-py32-none-any-whl + (let ((site-dir (site-packages inputs outputs)) + (python (assoc-ref inputs "python")) + (out (assoc-ref outputs "out"))) + (define (extract file) + "Extract wheel (ZIP file) into site-packages directory" + ;; Use Python’s zipfile to avoid extra dependency + (invoke "python" "-m" "zipfile" "-e" file site-dir)) + + (define python-hashbang + (string-append "#!" python "/bin/python")) + + (define* (merge-directories source destination + #:optional (post-move #f)) + "Move all files in SOURCE into DESTINATION, merging the two directories." + (format #t "Merging directory ~a into ~a~%" source destination) + (for-each (lambda (file) + (format #t "~a/~a -> ~a/~a~%" + source file destination file) + (mkdir-p destination) + (rename-file (string-append source "/" file) + (string-append destination "/" file)) + (when post-move + (post-move file))) + (scandir source + (negate (cut member <> '("." ".."))))) + (rmdir source)) + + (define (expand-data-directory directory) + "Move files from all .data subdirectories to their respective\ndestinations." + ;; Python’s distutils.command.install defines this mapping from source to + ;; destination mapping. + (let ((source (string-append directory "/scripts")) + (destination (string-append out "/bin"))) + (when (file-exists? source) + (merge-directories source destination + (lambda (f) + (let ((dest-path (string-append destination + "/" f))) + (chmod dest-path #o755) + ;; PEP 427 recommends that installers rewrite + ;; this odd shebang. + (substitute* dest-path + (("#!python") + python-hashbang))))))) + ;; Data can be contained in arbitrary directory structures. Most + ;; commonly it is used for share/. + (let ((source (string-append directory "/data")) + (destination out)) + (when (file-exists? source) + (merge-directories source destination))) + (let* ((distribution (car (string-split (basename directory) #\-))) + (source (string-append directory "/headers")) + (destination (string-append out "/include/python" + (python-version python) + "/" distribution))) + (when (file-exists? source) + (merge-directories source destination)))) + + (define (list-directories base predicate) + ;; Cannot use find-files here, because it’s recursive. + (scandir base + (lambda (name) + (let ((stat (lstat (string-append base "/" name)))) + (and (not (member name '("." ".."))) + (eq? (stat:type stat) 'directory) + (predicate name stat)))))) + + (let* ((wheel-output (assoc-ref outputs "wheel")) + (wheel-dir (if wheel-output wheel-output "dist")) + (wheels (map (cut string-append wheel-dir "/" <>) + (scandir wheel-dir + (cut string-suffix? ".whl" <>))))) + (cond + ((> (length wheels) 1) + ;; This code does not support multiple wheels yet, because their + ;; outputs would have to be merged properly. + (raise (condition (&cannot-extract-multiple-wheels)))) + ((= (length wheels) 0) + (raise (condition (&no-wheels-built))))) + (for-each extract wheels)) + (let ((datadirs (map (cut string-append site-dir "/" <>) + (list-directories site-dir + (file-name-predicate "\\.data$"))))) + (for-each (lambda (directory) + (expand-data-directory directory) + (rmdir directory)) datadirs)))) + +(define* (compile-bytecode #:key inputs outputs #:allow-other-keys) + "Compile installed byte-code in site-packages." + (let* ((site-dir (site-packages inputs outputs)) + (python (assoc-ref inputs "python")) + (major-minor (map string->number + (take (string-split (python-version python) #\.) 2))) + (<3.7? (match major-minor + ((major minor) + (or (< major 3) + (and (= major 3) + (< minor 7))))))) + (if <3.7? + ;; These versions don’t have the hash invalidation modes and do + ;; not produce reproducible bytecode files. + (format #t "Skipping bytecode compilation for Python version ~a < 3.7~%" + (python-version python)) + (invoke "python" "-m" "compileall" + "--invalidation-mode=unchecked-hash" site-dir)))) + +(define* (create-entrypoints #:key inputs outputs #:allow-other-keys) + "Implement Entry Points Specification +(https://packaging.python.org/specifications/entry-points/) by PyPa, +which creates runnable scripts in bin/ from entry point specification +file entry_points.txt. This is necessary, because wheels do not contain +these binaries and installers are expected to create them." + + (define (entry-points.txt->entry-points file) + "Specialized parser for Python configfile-like files, in particular +entry_points.txt. Returns a list of console_script and gui_scripts +entry points." + (call-with-input-file file + (lambda (in) + (let loop ((line (read-line in)) + (inside #f) + (result '())) + (if (eof-object? line) + result + (let* ((group-match (string-match "^\\[(.+)\\]$" line)) + (group-name (if group-match + (match:substring group-match 1) + #f)) + (next-inside (if (not group-name) + inside + (or (string=? group-name + "console_scripts") + (string=? group-name "gui_scripts")))) + (item-match (string-match + "^([^ =]+)\\s*=\\s*([^:]+):(.+)$" line))) + (if (and inside item-match) + (loop (read-line in) + next-inside + (cons (list (match:substring item-match 1) + (match:substring item-match 2) + (match:substring item-match 3)) + result)) + (loop (read-line in) next-inside result)))))))) + + (define (create-script path name module function) + "Create a Python script from an entry point’s NAME, MODULE and FUNCTION +and return write it to PATH/NAME." + (let ((interpreter (which "python")) + (file-path (string-append path "/" name))) + (format #t "Creating entry point for '~a.~a' at '~a'.~%" + module function file-path) + (call-with-output-file file-path + (lambda (port) + ;; Technically the script could also include search-paths, + ;; but having a generic 'wrap phases also handles manually + ;; written entry point scripts. + (format port "#!~a +# Auto-generated entry point script. +import sys +import ~a as mod +sys.exit (mod.~a ())~%" interpreter module function))) + (chmod file-path #o755))) + + (let* ((site-dir (site-packages inputs outputs)) + (out (assoc-ref outputs "out")) + (bin-dir (string-append out "/bin")) + (entry-point-files (find-files site-dir "^entry_points.txt$"))) + (mkdir-p bin-dir) + (for-each (lambda (f) + (for-each (lambda (ep) + (apply create-script + (cons bin-dir ep))) + (entry-points.txt->entry-points f))) + entry-point-files))) + +(define* (set-SOURCE-DATE-EPOCH* #:rest _) + "Set the 'SOURCE_DATE_EPOCH' environment variable. This is used by tools +that incorporate timestamps as a way to tell them to use a fixed timestamp. +See https://reproducible-builds.org/specs/source-date-epoch/." + ;; Use a post-1980 timestamp because the Zip format used in wheels do + ;; not support timestamps before 1980. + (setenv "SOURCE_DATE_EPOCH" "315619200")) + +(define %standard-phases + ;; The build phase only builds C extensions and copies the Python sources, + ;; while the install phase copies then byte-compiles the sources to the + ;; prefix directory. The check phase is moved after the installation phase + ;; to ease testing the built package. + (modify-phases python:%standard-phases + (replace 'set-SOURCE-DATE-EPOCH set-SOURCE-DATE-EPOCH*) + (replace 'build build) + (replace 'install install) + (delete 'check) + ;; Must be before tests, so they can use installed packages’ entry points. + (add-before 'wrap 'create-entrypoints create-entrypoints) + (add-after 'wrap 'check check) + (add-before 'check 'compile-bytecode compile-bytecode))) + +(define* (pyproject-build #:key inputs (phases %standard-phases) + #:allow-other-keys #:rest args) + "Build the given Python package, applying all of PHASES in order." + (apply python:python-build #:inputs inputs #:phases phases args)) + +;;; pyproject-build-system.scm ends here diff --git a/guix/build/syscalls.scm b/guix/build/syscalls.scm index e081aaca44..0358960ff5 100644 --- a/guix/build/syscalls.scm +++ b/guix/build/syscalls.scm @@ -46,10 +46,12 @@ MS_NOEXEC MS_REMOUNT MS_NOATIME + MS_NODIRATIME MS_STRICTATIME MS_RELATIME MS_BIND MS_MOVE + MS_REC MS_SHARED MS_LAZYTIME MNT_FORCE @@ -542,8 +544,10 @@ the last argument of `mknod'." (define MS_NOEXEC 8) (define MS_REMOUNT 32) (define MS_NOATIME 1024) +(define MS_NODIRATIME 2048) (define MS_BIND 4096) (define MS_MOVE 8192) +(define MS_REC 16384) (define MS_SHARED 1048576) (define MS_RELATIME 2097152) (define MS_STRICTATIME 16777216) @@ -645,7 +649,8 @@ the remaining unprocessed options." ("nodev" => MS_NODEV) ("noexec" => MS_NOEXEC) ("relatime" => MS_RELATIME) - ("noatime" => MS_NOATIME))))))) + ("noatime" => MS_NOATIME) + ("nodiratime" => MS_NODIRATIME))))))) (define (mount-flags mount) "Return the mount flags of MOUNT, a <mount> record, as an inclusive or of @@ -878,7 +883,7 @@ fdatasync(2) on the underlying file descriptor." (ST_NODEV => MS_NODEV) (ST_NOEXEC => MS_NOEXEC) (ST_NOATIME => MS_NOATIME) - (ST_NODIRATIME => 0) ;FIXME + (ST_NODIRATIME => MS_NODIRATIME) (ST_RELATIME => MS_RELATIME)))) (define-c-struct %statfs ;<bits/statfs.h> diff --git a/guix/channels.scm b/guix/channels.scm index ad6d3fb8ac..40cbc4bb3a 100644 --- a/guix/channels.scm +++ b/guix/channels.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2018-2022 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2018-2023 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2018 Ricardo Wurmus <rekado@elephly.net> ;;; Copyright © 2019 Jan (janneke) Nieuwenhuizen <janneke@gnu.org> ;;; Copyright © 2021 Brice Waegeneire <brice@waegenei.re> @@ -248,7 +248,7 @@ could be found at DIRECTORY or one of its ancestors." 'latest-repository-commit'." (match (channel-commit channel) (#f `(branch . ,(channel-branch channel))) - (commit `(commit . ,(channel-commit channel))))) + (commit `(tag-or-commit . ,(channel-commit channel))))) (define sexp->channel-introduction (match-lambda @@ -419,19 +419,28 @@ their relation. When AUTHENTICATE? is false, CHANNEL is not authenticated." (if authenticate? (if (channel-introduction channel) (authenticate-channel channel checkout commit) - ;; TODO: Warn for all the channels once the authentication interface - ;; is public. - (when (guix-channel? channel) - (raise (make-compound-condition - (formatted-message (G_ "channel '~a' lacks an \ + (begin + (when (file-exists? + (string-append checkout "/.guix-authorizations")) + (warning (and=> (channel-location channel) + source-properties->location) + (G_ "channel '~a' lacks 'introduction' field but \ +'.guix-authorizations' found\n") + (channel-name channel))) + + ;; TODO: Warn for all the channels once the authentication interface + ;; is public. + (when (guix-channel? channel) + (raise (make-compound-condition + (formatted-message (G_ "channel '~a' lacks an \ introduction and cannot be authenticated~%") - (channel-name channel)) - (condition - (&fix-hint - (hint (G_ "Add the missing introduction to your + (channel-name channel)) + (condition + (&fix-hint + (hint (G_ "Add the missing introduction to your channels file to address the issue. Alternatively, you can pass @option{--disable-authentication}, at the risk of running unauthenticated and -thus potentially malicious code.")))))))) +thus potentially malicious code."))))))))) (warning (G_ "channel authentication disabled~%"))) (when (guix-channel? channel) @@ -1048,7 +1057,9 @@ true, include its introduction, if any." (name ',(channel-name channel)) (url ,(channel-url channel)) (branch ,(channel-branch channel)) - (commit ,(channel-commit channel)) + ,@(if (channel-commit channel) + `((commit ,(channel-commit channel))) + '()) ,@(if intro `((introduction (make-channel-introduction ,(channel-introduction-first-signed-commit intro) diff --git a/guix/ci.scm b/guix/ci.scm index 88b80f781d..ecdffde2d1 100644 --- a/guix/ci.scm +++ b/guix/ci.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2018, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2018-2022 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2020 Mathieu Othacehe <othacehe@gnu.org> ;;; ;;; This file is part of GNU Guix. @@ -24,6 +24,7 @@ #:select (resolve-uri-reference)) #:use-module (json) #:use-module (srfi srfi-1) + #:use-module (srfi srfi-19) #:use-module (ice-9 match) #:use-module (web uri) #:use-module (guix i18n) @@ -42,6 +43,9 @@ build-system build-status build-timestamp + build-start-time + build-stop-time + build-duration build-products checkout? @@ -84,6 +88,11 @@ ;;; ;;; Code: +(define (seconds->date seconds) + "Given SECONDS, a number of seconds since 1970-01-01, return the +corresponding date object." + (time-utc->date (make-time time-utc 0 seconds))) + (define-json-mapping <build-product> make-build-product build-product? json->build-product @@ -118,6 +127,10 @@ (status build-status "buildstatus" ;symbol integer->build-status) (timestamp build-timestamp) ;integer + (start-time build-start-time "starttime" ;date + seconds->date) + (stop-time build-stop-time "stoptime" ;date + seconds->date) (products build-products "buildproducts" ;<build-product>* (lambda (products) (map json->build-product @@ -201,6 +214,14 @@ api-agnostic." (define* (json-api-fetch base-url path #:rest query) (json-fetch (apply api-url base-url path query))) +(define (build-duration build) + "Return the duration in seconds of BUILD." + (define duration + (time-difference (date->time-utc (build-stop-time build)) + (date->time-utc (build-start-time build)))) + + (time-second duration)) + (define* (queued-builds url #:optional (limit %query-limit)) "Return the list of queued derivations on URL." (let ((queue diff --git a/guix/derivations.scm b/guix/derivations.scm index 354ec20e3f..0bb6a28147 100644 --- a/guix/derivations.scm +++ b/guix/derivations.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2012-2021 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2012-2021, 2023 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2016, 2017 Mathieu Lirzin <mthl@gnu.org> ;;; ;;; This file is part of GNU Guix. @@ -484,17 +484,21 @@ things as appropriate and is thus more efficient." (fold-right (lambda (output result) (match output ((name path "" "") + ;; Regular derivation. (alist-cons name (make-derivation-output path #f #f #f) result)) ((name path hash-algo hash) - ;; fixed-output + ;; Fixed-output, unless HASH is the empty string (in that + ;; case, HASH-ALGO must be preserved despite being + ;; unused). (let* ((rec? (string-prefix? "r:" hash-algo)) (algo (string->symbol (if rec? (string-drop hash-algo 2) hash-algo))) - (hash (base16-string->bytevector hash))) + (hash (and (not (string-null? hash)) + (base16-string->bytevector hash)))) (alist-cons name (make-derivation-output path algo hash rec?) diff --git a/guix/download.scm b/guix/download.scm index 29a8f99034..fff54d7a17 100644 --- a/guix/download.scm +++ b/guix/download.scm @@ -97,7 +97,7 @@ "http://hackage.haskell.org/") (savannah ; http://download0.savannah.gnu.org/mirmon/savannah/ "https://download.savannah.gnu.org/releases/" - "https://nongnu.freemirror.org/nongnu/" + "https://de.freedif.org/savannah/" "https://ftp.cc.uoc.gr/mirrors/nongnu.org/" "http://ftp.twaren.net/Unix/NonGNU/" ; https appears unsupported "https://mirror.csclub.uwaterloo.ca/nongnu/" @@ -112,22 +112,16 @@ (sourceforge ; https://sourceforge.net/p/forge/documentation/Mirrors/ "http://downloads.sourceforge.net/project/" "http://ufpr.dl.sourceforge.net/project/" - "http://heanet.dl.sourceforge.net/project/" "http://freefr.dl.sourceforge.net/project/" "http://internode.dl.sourceforge.net/project/" "http://jaist.dl.sourceforge.net/project/" - "http://kent.dl.sourceforge.net/project/" "http://liquidtelecom.dl.sourceforge.net/project/" ;; "http://nbtelecom.dl.sourceforge.net/project/" ;never returns 404s "http://nchc.dl.sourceforge.net/project/" - "http://ncu.dl.sourceforge.net/project/" "http://netcologne.dl.sourceforge.net/project/" "http://netix.dl.sourceforge.net/project/" "http://pilotfiber.dl.sourceforge.net/project/" - "http://superb-sea2.dl.sourceforge.net/project/" - "http://tenet.dl.sourceforge.net/project/" - "http://vorboss.dl.sourceforge.net/project/" - "http://netassist.dl.sourceforge.net/project/") + "http://tenet.dl.sourceforge.net/project/") (netfilter.org ; https://www.netfilter.org/mirrors.html "http://ftp.netfilter.org/pub/" "ftp://ftp.es.netfilter.org/mirrors/netfilter/" diff --git a/guix/gexp.scm b/guix/gexp.scm index a50b93ed48..0fe4f1c98a 100644 --- a/guix/gexp.scm +++ b/guix/gexp.scm @@ -25,7 +25,6 @@ #:use-module (guix store) #:use-module (guix monads) #:use-module (guix derivations) - #:use-module (guix grafts) #:use-module (guix utils) #:use-module (guix diagnostics) #:use-module (guix i18n) diff --git a/guix/git.scm b/guix/git.scm index 53e7219c8c..95630a5e69 100644 --- a/guix/git.scm +++ b/guix/git.scm @@ -62,6 +62,7 @@ commit-difference commit-relation commit-descendant? + commit-id? remote-refs @@ -219,6 +220,12 @@ of SHA1 string." (last (string-split url #\/)) ".git" "") "-" (string-take sha1 7))) +(define (commit-id? str) + "Return true if STR is likely a Git commit ID, false otherwise---e.g., if it +is a tag name. This is based on a simple heuristic so use with care!" + (and (= (string-length str) 40) + (string-every char-set:hex-digit str))) + (define (resolve-reference repository ref) "Resolve the branch, commit or tag specified by REF, and return the corresponding Git object." @@ -265,12 +272,15 @@ corresponding Git object." ;; There's no such tag, so it must be a commit ID. (resolve `(commit . ,str))))))) (('tag . tag) - (let ((oid (reference-name->oid repository - (string-append "refs/tags/" tag)))) - ;; OID may point to a "tag" object, but it can also point directly - ;; to a "commit" object, as surprising as it may seem. Return that - ;; object, whatever that is. - (object-lookup repository oid)))))) + (let* ((oid (reference-name->oid repository + (string-append "refs/tags/" tag))) + (obj (object-lookup repository oid))) + ;; OID may designate an "annotated tag" object or a "commit" object. + ;; Return the commit object in both cases. + (if (= OBJ-TAG (object-type obj)) + (object-lookup repository + (tag-target-id (tag-lookup repository oid))) + obj)))))) (define (switch-to-ref repository ref) "Switch to REPOSITORY's branch, commit or tag specified by REF. Return the diff --git a/guix/gnu-maintenance.scm b/guix/gnu-maintenance.scm index f983debcd2..0aa70243b5 100644 --- a/guix/gnu-maintenance.scm +++ b/guix/gnu-maintenance.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2010, 2011, 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2010-2023 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2012, 2013 Nikita Karetnikov <nikita@karetnikov.org> ;;; Copyright © 2021 Simon Tournier <zimon.toutoune@gmail.com> ;;; Copyright © 2022 Maxime Devos <maximedevos@telenet.be> @@ -37,10 +37,13 @@ #:autoload (guix download) (%mirrors) #:use-module (guix ftp-client) #:use-module (guix utils) + #:use-module (guix diagnostics) + #:use-module (guix i18n) #:use-module (guix memoization) #:use-module (guix records) #:use-module (guix upstream) #:use-module (guix packages) + #:autoload (guix import utils) (false-if-networking-error) #:autoload (zlib) (call-with-gzip-input-port) #:autoload (htmlprag) (html->sxml) ;from Guile-Lib #:export (gnu-package-name @@ -64,7 +67,7 @@ release-file? releases - latest-release + import-release gnu-release-archive-types gnu-package-name->name+version @@ -252,7 +255,7 @@ network to check in GNU's database." (make-regexp "^([^.]+)[-_][vV]?([0-9]|[^-])+(-(src|[sS]ource|gnu[0-9]))?\\.(tar\\.|tgz|zip$)")) (define %alpha-tarball-rx - (make-regexp "^.*-.*[0-9](-|~)?(alpha|beta|rc|RC|cvs|svn|git)-?[0-9\\.]*\\.tar\\.")) + (make-regexp "^.*-.*[0-9](-|~|\\.)?(alpha|beta|rc|RC|cvs|svn|git)-?[0-9\\.]*\\.tar\\.")) (define (release-file? project file) "Return #f if FILE is not a release tarball of PROJECT, otherwise return @@ -331,14 +334,17 @@ name/directory pairs." files) result))))))) -(define* (latest-ftp-release project +(define* (import-ftp-release project #:key + (version #f) (server "ftp.gnu.org") (directory (string-append "/gnu/" project)) (file->signature (cut string-append <> ".sig"))) "Return an <upstream-source> for the latest release of PROJECT on SERVER -under DIRECTORY, or #f. Use FTP-OPEN and FTP-CLOSE to open (resp. close) FTP -connections; this can be useful to reuse connections. +under DIRECTORY, or #f. Optionally include a VERSION string to fetch a specific version. + +Use FTP-OPEN and FTP-CLOSE to open (resp. close) FTP connections; this can be +useful to reuse connections. FILE->SIGNATURE must be a procedure; it is passed a source file URL and must return the corresponding signature URL, or #f it signatures are unavailable." @@ -405,8 +411,12 @@ return the corresponding signature URL, or #f it signatures are unavailable." ;; Assume that SUBDIRS correspond to versions, and jump into the ;; one with the highest version number. - (let* ((release (reduce latest-release #f - (coalesce-sources releases))) + (let* ((release (if version + (find (lambda (upstream) + (string=? (upstream-source-version upstream) version)) + (coalesce-sources releases)) + (reduce latest-release #f + (coalesce-sources releases)))) (result (if (and result release) (latest-release release result) (or release result))) @@ -418,13 +428,16 @@ return the corresponding signature URL, or #f it signatures are unavailable." (ftp-close conn) result)))))) -(define* (latest-release package +(define* (import-release package #:key + (version #f) (server "ftp.gnu.org") (directory (string-append "/gnu/" package))) "Return the <upstream-source> for the latest version of PACKAGE or #f. -PACKAGE must be the canonical name of a GNU package." - (latest-ftp-release package +PACKAGE must be the canonical name of a GNU package. Optionally include a +VERSION string to fetch a specific version." + (import-ftp-release package + #:version version #:server server #:directory directory)) @@ -440,14 +453,15 @@ of EXP otherwise." (close-port port)) #f))) -(define (latest-release* package) - "Like 'latest-release', but (1) take a <package> object, and (2) ignore FTP +(define* (import-release* package #:key (version #f)) + "Like 'import-release', but (1) take a <package> object, and (2) ignore FTP errors that might occur when PACKAGE is not actually a GNU package, or not hosted on ftp.gnu.org, or not under that name (this is the case for \"emacs-auctex\", for instance.)" (let-values (((server directory) (ftp-server/directory package))) - (false-if-ftp-error (latest-release (package-upstream-name package) + (false-if-ftp-error (import-release (package-upstream-name package) + #:version version #:server server #:directory directory)))) @@ -472,14 +486,18 @@ hosted on ftp.gnu.org, or not under that name (this is the case for (_ links)))) -(define* (latest-html-release package +(define* (import-html-release package #:key + (version #f) (base-url "https://kernel.org/pub") (directory (string-append "/" package)) file->signature) "Return an <upstream-source> for the latest release of PACKAGE (a string) on -SERVER under DIRECTORY, or #f. BASE-URL should be the URL of an HTML page, -typically a directory listing as found on 'https://kernel.org/pub'. +SERVER under DIRECTORY, or #f. Optionally include a VERSION string to fetch a +specific version. + +BASE-URL should be the URL of an HTML page, typically a directory listing as +found on 'https://kernel.org/pub'. When FILE->SIGNATURE is omitted or #f, guess the detached signature file name, if any. Otherwise, FILE->SIGNATURE must be a procedure; it is passed a source @@ -552,13 +570,18 @@ are unavailable." (match candidates (() #f) ((first . _) - ;; Select the most recent release and return it. - (reduce (lambda (r1 r2) - (if (version>? (upstream-source-version r1) - (upstream-source-version r2)) - r1 r2)) - first - (coalesce-sources candidates)))))) + (if version + ;; find matching release version and return it + (find (lambda (upstream) + (string=? (upstream-source-version upstream) version)) + (coalesce-sources candidates)) + ;; Select the most recent release and return it. + (reduce (lambda (r1 r2) + (if (version>? (upstream-source-version r1) + (upstream-source-version r2)) + r1 r2)) + first + (coalesce-sources candidates))))))) ;;; @@ -590,46 +613,62 @@ are unavailable." (call-with-gzip-input-port port (compose string->lines get-string-all)))))) -(define (latest-gnu-release package) +(define* (import-gnu-release package #:key (version #f)) "Return the latest release of PACKAGE, a GNU package available via -ftp.gnu.org. +ftp.gnu.org. Optionally include a VERSION string to fetch a specific version. This method does not rely on FTP access at all; instead, it browses the file list available from %GNU-FILE-LIST-URI over HTTP(S)." + (define archive-type + (package-archive-type package)) + + (define (better-tarball? tarball1 tarball2) + (string=? (file-extension tarball1) archive-type)) + + (define (find-latest-tarball-version tarballs) + (fold (lambda (file1 file2) + (if (and file2 + (version>? (tarball-sans-extension (basename file2)) + (tarball-sans-extension (basename file1)))) + file2 + file1)) + #f + tarballs)) + (let-values (((server directory) (ftp-server/directory package)) ((name) (package-upstream-name package))) (let* ((files (ftp.gnu.org-files)) + ;; select tarballs for this package (relevant (filter (lambda (file) (and (string-prefix? "/gnu" file) (string-contains file directory) (release-file? name (basename file)))) - files))) - (match (sort relevant (lambda (file1 file2) - (version>? (tarball-sans-extension - (basename file1)) - (tarball-sans-extension - (basename file2))))) - ((and tarballs (reference _ ...)) - (let* ((version (tarball->version reference)) - (tarballs (filter (lambda (file) - (string=? (tarball-sans-extension - (basename file)) - (tarball-sans-extension - (basename reference)))) - tarballs))) - (upstream-source - (package name) - (version version) - (urls (map (lambda (file) - (string-append "mirror://gnu/" - (string-drop file - (string-length "/gnu/")))) - tarballs)) - (signature-urls (map (cut string-append <> ".sig") urls))))) - (() - #f))))) + files)) + ;; find latest version + (version (or version + (and (not (null? relevant)) + (tarball->version + (find-latest-tarball-version relevant))))) + ;; find tarballs matching this version + (tarballs (filter (lambda (file) + (string=? version (tarball->version file))) + relevant))) + (match tarballs + (() #f) + (_ + (upstream-source + (package name) + (version version) + (urls (map (lambda (file) + (string-append "mirror://gnu/" + (string-drop file + (string-length "/gnu/")))) + ;; Sort so that the tarball with the same compression + ;; format as currently used in PACKAGE comes first. + (sort tarballs better-tarball?))) + (signature-urls (map (cut string-append <> ".sig") urls)))))))) (define %package-name-rx ;; Regexp for a package name, e.g., "foo-X.Y". Since TeXmacs uses @@ -679,12 +718,13 @@ GNOME packages; EMMS is included though, because its releases are on gnu.org." (define %savannah-base ;; One of the Savannah mirrors listed at - ;; <http://download0.savannah.gnu.org/mirmon/savannah/> that serves valid + ;; <https://download.savannah.gnu.org/mirmon/savannah/> that serves valid ;; HTML (unlike <https://download.savannah.nongnu.org/releases>.) - "https://nongnu.freemirror.org/nongnu") + "https://de.freedif.org/savannah/") -(define (latest-savannah-release package) - "Return the latest release of PACKAGE." +(define* (import-savannah-release package #:key (version #f)) + "Return the latest release of PACKAGE. Optionally include a VERSION string +to fetch a specific version." (let* ((uri (string->uri (match (origin-uri (package-source package)) ((? string? uri) uri) @@ -693,12 +733,14 @@ GNOME packages; EMMS is included though, because its releases are on gnu.org." (directory (dirname (uri-path uri)))) ;; Note: We use the default 'file->signature', which adds ".sig", ".asc", ;; or whichever detached signature naming scheme PACKAGE uses. - (latest-html-release package + (import-html-release package + #:version version #:base-url %savannah-base #:directory directory))) -(define (latest-sourceforge-release package) - "Return the latest release of PACKAGE." +(define* (latest-sourceforge-release package #:key (version #f)) + "Return the latest release of PACKAGE. Optionally include a VERSION string +to fetch a specific version." (define (uri-append uri extension) ;; Return URI with EXTENSION appended. (build-uri (uri-scheme uri) @@ -712,6 +754,12 @@ GNOME packages; EMMS is included though, because its releases are on gnu.org." ((200 302) #t) (else #f)))) + (when version + (error + (formatted-message + (G_ "Updating to a specific version is not yet implemented for ~a, sorry.") + "sourceforge"))) + (let* ((name (package-upstream-name package)) (base (string-append "https://sourceforge.net/projects/" name "/files")) @@ -750,21 +798,24 @@ GNOME packages; EMMS is included though, because its releases are on gnu.org." (when port (close-port port)))))) -(define (latest-xorg-release package) - "Return the latest release of PACKAGE." +(define* (import-xorg-release package #:key (version #f)) + "Return the latest release of PACKAGE. Optionally include a VERSION string +to fetch a specific version." (let ((uri (string->uri (origin-uri (package-source package))))) (false-if-ftp-error - (latest-ftp-release + (import-ftp-release (package-name package) + #:version version #:server "ftp.freedesktop.org" #:directory (string-append "/pub/xorg/" (dirname (uri-path uri))))))) -(define (latest-kernel.org-release package) - "Return the latest release of PACKAGE, the name of a kernel.org package." +(define* (import-kernel.org-release package #:key (version #f)) + "Return the latest release of PACKAGE, the name of a kernel.org package. +Optionally include a VERSION string to fetch a specific version." (define %kernel.org-base ;; This URL and sub-directories thereof are nginx-generated directory - ;; listings suitable for 'latest-html-release'. + ;; listings suitable for 'import-html-release'. "https://mirrors.edge.kernel.org/pub") (define (file->signature file) @@ -776,7 +827,8 @@ GNOME packages; EMMS is included though, because its releases are on gnu.org." ((uri mirrors ...) uri)))) (package (package-upstream-name package)) (directory (dirname (uri-path uri)))) - (latest-html-release package + (import-html-release package + #:version version #:base-url %kernel.org-base #:directory directory #:file->signature file->signature))) @@ -785,8 +837,7 @@ GNOME packages; EMMS is included though, because its releases are on gnu.org." ;; Return true if the given package may be handled by the generic HTML ;; updater. (let ((hosting-sites '("github.com" "github.io" "gitlab.com" - "notabug.org" "sr.ht" - "gforge.inria.fr" "gitlab.inria.fr" + "notabug.org" "sr.ht" "gitlab.inria.fr" "ftp.gnu.org" "download.savannah.gnu.org" "pypi.org" "crates.io" "rubygems.org" "bioconductor.org"))) @@ -804,9 +855,10 @@ GNOME packages; EMMS is included though, because its releases are on gnu.org." (or (assoc-ref (package-properties package) 'release-monitoring-url) (http-url? package))))) -(define (latest-html-updatable-release package) +(define* (import-html-updatable-release package #:key (version #f)) "Return the latest release of PACKAGE. Do that by crawling the HTML page of -the directory containing its source tarball." +the directory containing its source tarball. Optionally include a VERSION +string to fetch a specific version." (let* ((uri (string->uri (match (origin-uri (package-source package)) ((? string? url) url) @@ -820,28 +872,20 @@ the directory containing its source tarball." "" (dirname (uri-path uri)))) (package (package-upstream-name package))) - (catch #t - (lambda () - (guard (c ((http-get-error? c) #f)) - (latest-html-release package - #:base-url base - #:directory directory))) - (lambda (key . args) - ;; Return false and move on upon connection failures and bogus HTTP - ;; servers. - (unless (memq key '(gnutls-error tls-certificate-error - system-error - bad-header bad-header-component)) - (apply throw key args)) - #f)))) + (false-if-networking-error + (import-html-release package + #:version version + #:base-url base + #:directory directory)))) (define %gnu-updater ;; This is for everything at ftp.gnu.org. (upstream-updater (name 'gnu) (description "Updater for GNU packages") - (pred gnu-hosted?) - (latest latest-gnu-release))) + (pred (lambda (package) + (false-if-networking-error (gnu-hosted? package)))) + (import import-gnu-release))) (define %gnu-ftp-updater ;; This is for GNU packages taken from alternate locations, such as @@ -850,43 +894,44 @@ the directory containing its source tarball." (name 'gnu-ftp) (description "Updater for GNU packages only available via FTP") (pred (lambda (package) - (and (not (gnu-hosted? package)) - (pure-gnu-package? package)))) - (latest latest-release*))) + (false-if-networking-error + (and (not (gnu-hosted? package)) + (pure-gnu-package? package))))) + (import import-release*))) (define %savannah-updater (upstream-updater (name 'savannah) (description "Updater for packages hosted on savannah.gnu.org") (pred (url-prefix-predicate "mirror://savannah/")) - (latest latest-savannah-release))) + (import import-savannah-release))) (define %sourceforge-updater (upstream-updater (name 'sourceforge) (description "Updater for packages hosted on sourceforge.net") (pred (url-prefix-predicate "mirror://sourceforge/")) - (latest latest-sourceforge-release))) + (import latest-sourceforge-release))) (define %xorg-updater (upstream-updater (name 'xorg) (description "Updater for X.org packages") (pred (url-prefix-predicate "mirror://xorg/")) - (latest latest-xorg-release))) + (import import-xorg-release))) (define %kernel.org-updater (upstream-updater (name 'kernel.org) (description "Updater for packages hosted on kernel.org") (pred (url-prefix-predicate "mirror://kernel.org/")) - (latest latest-kernel.org-release))) + (import import-kernel.org-release))) (define %generic-html-updater (upstream-updater (name 'generic-html) (description "Updater that crawls HTML pages.") (pred html-updatable-package?) - (latest latest-html-updatable-release))) + (import import-html-updatable-release))) ;;; gnu-maintenance.scm ends here diff --git a/guix/grafts.scm b/guix/grafts.scm index 0ffda8f9aa..f93da32981 100644 --- a/guix/grafts.scm +++ b/guix/grafts.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2014, 2015, 2016, 2017, 2018, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2014-2022 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -24,6 +24,7 @@ #:use-module (guix derivations) #:use-module ((guix utils) #:select (%current-system)) #:use-module (guix sets) + #:use-module (guix gexp) #:use-module (srfi srfi-1) #:use-module (srfi srfi-9 gnu) #:use-module (srfi srfi-26) @@ -41,10 +42,11 @@ graft-derivation graft-derivation/shallow - %graft? - without-grafting - set-grafting - grafting?)) + %graft-with-utf8-locale?) + #:re-export (%graft? ;for backward compatibility + without-grafting + set-grafting + grafting?)) (define-record-type* <graft> graft make-graft graft? @@ -79,7 +81,13 @@ (($ <graft> (? string? item)) item))) -(define* (graft-derivation/shallow store drv grafts +(define %graft-with-utf8-locale? + ;; Whether to install a UTF-8 locale for grafting. This parameter exists + ;; for the sole purpose of being able to run tests without having to build + ;; 'glibc-utf8-locales'. + (make-parameter #t)) + +(define* (graft-derivation/shallow drv grafts #:key (name (derivation-name drv)) (outputs (derivation-output-names drv)) @@ -88,72 +96,74 @@ "Return a derivation called NAME, which applies GRAFTS to the specified OUTPUTS of DRV. This procedure performs \"shallow\" grafting in that GRAFTS are not recursively applied to dependencies of DRV." - ;; XXX: Someday rewrite using gexps. + (define glibc-locales + (module-ref (resolve-interface '(gnu packages commencement)) + 'glibc-utf8-locales-final)) + (define mapping ;; List of store item pairs. - (map (match-lambda - (($ <graft> source source-output target target-output) - (cons (if (derivation? source) - (derivation->output-path source source-output) - source) - (if (derivation? target) - (derivation->output-path target target-output) - target)))) + (map (lambda (graft) + (gexp + ((ungexp (graft-origin graft) + (graft-origin-output graft)) + . (ungexp (graft-replacement graft) + (graft-replacement-output graft))))) grafts)) - (define output-pairs - (map (lambda (output) - (cons output - (derivation-output-path - (assoc-ref (derivation-outputs drv) output)))) - outputs)) + (define set-utf8-locale + (and (%graft-with-utf8-locale?) + #~(begin + ;; Let Guile interpret file names as UTF-8. + (setenv "GUIX_LOCPATH" + #+(file-append glibc-locales "/lib/locale")) + (setlocale LC_ALL "en_US.utf8")))) + (define build - `(begin - (use-modules (guix build graft) - (guix build utils) - (ice-9 match)) - - (let* ((old-outputs ',output-pairs) - (mapping (append ',mapping - (map (match-lambda - ((name . file) - (cons (assoc-ref old-outputs name) - file))) - %outputs)))) - (graft old-outputs %outputs mapping)))) - - (define add-label - (cut cons "x" <>)) + (with-imported-modules '((guix build graft) + (guix build utils) + (guix build debug-link) + (guix elf)) + #~(begin + (use-modules (guix build graft) + (guix build utils) + (ice-9 match)) + + (define %outputs + (ungexp (outputs->gexp outputs))) + + #+set-utf8-locale + (let* ((old-outputs '(ungexp + (map (lambda (output) + (gexp ((ungexp output) + . (ungexp drv output)))) + outputs))) + (mapping (append '(ungexp mapping) + (map (match-lambda + ((name . file) + (cons (assoc-ref old-outputs name) + file))) + %outputs)))) + (graft old-outputs %outputs mapping))))) + (define properties `((type . graft) (graft (count . ,(length grafts))))) - (match grafts - ((($ <graft> sources source-outputs targets target-outputs) ...) - (let ((sources (zip sources source-outputs)) - (targets (zip targets target-outputs))) - (build-expression->derivation store name build - #:system system - #:guile-for-build guile - #:modules '((guix build graft) - (guix build utils) - (guix build debug-link) - (guix elf)) - #:inputs `(,@(map (lambda (out) - `("x" ,drv ,out)) - outputs) - ,@(append (map add-label sources) - (map add-label targets))) - #:outputs outputs - - ;; Grafts are computationally cheap so no - ;; need to offload or substitute. - #:local-build? #t - #:substitutable? #f - - #:properties properties))))) + (gexp->derivation name build + #:system system + #:guile-for-build guile + + ;; Grafts are computationally cheap so no + ;; need to offload or substitute. + #:local-build? #t + #:substitutable? #f + + #:properties properties)) + +(define graft-derivation/shallow* + (store-lower graft-derivation/shallow)) (define (non-self-references store drv outputs) "Return the list of references of the OUTPUTS of DRV, excluding self @@ -292,10 +302,10 @@ derivations to the corresponding set of grafts." ;; Use APPLICABLE, the subset of GRAFTS that is really ;; applicable to DRV, to avoid creating several identical ;; grafted variants of DRV. - (let* ((new (graft-derivation/shallow store drv applicable - #:outputs outputs - #:guile guile - #:system system)) + (let* ((new (graft-derivation/shallow* store drv applicable + #:outputs outputs + #:guile guile + #:system system)) (grafts (append (map (lambda (output) (graft (origin drv) @@ -334,36 +344,6 @@ DRV, and graft DRV itself to refer to those grafted dependencies." (graft-replacement first) drv))))) - -;; The following might feel more at home in (guix packages) but since (guix -;; gexp), which is a lower level, needs them, we put them here. - -(define %graft? - ;; Whether to honor package grafts by default. - (make-parameter #t)) - -(define (call-without-grafting thunk) - (lambda (store) - (values (parameterize ((%graft? #f)) - (run-with-store store (thunk))) - store))) - -(define-syntax-rule (without-grafting mexp ...) - "Bind monadic expressions MEXP in a dynamic extent where '%graft?' is -false." - (call-without-grafting (lambda () (mbegin %store-monad mexp ...)))) - -(define-inlinable (set-grafting enable?) - ;; This monadic procedure enables grafting when ENABLE? is true, and - ;; disables it otherwise. It returns the previous setting. - (lambda (store) - (values (%graft? enable?) store))) - -(define-inlinable (grafting?) - ;; Return a Boolean indicating whether grafting is enabled. - (lambda (store) - (values (%graft?) store))) - ;; Local Variables: ;; eval: (put 'with-cache 'scheme-indent-function 1) ;; End: diff --git a/guix/import/cpan.scm b/guix/import/cpan.scm index 87abe9c2f1..8972b87080 100644 --- a/guix/import/cpan.scm +++ b/guix/import/cpan.scm @@ -4,6 +4,7 @@ ;;; Copyright © 2016 Alex Sassmannshausen <alex@pompo.co> ;;; Copyright © 2017, 2018 Tobias Geerinckx-Rice <me@tobias.gr> ;;; Copyright © 2020, 2021 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2022 Hartmut Goebel <h.goebel@crazy-compilers.com> ;;; ;;; This file is part of GNU Guix. ;;; @@ -29,6 +30,7 @@ #:use-module (srfi srfi-26) #:use-module (json) #:use-module (gcrypt hash) + #:use-module (guix diagnostics) #:use-module (guix store) #:use-module (guix utils) #:use-module (guix base32) @@ -39,26 +41,7 @@ #:use-module (guix packages) #:use-module (guix upstream) #:use-module (guix derivations) - #:export (cpan-dependency? - cpan-dependency-relationship - cpan-dependency-phase - cpan-dependency-module - cpan-dependency-version - - cpan-release? - cpan-release-license - cpan-release-author - cpan-release-version - cpan-release-module - cpan-release-distribution - cpan-release-download-url - cpan-release-abstract - cpan-release-home-page - cpan-release-dependencies - json->cpan-release - - cpan-fetch - cpan->guix-package + #:export (cpan->guix-package metacpan-url->mirror-url %cpan-updater @@ -324,8 +307,13 @@ in RELEASE, a <cpan-release> record." ")")))) (url-predicate (cut regexp-exec cpan-rx <>)))) -(define (latest-release package) +(define* (latest-release package #:key (version #f)) "Return an <upstream-source> for the latest release of PACKAGE." + (when version + (error + (formatted-message + (G_ "~a updater doesn't support updating to a specific version, sorry.") + "cpan"))) (match (cpan-fetch (package->upstream-name package)) (#f #f) (release @@ -358,4 +346,4 @@ in RELEASE, a <cpan-release> record." (name 'cpan) (description "Updater for CPAN packages") (pred cpan-package?) - (latest latest-release))) + (import latest-release))) diff --git a/guix/import/cran.scm b/guix/import/cran.scm index d7f6945675..c4b36da12b 100644 --- a/guix/import/cran.scm +++ b/guix/import/cran.scm @@ -1,10 +1,11 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2015, 2016, 2017, 2018, 2019, 2020, 2021, 2022 Ricardo Wurmus <rekado@elephly.net> +;;; Copyright © 2015, 2016, 2017, 2018, 2019, 2020, 2021, 2022, 2023 Ricardo Wurmus <rekado@elephly.net> ;;; Copyright © 2015, 2016, 2017, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com> ;;; Copyright © 2020 Martin Becze <mjbecze@riseup.net> ;;; Copyright © 2021 Sarah Morgensen <iskarian@mgsn.dev> ;;; Copyright © 2021 Simon Tournier <zimon.toutoune@gmail.com> +;;; Copyright © 2022 Hartmut Goebel <h.goebel@crazy-compilers.com> ;;; ;;; This file is part of GNU Guix. ;;; @@ -32,6 +33,7 @@ #:use-module (srfi srfi-26) #:use-module (srfi srfi-34) #:use-module (srfi srfi-35) + #:use-module (srfi srfi-71) #:use-module (ice-9 receive) #:use-module (web uri) #:use-module (guix memoization) @@ -82,32 +84,64 @@ (define %input-style (make-parameter 'variable)) ; or 'specification -(define string->license - (match-lambda - ("AGPL-3" 'agpl3+) - ("Artistic-2.0" 'artistic2.0) - ("Apache License 2.0" 'asl2.0) - ("BSD_2_clause" 'bsd-2) - ("BSD_2_clause + file LICENSE" 'bsd-2) - ("BSD_3_clause" 'bsd-3) - ("BSD_3_clause + file LICENSE" 'bsd-3) - ("GPL" '(list gpl2+ gpl3+)) - ("GPL (>= 2)" 'gpl2+) - ("GPL (>= 3)" 'gpl3+) - ("GPL-2" 'gpl2) - ("GPL-3" 'gpl3) - ("LGPL-2" 'lgpl2.0) - ("LGPL-2.1" 'lgpl2.1) - ("LGPL-3" 'lgpl3) - ("LGPL (>= 2)" 'lgpl2.0+) - ("LGPL (>= 2.1)" 'lgpl2.1+) - ("LGPL (>= 3)" 'lgpl3+) - ("MIT" 'expat) - ("MIT + file LICENSE" 'expat) - ((x) (string->license x)) - ((lst ...) `(list ,@(map string->license lst))) - (_ #f))) - +(define (string->licenses license-string license-prefix) + (let ((licenses + (map string-trim-both + (string-tokenize license-string + (char-set-complement (char-set #\|)))))) + (string->license licenses license-prefix))) + +(define (string->license license-string license-prefix) + (let ((prefix license-prefix)) + (match license-string + ("AGPL-3" (prefix 'agpl3)) + ("AGPL (>= 3)" (prefix 'agpl3+)) + ("Artistic-2.0" (prefix 'artistic2.0)) + ((or "Apache License 2.0" + "Apache License (== 2.0)") + (prefix 'asl2.0)) + ("BSD_2_clause" (prefix 'bsd-2)) + ("BSD_2_clause + file LICENSE" (prefix 'bsd-2)) + ("BSD_3_clause" (prefix 'bsd-3)) + ("BSD_3_clause + file LICENSE" (prefix 'bsd-3)) + ("CC0" (prefix 'cc0)) + ("CC BY-SA 4.0" (prefix 'cc-by-sa4.0)) + ("CeCILL" (prefix 'cecill)) + ((or "GPL" + "GNU General Public License") + `(list ,(prefix 'gpl2+) ,(prefix 'gpl3+))) + ((or "GPL (>= 2)" + "GPL (>= 2.0)") + (prefix 'gpl2+)) + ((or "GPL (> 2)" + "GPL (>= 3)" + "GPL (>= 3.0)" + "GNU General Public License (>= 3)") + (prefix 'gpl3+)) + ((or "GPL-2" + "GNU General Public License version 2") + (prefix 'gpl2)) + ((or "GPL-3" + "GNU General Public License version 3") + (prefix 'gpl3)) + ((or "GNU Lesser General Public License" + "LGPL") + (prefix 'lgpl2.0+)) + ("LGPL-2" (prefix 'lgpl2.0)) + ("LGPL-2.1" (prefix 'lgpl2.1)) + ("LGPL-3" (prefix 'lgpl3)) + ((or "LGPL (>= 2)" + "LGPL (>= 2.0)") + (prefix 'lgpl2.0+)) + ("LGPL (>= 2.1)" (prefix 'lgpl2.1+)) + ("LGPL (>= 3)" (prefix 'lgpl3+)) + ("MIT" (prefix 'expat)) + ("MIT + file LICENSE" (prefix 'expat)) + ("file LICENSE" + `(,(prefix 'fsdg-compatible) "file://LICENSE")) + ((x) (string->license x license-prefix)) + ((lst ...) `(list ,@(map (cut string->license <> license-prefix) lst))) + (unknown `(,(prefix 'fsdg-compatible) ,unknown))))) (define (description->alist description) "Convert a DESCRIPTION string into an alist." @@ -156,9 +190,9 @@ package definition." (define %cran-canonical-url "https://cran.r-project.org/package=") (define %bioconductor-url "https://bioconductor.org/packages/") -;; The latest Bioconductor release is 3.15. Bioconductor packages should be +;; The latest Bioconductor release is 3.16. Bioconductor packages should be ;; updated together. -(define %bioconductor-version "3.15") +(define %bioconductor-version "3.16") (define* (bioconductor-packages-list-url #:optional type) (string-append "https://bioconductor.org/packages/" @@ -358,36 +392,61 @@ empty list when the FIELD cannot be found." ;; The field for system dependencies is often abused to specify non-package ;; dependencies (such as c++11). This list is used to ignore them. (define invalid-packages - (list "c++11" + (list "c++" + "c++11" "c++14" - "linux" + "c++17" + "c99" "getopt::long" + "gnu" + "posix.1-2001" + "linux" + "none" + "windows" + "xcode" "xquartz")) -(define cran-guix-name (cut guix-name "r-" <>)) +(define (transform-sysname sysname) + "Return a Guix package name for the common package name SYSNAME." + (match sysname + ("booktabs" "texlive-booktabs") + ("bowtie2" "bowtie") + ("cat" "coreutils") + ("java" "openjdk") + ("exiftool" "perl-image-exiftool") + ("fftw3" "fftw") + ("freetype2" "freetype") + ("gettext" "gnu-gettext") + ("gmake" "gnu-make") + ("libarchive-devel" "libarchive") + ("libarchive_dev" "libarchive") + ("libbz2" "bzip2") + ("libexpat" "expat") + ("liblz4" "lz4") + ("liblzma" "xz") + ("libzstd" "zstd") + ("libxml2-devel" "libxml2") + ("libz" "zlib") + ("mariadb-devel" "mariadb") + ("mysql56_dev" "mariadb") + ("pandoc-citeproc" "pandoc") + ("python3" "python-3") + ("sqlite3" "sqlite") + ("svn" "subversion") + ("tcl/tk" "tcl") + ("udunits-2" "udunits") + ("whoami" "coreutils") + ("x11" "libx11") + (_ sysname))) -(define (tarball-needs-fortran? tarball) - "Check if the TARBALL contains Fortran source files." - (define (check pattern) - (parameterize ((current-error-port (%make-void-port "rw+")) - (current-output-port (%make-void-port "rw+"))) - (zero? (system* "tar" "--wildcards" "--list" pattern "-f" tarball)))) - (or (check "*.f90") - (check "*.f95") - (check "*.f"))) +(define cran-guix-name (cut guix-name "r-" <>)) (define (directory-needs-fortran? dir) "Check if the directory DIR contains Fortran source files." - (match (find-files dir "\\.f(90|95)$") + (match (find-files dir "\\.f(90|95)?$") (() #f) (_ #t))) -(define (needs-fortran? thing tarball?) - "Check if the THING contains Fortran source files." - (if tarball? - (tarball-needs-fortran? thing) - (directory-needs-fortran? thing))) - (define (files-match-pattern? directory regexp . file-patterns) "Return #T if any of the files matching FILE-PATTERNS in the DIRECTORY match the given REGEXP." @@ -403,58 +462,42 @@ the given REGEXP." (else (loop)))))))) (apply find-files directory file-patterns)))) -(define (tarball-files-match-pattern? tarball regexp . file-patterns) - "Return #T if any of the files represented by FILE-PATTERNS in the TARBALL -match the given REGEXP." - (call-with-temporary-directory - (lambda (dir) - (parameterize ((current-error-port (%make-void-port "rw+"))) - (apply system* "tar" - "xf" tarball "-C" dir - `("--wildcards" ,@file-patterns))) - (files-match-pattern? dir regexp)))) - (define (directory-needs-zlib? dir) "Return #T if any of the Makevars files in the src directory DIR contain a zlib linker flag." (files-match-pattern? dir "-lz" "(Makevars.*|configure.*)")) -(define (tarball-needs-zlib? tarball) - "Return #T if any of the Makevars files in the src directory of the TARBALL -contain a zlib linker flag." - (tarball-files-match-pattern? - tarball "-lz" - "*/src/Makevars*" "*/src/configure*" "*/configure*")) - -(define (needs-zlib? thing tarball?) - "Check if the THING contains files indicating a dependency on zlib." - (if tarball? - (tarball-needs-zlib? thing) - (directory-needs-zlib? thing))) - (define (directory-needs-pkg-config? dir) "Return #T if any of the Makevars files in the src directory DIR reference the pkg-config tool." (files-match-pattern? dir "pkg-config" "(Makevars.*|configure.*)")) -(define (tarball-needs-pkg-config? tarball) - "Return #T if any of the Makevars files in the src directory of the TARBALL -reference the pkg-config tool." - (tarball-files-match-pattern? - tarball "pkg-config" - "*/src/Makevars*" "*/src/configure*" "*/configure*")) - -(define (needs-pkg-config? thing tarball?) - "Check if the THING contains files indicating a dependency on pkg-config." +(define (source-dir->dependencies dir) + "Guess dependencies of R package source in DIR and return two values: a list +of package names for INPUTS and another list of names of NATIVE-INPUTS." + (values + (if (directory-needs-zlib? dir) '("zlib") '()) + (append + (if (directory-needs-pkg-config? dir) '("pkg-config") '()) + (if (directory-needs-fortran? dir) '("gfortran") '())))) + +(define (source->dependencies source tarball?) + "SOURCE-DIR->DEPENDENCIES, but for directories and tarballs as indicated +by TARBALL?" (if tarball? - (tarball-needs-pkg-config? thing) - (directory-needs-pkg-config? thing))) + (call-with-temporary-directory + (lambda (dir) + (parameterize ((current-error-port (%make-void-port "rw+"))) + (system* "tar" "xf" source "-C" dir)) + (source-dir->dependencies dir))) + (source-dir->dependencies source))) (define (needs-knitr? meta) (member "knitr" (listify meta "VignetteBuilder"))) -(define (description->package repository meta) +(define* (description->package repository meta #:key (license-prefix identity) + (download-source download)) "Return the `package' s-expression for an R package published on REPOSITORY from the alist META, which was derived from the R package's DESCRIPTION file." (let* ((base-url (case repository @@ -474,7 +517,7 @@ from the alist META, which was derived from the R package's DESCRIPTION file." (name (assoc-ref meta "Package")) (synopsis (assoc-ref meta "Title")) (version (assoc-ref meta "Version")) - (license (string->license (assoc-ref meta "License"))) + (license (string->licenses (assoc-ref meta "License") license-prefix)) ;; Some packages have multiple home pages. Some have none. (home-page (case repository ((git) (assoc-ref meta 'git)) @@ -496,12 +539,15 @@ from the alist META, which was derived from the R package's DESCRIPTION file." (_ #f))))) (git? (if (assoc-ref meta 'git) #true #false)) (hg? (if (assoc-ref meta 'hg) #true #false)) - (source (download source-url #:method (cond - (git? 'git) - (hg? 'hg) - (else #f)))) + (source (download-source source-url #:method (cond + (git? 'git) + (hg? 'hg) + (else #f)))) + (tarball? (not (or git? hg?))) + (source-inputs source-native-inputs + (source->dependencies source tarball?)) (sysdepends (append - (if (needs-zlib? source (not (or git? hg?))) '("zlib") '()) + source-inputs (filter (lambda (name) (not (member name invalid-packages))) (map string-downcase (listify meta "SystemRequirements"))))) @@ -558,20 +604,17 @@ from the alist META, which was derived from the R package's DESCRIPTION file." `((properties ,`(,'quasiquote ((,'upstream-name . ,name))))) '()) (build-system r-build-system) - ,@(maybe-inputs sysdepends) + ,@(maybe-inputs (map transform-sysname sysdepends)) ,@(maybe-inputs (map cran-guix-name propagate) 'propagated-inputs) ,@(maybe-inputs - `(,@(if (needs-fortran? source (not (or git? hg?))) - '("gfortran") '()) - ,@(if (needs-pkg-config? source (not (or git? hg?))) - '("pkg-config") '()) + `(,@source-native-inputs ,@(if (needs-knitr? meta) '("r-knitr") '())) 'native-inputs) (home-page ,(if (string-null? home-page) (string-append base-url name) home-page)) - (synopsis ,synopsis) + (synopsis ,(beautify-synopsis synopsis)) (description ,(beautify-description (or (assoc-ref meta "Description") ""))) (license ,license)))) @@ -590,31 +633,41 @@ from the alist META, which was derived from the R package's DESCRIPTION file." (define cran->guix-package (memoize - (lambda* (package-name #:key (repo 'cran) version) + (lambda* (package-name #:key (repo 'cran) version (license-prefix identity) + (fetch-description fetch-description) + (download-source download) + #:allow-other-keys) "Fetch the metadata for PACKAGE-NAME from REPO and return the `package' s-expression corresponding to that package, or #f on failure." (let ((description (fetch-description repo package-name version))) (if description - (description->package repo description) + (description->package repo description + #:license-prefix license-prefix + #:download-source download-source) (case repo ((git) ;; Retry import from Bioconductor - (cran->guix-package package-name #:repo 'bioconductor)) + (cran->guix-package package-name #:repo 'bioconductor + #:license-prefix license-prefix)) ((hg) ;; Retry import from Bioconductor - (cran->guix-package package-name #:repo 'bioconductor)) + (cran->guix-package package-name #:repo 'bioconductor + #:license-prefix license-prefix)) ((bioconductor) ;; Retry import from CRAN - (cran->guix-package package-name #:repo 'cran)) + (cran->guix-package package-name #:repo 'cran + #:license-prefix license-prefix)) (else (values #f '())))))))) -(define* (cran-recursive-import package-name #:key (repo 'cran) version) +(define* (cran-recursive-import package-name #:key (repo 'cran) version + (license-prefix identity)) (recursive-import package-name #:version version #:repo repo #:repo->guix-package cran->guix-package - #:guix-name cran-guix-name)) + #:guix-name cran-guix-name + #:license-prefix license-prefix)) ;;; @@ -640,8 +693,13 @@ s-expression corresponding to that package, or #f on failure." (_ #f))) (_ #f))))) -(define (latest-cran-release pkg) +(define* (latest-cran-release pkg #:key (version #f)) "Return an <upstream-source> for the latest release of the package PKG." + (when version + (error + (formatted-message + (G_ "~a provides only the latest version of each package, sorry.") + "CRAN"))) (define upstream-name (package->upstream-name pkg)) @@ -660,21 +718,26 @@ s-expression corresponding to that package, or #f on failure." (changed-inputs pkg (description->package 'cran meta))))))) -(define (latest-bioconductor-release pkg) +(define* (latest-bioconductor-release pkg #:key (version #f)) "Return an <upstream-source> for the latest release of the package PKG." + (when version + (error + (formatted-message + (G_ "~a provides only the latest version of each package, sorry.") + "bioconductor.org"))) (define upstream-name (package->upstream-name pkg)) - (define version + (define latest-version (latest-bioconductor-package-version upstream-name)) - (and version + (and latest-version ;; Bioconductor does not provide signatures. (upstream-source (package (package-name pkg)) - (version version) - (urls (bioconductor-uri upstream-name version)) + (version latest-version) + (urls (bioconductor-uri upstream-name latest-version)) (input-changes (changed-inputs pkg @@ -723,13 +786,13 @@ s-expression corresponding to that package, or #f on failure." (name 'cran) (description "Updater for CRAN packages") (pred cran-package?) - (latest latest-cran-release))) + (import latest-cran-release))) (define %bioconductor-updater (upstream-updater (name 'bioconductor) (description "Updater for Bioconductor packages") (pred bioconductor-package?) - (latest latest-bioconductor-release))) + (import latest-bioconductor-release))) ;;; cran.scm ends here diff --git a/guix/import/crate.scm b/guix/import/crate.scm index c76d7e9c1a..c17d96ef41 100644 --- a/guix/import/crate.scm +++ b/guix/import/crate.scm @@ -3,6 +3,7 @@ ;;; Copyright © 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2019, 2020 Martin Becze <mjbecze@riseup.net> ;;; Copyright © 2021 Nicolas Goaziou <mail@nicolasgoaziou.fr> +;;; Copyright © 2022 Hartmut Goebel <h.goebel@crazy-compilers.com> ;;; ;;; This file is part of GNU Guix. ;;; @@ -216,7 +217,8 @@ and LICENSE." 'unknown-license!))) (string-split string (string->char-set " /")))) -(define* (crate->guix-package crate-name #:key version include-dev-deps? repo) +(define* (crate->guix-package crate-name #:key version include-dev-deps? + #:allow-other-keys) "Fetch the metadata for CRATE-NAME from crates.io, and return the `package' s-expression corresponding to that package, or #f on failure. When VERSION is specified, convert it into a semver range and attempt to fetch @@ -354,11 +356,12 @@ look up the development dependencs for the given crate." (define crate-package? (url-predicate crate-url?)) -(define (latest-release package) - "Return an <upstream-source> for the latest release of PACKAGE." +(define* (import-release package #:key (version #f)) + "Return an <upstream-source> for the latest release of PACKAGE. Optionally +include a VERSION string to fetch a specific version." (let* ((crate-name (guix-package->crate-name package)) (crate (lookup-crate crate-name)) - (version (crate-latest-version crate)) + (version (or version (crate-latest-version crate))) (url (crate-uri crate-name version))) (upstream-source (package (package-name package)) @@ -370,5 +373,5 @@ look up the development dependencs for the given crate." (name 'crate) (description "Updater for crates.io packages") (pred crate-package?) - (latest latest-release))) + (import import-release))) diff --git a/guix/import/egg.scm b/guix/import/egg.scm index 52196583c4..90d97909b5 100644 --- a/guix/import/egg.scm +++ b/guix/import/egg.scm @@ -2,6 +2,7 @@ ;;; Copyright © 2021 Xinglu Chen <public@yoctocell.xyz> ;;; Copyright © 2021 Tobias Geerinckx-Rice <me@tobias.gr> ;;; Copyright © 2021 Sarah Morgensen <iskarian@mgsn.dev> +;;; Copyright © 2022 Hartmut Goebel <h.goebel@crazy-compilers.com> ;;; ;;; This file is part of GNU Guix. ;;; @@ -67,7 +68,7 @@ ;;; ;;; * Support for CHICKEN 4? ;;; -;;; * Some packages will specify a specific version of a depencency in the +;;; * Some packages will specify a specific version of a dependency in the ;;; PACKAGE.egg file, how should we handle this? ;;; ;;; Code: @@ -170,7 +171,8 @@ FILE is specified, return the package metadata in FILE." ;;; Egg importer. ;;; -(define* (egg->guix-package name version #:key (file #f) (source #f)) +(define* (egg->guix-package name version #:key (file #f) (source #f) + #:allow-other-keys) "Import a CHICKEN egg called NAME from either the given .egg FILE, or from the latest NAME metadata downloaded from the official repository if FILE is #f. Return a <package> record or #f on failure. If VERSION is specified, import @@ -333,10 +335,11 @@ not work." ;;; Updater. ;;; -(define (latest-release package) - "Return an @code{<upstream-source>} for the latest release of PACKAGE." +(define* (import-release package #:key (version #f)) + "Return an @code{<upstream-source>} for the latest release of PACKAGE. +Optionally include a VERSION string to fetch a specific version." (let* ((egg-name (guix-package->egg-name package)) - (version (find-latest-version egg-name)) + (version (or version (find-latest-version egg-name))) (source-url (egg-uri egg-name version))) (upstream-source (package (package-name package)) @@ -348,6 +351,6 @@ not work." (name 'egg) (description "Updater for CHICKEN egg packages") (pred egg-package?) - (latest latest-release))) + (import import-release))) ;;; egg.scm ends here diff --git a/guix/import/elm.scm b/guix/import/elm.scm index 74902b8617..c8fb15343f 100644 --- a/guix/import/elm.scm +++ b/guix/import/elm.scm @@ -190,7 +190,7 @@ given NAME and VERSION, and a list of Elm packages it depends on." (define elm->guix-package (memoize - (lambda* (package-name #:key repo version) + (lambda* (package-name #:key version #:allow-other-keys) "Fetch the metadata for PACKAGE-NAME, an Elm package registered at package.elm.org, and return two values: the `package' s-expression corresponding to that package (or #f on failure) and a list of Elm diff --git a/guix/import/elpa.scm b/guix/import/elpa.scm index 9399f45ebc..f9e9f2de53 100644 --- a/guix/import/elpa.scm +++ b/guix/import/elpa.scm @@ -7,6 +7,7 @@ ;;; Copyright © 2021 Xinglu Chen <public@yoctocell.xyz> ;;; Copyright © 2021 Sarah Morgensen <iskarian@mgsn.dev> ;;; Copyright © 2021 Simon Tournier <zimon.toutoune@gmail.com> +;;; Copyright © 2022 Hartmut Goebel <h.goebel@crazy-compilers.com> ;;; ;;; This file is part of GNU Guix. ;;; @@ -35,6 +36,7 @@ #:use-module (srfi srfi-26) #:use-module (srfi srfi-34) #:use-module (srfi srfi-35) + #:use-module (guix diagnostics) #:use-module ((guix download) #:select (download-to-store)) #:use-module (guix import utils) #:use-module (guix http-client) @@ -400,11 +402,16 @@ type '<elpa-package>'." (string-drop (package-name package) 6) (package-name package)))) -(define (latest-release package) +(define* (latest-release package #:key (version #f)) "Return an <upstream-release> for the latest release of PACKAGE." (define name (guix-package->elpa-name package)) (define repo (elpa-repository package)) + (when version + (error + (formatted-message + (G_ "~a updater doesn't support updating to a specific version, sorry.") + "elpa"))) (match (elpa-package-info name repo) (#f ;; No info, perhaps because PACKAGE is not truly an ELPA package. @@ -444,7 +451,7 @@ type '<elpa-package>'." (name 'elpa) (description "Updater for ELPA packages") (pred package-from-elpa-repository?) - (latest latest-release))) + (import latest-release))) (define elpa-guix-name (cut guix-name "emacs-" <>)) diff --git a/guix/import/gem.scm b/guix/import/gem.scm index ad1343bff4..c8d6cd4d2d 100644 --- a/guix/import/gem.scm +++ b/guix/import/gem.scm @@ -6,6 +6,7 @@ ;;; Copyright © 2020 Martin Becze <mjbecze@riseup.net> ;;; Copyright © 2021 Sarah Morgensen <iskarian@mgsn.dev> ;;; Copyright © 2022 Taiju HIGASHI <higashi@taiju.info> +;;; Copyright © 2022 Hartmut Goebel <h.goebel@crazy-compilers.com> ;;; ;;; This file is part of GNU Guix. ;;; @@ -123,7 +124,8 @@ VERSION, HASH, HOME-PAGE, DESCRIPTION, DEPENDENCIES, and LICENSES." ((license) (license->symbol license)) (_ `(list ,@(map license->symbol licenses))))))) -(define* (gem->guix-package package-name #:key (repo 'rubygems) version) +(define* (gem->guix-package package-name #:key (repo 'rubygems) version + #:allow-other-keys) "Fetch the metadata for PACKAGE-NAME from rubygems.org, and return the `package' s-expression corresponding to that package, or #f on failure. Optionally include a VERSION string to fetch a specific version gem." @@ -173,11 +175,11 @@ package on RubyGems." (define gem-package? (url-prefix-predicate "https://rubygems.org/downloads/")) -(define (latest-release package) +(define* (import-release package #:key (version #f)) "Return an <upstream-source> for the latest release of PACKAGE." (let* ((gem-name (guix-package->gem-name package)) (gem (rubygems-fetch gem-name)) - (version (gem-version gem)) + (version (or version (gem-version gem))) (url (rubygems-uri gem-name version))) (upstream-source (package (package-name package)) @@ -189,7 +191,7 @@ package on RubyGems." (name 'gem) (description "Updater for RubyGem packages") (pred gem-package?) - (latest latest-release))) + (import import-release))) (define* (gem-recursive-import package-name #:optional version) (recursive-import package-name diff --git a/guix/import/git.scm b/guix/import/git.scm index 4cf404677c..c15943bd7c 100644 --- a/guix/import/git.scm +++ b/guix/import/git.scm @@ -2,6 +2,7 @@ ;;; Copyright © 2021 Xinglu Chen <public@yoctocell.xyz> ;;; Copyright © 2021 Sarah Morgensen <iskarian@mgsn.dev> ;;; Copyright © 2022 Maxime Devos <maximedevos@telenet.be> +;;; Copyright © 2022 Hartmut Goebel <h.goebel@crazy-compilers.com> ;;; ;;; This file is part of GNU Guix. ;;; @@ -146,9 +147,11 @@ version corresponding to the tag, and the cdr is the name of the tag." tags) entry<?)) -(define* (latest-tag url #:key prefix suffix delim pre-releases?) +(define* (latest-tag url + #:key prefix suffix delim pre-releases? (version #f)) "Return the latest version and corresponding tag available from the Git -repository at URL." +repository at URL. Optionally include a VERSION string to fetch a specific +version." (define (pre-release? tag) (any (cut regexp-exec <> tag) %pre-release-rx)) @@ -169,13 +172,22 @@ repository at URL." ((null? versions->tags) (git-no-valid-tags-error)) (else - (match (last versions->tags) - ((version . tag) - (values version tag))))))) - -(define (latest-git-tag-version package) + (let ((versions (if version + (filter (match-lambda + ((candidate-version . tag) + (string=? version candidate-version))) + versions->tags) + versions->tags))) + (if (null? versions) + (values #f #f) + (match (last versions) + ((version . tag) + (values version tag))))))))) + +(define* (latest-git-tag-version package #:key (version #f)) "Given a PACKAGE, return the latest version of it and the corresponding git -tag, or #false and #false if the latest version could not be determined." +tag, or #false and #false if the latest version could not be determined. +Optionally include a VERSION string to fetch a specific version." (guard (c ((or (git-no-tags-error? c) (git-no-valid-tags-error? c)) (warning (or (package-field-location package 'source) (package-location package)) @@ -193,6 +205,7 @@ tag, or #false and #false if the latest version could not be determined." (url (git-reference-url (origin-uri source))) (property (cute assq-ref (package-properties package) <>))) (latest-tag url + #:version version #:prefix (property 'release-tag-prefix) #:suffix (property 'release-tag-suffix) #:delim (property 'release-tag-version-delimiter) @@ -206,12 +219,14 @@ tag, or #false and #false if the latest version could not be determined." (git-reference? (origin-uri origin)))) (_ #f))) -(define (latest-git-release package) - "Return an <upstream-source> for the latest release of PACKAGE." +(define* (import-git-release package #:key (version #f)) + "Return an <upstream-source> for the latest release of PACKAGE. +Optionally include a VERSION string to fetch a specific version." (let* ((name (package-name package)) (old-version (package-version package)) (old-reference (origin-uri (package-source package))) - (new-version new-version-tag (latest-git-tag-version package))) + (new-version new-version-tag + (latest-git-tag-version package #:version version))) (and new-version new-version-tag (upstream-source (package name) @@ -226,4 +241,4 @@ tag, or #false and #false if the latest version could not be determined." (name 'generic-git) (description "Updater for packages hosted on Git repositories") (pred git-package?) - (latest latest-git-release))) + (import import-git-release))) diff --git a/guix/import/github.scm b/guix/import/github.scm index e1a1af7133..a1bda5ec43 100644 --- a/guix/import/github.scm +++ b/guix/import/github.scm @@ -249,11 +249,13 @@ Alternatively, you can wait until your rate limit is reset, or use the #:headers headers))) (x x))))))))) -(define (latest-released-version url package-name) +(define* (latest-released-version url package-name #:key (version #f)) "Return the newest released version and its tag given a string URL like 'https://github.com/arq5x/bedtools2/archive/v2.24.0.tar.gz' and the name of the package e.g. 'bedtools2'. Return #f (two values) if there are no -releases." +releases. + +Optionally include a VERSION string to fetch a specific version." (define (pre-release? x) (assoc-ref x "prerelease")) @@ -290,16 +292,25 @@ releases." (match (and=> (fetch-releases-or-tags url) vector->list) (#f (values #f #f)) (json - (match (sort (filter-map release->version - (match (remove pre-release? json) - (() json) ; keep everything - (releases releases))) - (lambda (x y) (version>? (car x) (car y)))) + (let ((releases (filter-map release->version + (match (remove pre-release? json) + (() json) ; keep everything + (releases releases))))) + (match (if version + ;; Find matching release version. + (filter (match-lambda + ((candidate-version . tag) + (string=? version candidate-version))) + releases) + ;; Sort releases descending. + (sort releases + (lambda (x y) (version>? (car x) (car y))))) (((latest-version . tag) . _) (values latest-version tag)) - (() (values #f #f)))))) + (() (values #f #f))))))) -(define (latest-release pkg) - "Return an <upstream-source> for the latest release of PKG." +(define* (import-release pkg #:key (version #f)) + "Return an <upstream-source> for the latest release of PKG. +Optionally include a VERSION string to fetch a specific version." (define (github-uri uri) (match uri ((? string? url) @@ -313,7 +324,8 @@ releases." (source-uri (github-uri original-uri)) (name (package-name pkg)) (newest-version version-tag - (latest-released-version source-uri name))) + (latest-released-version source-uri name + #:version version))) (if newest-version (upstream-source (package name) @@ -330,6 +342,6 @@ releases." (name 'github) (description "Updater for GitHub packages") (pred github-package?) - (latest latest-release))) + (import import-release))) diff --git a/guix/import/gnome.scm b/guix/import/gnome.scm index 9d8cd8ec76..3c5a96fdde 100644 --- a/guix/import/gnome.scm +++ b/guix/import/gnome.scm @@ -1,6 +1,7 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2017, 2019, 2021 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2022 Maxim Cournoyer <maxim.cournoyer@gmail.com> +;;; Copyright © 2022 Hartmut Goebel <h.goebel@crazy-compilers.com> ;;; ;;; This file is part of GNU Guix. ;;; @@ -57,9 +58,10 @@ source for metadata." name "/" relative-url)))) '("tar.lz" "tar.xz" "tar.bz2" "tar.gz"))))))) -(define (latest-gnome-release package) +(define* (import-gnome-release package #:key (version #f)) "Return the latest release of PACKAGE, a GNOME package, or #f if it could -not be determined." +not be determined. Optionally include a VERSION string to fetch a specific +version." (define %not-dot (char-set-complement (char-set #\.))) @@ -88,6 +90,28 @@ https://discourse.gnome.org/t/new-gnome-versioning-scheme/4235" ;; Some packages like "NetworkManager" have camel-case names. (package-upstream-name package)) + (define (find-latest-release releases) + (fold (match-lambda* + (((key . value) result) + (cond ((release-version? key) + (match result + (#f + (cons key value)) + ((newest . _) + (if (version>? key newest) + (cons key value) + result)))) + (else + result)))) + #f + releases)) + + (define (find-version-release releases version) + (find (match-lambda + ((key . value) + (string=? key version))) + releases)) + (guard (c ((http-get-error? c) (if (= 404 (http-get-error-code c)) #f @@ -108,20 +132,9 @@ https://discourse.gnome.org/t/new-gnome-versioning-scheme/4235" (match json (#(4 releases _ ...) (let* ((releases (assoc-ref releases upstream-name)) - (latest (fold (match-lambda* - (((key . value) result) - (cond ((release-version? key) - (match result - (#f - (cons key value)) - ((newest . _) - (if (version>? key newest) - (cons key value) - result)))) - (else - result)))) - #f - releases))) + (latest (if version + (find-version-release releases version) + (find-latest-release releases)))) (and latest (jsonish->upstream-source upstream-name latest)))))))) @@ -130,4 +143,4 @@ https://discourse.gnome.org/t/new-gnome-versioning-scheme/4235" (name 'gnome) (description "Updater for GNOME packages") (pred (url-prefix-predicate "mirror://gnome/")) - (latest latest-gnome-release))) + (import import-gnome-release))) diff --git a/guix/import/gnu.scm b/guix/import/gnu.scm index 2b9b71feb0..cff088f423 100644 --- a/guix/import/gnu.scm +++ b/guix/import/gnu.scm @@ -109,7 +109,8 @@ download policy (see 'download-tarball' for details.)" #f)))) (define* (gnu->guix-package name - #:key (key-download 'interactive)) + #:key (key-download 'interactive) + #:allow-other-keys) "Return the package declaration for NAME as an s-expression. Use KEY-DOWNLOAD as the OpenPGP key download policy (see 'download-tarball' for details.)" @@ -117,7 +118,7 @@ details.)" (unless package (raise (formatted-message (G_ "no GNU package found for ~a") name))) - (match (latest-release name) + (match (import-release name) ((? upstream-source? release) (let ((version (upstream-source-version release))) (gnu-package->sexp package release #:key-download key-download))) diff --git a/guix/import/go.scm b/guix/import/go.scm index d00c13475a..90d4c8931d 100644 --- a/guix/import/go.scm +++ b/guix/import/go.scm @@ -602,7 +602,8 @@ available versions:~{ ~a~}.") (define* (go-module->guix-package module-path #:key (goproxy "https://proxy.golang.org") version - pin-versions?) + pin-versions? + #:allow-other-keys) "Return the package S-expression corresponding to MODULE-PATH at VERSION, a Go package. The meta-data is fetched from the GOPROXY server and https://pkg.go.dev/. When VERSION is unspecified, the latest version available is used." @@ -687,7 +688,7 @@ This package and its dependencies won't be imported.~%") package-name #:repo->guix-package (memoize - (lambda* (name #:key version repo) + (lambda* (name #:key version repo #:allow-other-keys) (receive (package-sexp dependencies) (go-module->guix-package* name #:goproxy goproxy #:version version diff --git a/guix/import/hackage.scm b/guix/import/hackage.scm index 878a7d2f9c..7bc2908405 100644 --- a/guix/import/hackage.scm +++ b/guix/import/hackage.scm @@ -7,6 +7,7 @@ ;;; Copyright © 2021 Xinglu Chen <public@yoctocell.xyz> ;;; Copyright © 2021 Sarah Morgensen <iskarian@mgsn.dev> ;;; Copyright © 2019 Simon Tournier <zimon.toutoune@gmail.com> +;;; Copyright © 2022 Hartmut Goebel <h.goebel@crazy-compilers.com> ;;; ;;; This file is part of GNU Guix. ;;; @@ -30,10 +31,12 @@ #:use-module (srfi srfi-34) #:use-module (srfi srfi-26) #:use-module (srfi srfi-1) + #:use-module (guix diagnostics) #:use-module ((guix download) #:select (download-to-store url-fetch)) #:use-module ((guix utils) #:select (package-name->name+version canonical-newline-port)) #:use-module (guix http-client) + #:use-module (guix i18n) #:use-module (guix import utils) #:use-module (guix import cabal) #:use-module (guix store) @@ -323,7 +326,8 @@ the hash of the Cabal file." (define* (hackage->guix-package package-name #:key (include-test-dependencies? #t) (port #f) - (cabal-environment '())) + (cabal-environment '()) + #:allow-other-keys) "Fetch the Cabal file for PACKAGE-NAME from hackage.haskell.org, or, if the called with keyword parameter PORT, from PORT. Return the `package' S-expression corresponding to that package, or #f on failure. @@ -350,7 +354,7 @@ respectively." (define* (hackage-recursive-import package-name . args) (recursive-import package-name - #:repo->guix-package (lambda* (name #:key repo version) + #:repo->guix-package (lambda* (name #:key version #:allow-other-keys) (apply hackage->guix-package/m (cons name args))) #:guix-name hackage-name->package-name)) @@ -359,8 +363,13 @@ respectively." (let ((hackage-rx (make-regexp "(https?://hackage.haskell.org|mirror://hackage/)"))) (url-predicate (cut regexp-exec hackage-rx <>)))) -(define (latest-release package) +(define* (latest-release package #:key (version #f)) "Return an <upstream-source> for the latest release of PACKAGE." + (when version + (error + (formatted-message + (G_ "~a updater doesn't support updating to a specific version, sorry.") + "hackage"))) (let* ((hackage-name (guix-package->hackage-name package)) (cabal-meta (hackage-fetch hackage-name))) (match cabal-meta @@ -381,6 +390,6 @@ respectively." (name 'hackage) (description "Updater for Hackage packages") (pred hackage-package?) - (latest latest-release))) + (import latest-release))) ;;; cabal.scm ends here diff --git a/guix/import/hexpm.scm b/guix/import/hexpm.scm index 2a7a9f3d82..dac5d1756f 100644 --- a/guix/import/hexpm.scm +++ b/guix/import/hexpm.scm @@ -234,7 +234,7 @@ build-system, and DEPENDENCIES the inputs for the package." (fold (lambda (a b) (if (version>? a b) a b)) (car versions) versions))))) -(define* (hexpm->guix-package package-name #:key repo version) +(define* (hexpm->guix-package package-name #:key version #:allow-other-keys) "Fetch the metadata for PACKAGE-NAME from hexpms.io, and return the `package' s-expression corresponding to that package, or #f on failure. When VERSION is specified, attempt to fetch that version; otherwise fetch the @@ -328,11 +328,12 @@ latest version of PACKAGE-NAME." ;;; Updater ;;; -(define (latest-release package) - "Return an <upstream-source> for the latest release of PACKAGE." +(define* (import-release package #:key (version #f)) + "Return an <upstream-source> for the latest release of PACKAGE. Optionally +include a VERSION string to fetch a specific version." (let* ((hexpm-name (guix-package->hexpm-name package)) (hexpm (lookup-hexpm hexpm-name)) - (version (hexpm-latest-release hexpm)) + (version (or version (hexpm-latest-release hexpm))) (url (hexpm-uri hexpm-name version))) (upstream-source (package (package-name package)) @@ -344,4 +345,4 @@ latest version of PACKAGE-NAME." (name 'hexpm) (description "Updater for hex.pm packages") (pred (url-prefix-predicate hexpm-package-url)) - (latest latest-release))) + (import import-release))) diff --git a/guix/import/kde.scm b/guix/import/kde.scm index 6873418d62..3566312eca 100644 --- a/guix/import/kde.scm +++ b/guix/import/kde.scm @@ -28,6 +28,7 @@ #:use-module (ice-9 match) #:use-module (ice-9 rdelim) #:use-module (ice-9 regex) + #:use-module (srfi srfi-1) #:use-module (srfi srfi-11) #:use-module (web uri) @@ -149,42 +150,52 @@ Output: (string-join (map version->pattern directory-parts) "/") "/")))) -(define (latest-kde-release package) +(define* (import-kde-release package #:key (version #f)) "Return the latest release of PACKAGE, a KDE package, or #f if it could -not be determined." +not be determined. Optionally include a VERSION string to fetch a specific +version." + + (define (find-latest-archive-version archives) + (fold (lambda (file1 file2) + (if (and file2 + (version>? (tarball-sans-extension (basename file2)) + (tarball-sans-extension (basename file1)))) + file2 + file1)) + #f + archives)) + (let* ((uri (string->uri (origin-uri (package-source package)))) (path-rx (uri->kde-path-pattern uri)) (name (package-upstream-name package)) (files (download.kde.org-files)) + ;; select archives for this package (relevant (filter (lambda (file) (and (regexp-exec path-rx file) (release-file? name (basename file)))) - files))) - (match (sort relevant (lambda (file1 file2) - (version>? (tarball-sans-extension - (basename file1)) - (tarball-sans-extension - (basename file2))))) - ((and tarballs (reference _ ...)) - (let* ((version (tarball->version reference)) - (tarballs (filter (lambda (file) - (string=? (tarball-sans-extension - (basename file)) - (tarball-sans-extension - (basename reference)))) - tarballs))) - (upstream-source - (package name) - (version version) - (urls (map (lambda (file) - (string-append "mirror://kde/" file)) - tarballs))))) - (() - #f)))) + files)) + ;; Find latest version. + (version (or version + (and (not (null? relevant)) + (tarball->version (find-latest-archive-version relevant))))) + ;; Find archives matching this version. + (tarballs (filter (lambda (file) + (string=? version (tarball->version file))) + relevant))) + (match tarballs + (() #f) + (_ + (upstream-source + (package name) + (version version) + (urls (map (lambda (file) + (string-append "mirror://kde/" file)) + tarballs))))))) + (define %kde-updater (upstream-updater (name 'kde) (description "Updater for KDE packages") (pred (url-prefix-predicate "mirror://kde/")) - (latest latest-kde-release))) + (import import-kde-release))) diff --git a/guix/import/launchpad.scm b/guix/import/launchpad.scm index aeb447b0a5..01953ea69c 100644 --- a/guix/import/launchpad.scm +++ b/guix/import/launchpad.scm @@ -2,6 +2,7 @@ ;;; Copyright © 2019, 2020 Arun Isaac <arunisaac@systemreboot.net> ;;; Copyright © 2021 Matthew James Kraai <kraai@ftbfs.org> ;;; Copyright © 2020 Brice Waegeneire <brice@waegenei.re> +;;; Copyright © 2022 Hartmut Goebel <h.goebel@crazy-compilers.com> ;;; ;;; This file is part of GNU Guix. ;;; @@ -121,8 +122,9 @@ for example, 'linuxdcpp'. Return #f if there is no releases." (last (remove pre-release? (vector->list (assoc-ref json "entries")))) "version")))) -(define (latest-release pkg) - "Return an <upstream-source> for the latest release of PKG." +(define* (import-release pkg #:key (version #f)) + "Return an <upstream-source> for the latest release of PKG. Optionally +include a VERSION string to fetch a specific version." (define (origin-launchpad-uri origin) (match (origin-uri origin) ((? string? url) url) ; surely a Launchpad URL @@ -132,7 +134,7 @@ for example, 'linuxdcpp'. Return #f if there is no releases." (let* ((source-uri (origin-launchpad-uri (package-source pkg))) (name (package-name pkg)) (repository (launchpad-repository source-uri)) - (newest-version (latest-released-version repository))) + (newest-version (or version (latest-released-version repository)))) (if newest-version (upstream-source (package name) @@ -145,4 +147,4 @@ for example, 'linuxdcpp'. Return #f if there is no releases." (name 'launchpad) (description "Updater for Launchpad packages") (pred launchpad-package?) - (latest latest-release))) + (import import-release))) diff --git a/guix/import/minetest.scm b/guix/import/minetest.scm index 43cfb533e2..e5775e2fa9 100644 --- a/guix/import/minetest.scm +++ b/guix/import/minetest.scm @@ -1,5 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2021, 2022 Maxime Devos <maximedevos@telenet.be> +;;; Copyright © 2022 Hartmut Goebel <h.goebel@crazy-compilers.com> ;;; ;;; This file is part of GNU Guix. ;;; @@ -25,6 +26,7 @@ #:use-module (srfi srfi-2) #:use-module (srfi srfi-11) #:use-module (srfi srfi-26) + #:use-module (guix diagnostics) #:use-module ((guix packages) #:prefix package:) #:use-module (guix upstream) #:use-module (guix utils) @@ -439,7 +441,8 @@ DEPENDENCIES as a list of AUTHOR/NAME strings." #f))))) dependency-list)) -(define* (%minetest->guix-package author/name #:key (sort %default-sort-key)) +(define* (%minetest->guix-package author/name #:key (sort %default-sort-key) + #:allow-other-keys) "Fetch the metadata for AUTHOR/NAME from https://content.minetest.net, and return the 'package' S-expression corresponding to that package, or raise an exception on failure. On success, also return the upstream dependencies as a @@ -475,7 +478,7 @@ list of AUTHOR/NAME strings." (memoize %minetest->guix-package)) (define* (minetest-recursive-import author/name #:key (sort %default-sort-key)) - (define* (minetest->guix-package* author/name #:key repo version) + (define* (minetest->guix-package* author/name #:key version #:allow-other-keys) (minetest->guix-package author/name #:sort sort)) (recursive-import author/name #:repo->guix-package minetest->guix-package* @@ -486,7 +489,7 @@ list of AUTHOR/NAME strings." (and (string-prefix? "minetest-" (package:package-name pkg)) (assq-ref (package:package-properties pkg) 'upstream-name))) -(define (latest-minetest-release pkg) +(define* (latest-minetest-release pkg #:key (version #f)) "Return an <upstream-source> for the latest release of the package PKG, or #false if the latest release couldn't be determined." (define author/name @@ -494,6 +497,12 @@ or #false if the latest release couldn't be determined." (define contentdb-package (contentdb-fetch author/name)) ; TODO warn if #f? (define release (latest-release author/name)) (define source (package:package-source pkg)) + + (when version + (error + (formatted-message + (G_ "~a updater doesn't support updating to a specific version, sorry.") + "minetest"))) (and contentdb-package release (release-commit release) ; not always set ;; Only continue if both the old and new version number are both @@ -513,4 +522,4 @@ or #false if the latest release couldn't be determined." (name 'minetest) (description "Updater for Minetest packages on ContentDB") (pred minetest-package?) - (latest latest-minetest-release))) + (import latest-minetest-release))) diff --git a/guix/import/opam.scm b/guix/import/opam.scm index b4b5a6eaad..938a88f69d 100644 --- a/guix/import/opam.scm +++ b/guix/import/opam.scm @@ -4,6 +4,7 @@ ;;; Copyright © 2021 Xinglu Chen <public@yoctocell.xyz> ;;; Copyright © 2021 Sarah Morgensen <iskarian@mgsn.dev> ;;; Copyright © 2021, 2022 Alice Brenon <alice.brenon@ens-lyon.fr> +;;; Copyright © 2022 Hartmut Goebel <h.goebel@crazy-compilers.com> ;;; ;;; This file is part of GNU Guix. ;;; @@ -35,6 +36,7 @@ #:use-module ((guix build utils) #:select (dump-port find-files mkdir-p)) #:use-module (guix build-system) #:use-module (guix build-system ocaml) + #:use-module (guix diagnostics) #:use-module (guix http-client) #:use-module (guix ui) #:use-module (guix packages) @@ -338,7 +340,7 @@ path to the repository." (sha256 (base32 ,(guix-hash-url temp))))))) 'no-source-information))) -(define* (opam->guix-package name #:key (repo 'opam) version) +(define* (opam->guix-package name #:key (repo 'opam) version #:allow-other-keys) "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." @@ -380,8 +382,8 @@ or #f on failure." ,(list 'quasiquote `((upstream-name . ,name)))))) (home-page ,(metadata-ref opam-content "homepage")) (synopsis ,(metadata-ref opam-content "synopsis")) - (description ,(beautify-description - (metadata-ref opam-content "description"))) + (description ,(and=> (metadata-ref opam-content "description") + beautify-description)) (license ,(spdx-string->license (metadata-ref opam-content "license")))) (filter @@ -417,8 +419,13 @@ package in OPAM." (member (build-system-name (package-build-system package)) '(dune ocaml)) (not (string-prefix? "ocaml4" (package-name package))))) -(define (latest-release package) +(define* (latest-release package #:key (version #f)) "Return an <upstream-source> for the latest release of PACKAGE." + (when version + (error + (formatted-message + (G_ "~a updater doesn't support updating to a specific version, sorry.") + "opam"))) (and-let* ((opam-name (guix-package->opam-name package)) (opam-file (opam-fetch opam-name)) (version (assoc-ref opam-file "version")) @@ -435,4 +442,4 @@ package in OPAM." (name 'opam) (description "Updater for OPAM packages") (pred opam-package?) - (latest latest-release))) + (import latest-release))) diff --git a/guix/import/print.scm b/guix/import/print.scm index 66016145cb..2f54adbd8c 100644 --- a/guix/import/print.scm +++ b/guix/import/print.scm @@ -200,7 +200,8 @@ when evaluated." (source ,(source->code source version)) ,@(match properties (() '()) - (_ `((properties ,properties)))) + (_ `((properties + ,(list 'quasiquote (object->code properties #t)))))) ,@(if replacement `((replacement ,replacement)) '()) diff --git a/guix/import/pypi.scm b/guix/import/pypi.scm index 4760fc3dae..c9aaacbc3f 100644 --- a/guix/import/pypi.scm +++ b/guix/import/pypi.scm @@ -13,6 +13,7 @@ ;;; Copyright © 2021 Marius Bakke <marius@gnu.org> ;;; Copyright © 2022 Vivien Kraus <vivien@planete-kraus.eu> ;;; Copyright © 2021 Simon Tournier <zimon.toutoune@gmail.com> +;;; Copyright © 2022 Hartmut Goebel <h.goebel@crazy-compilers.com> ;;; ;;; This file is part of GNU Guix. ;;; @@ -491,7 +492,7 @@ VERSION, SOURCE-URL, HOME-PAGE, SYNOPSIS, DESCRIPTION, and LICENSE." (define pypi->guix-package (memoize - (lambda* (package-name #:key repo version) + (lambda* (package-name #:key version #:allow-other-keys) "Fetch the metadata for PACKAGE-NAME from pypi.org, and return the `package' s-expression corresponding to that package, or #f on failure." (let* ((project (pypi-fetch package-name)) @@ -556,15 +557,16 @@ source. To build it from source, refer to the upstream repository at (string-prefix? "https://pypi.org/packages" url) (string-prefix? "https://files.pythonhosted.org/packages" url))))) -(define (latest-release package) - "Return an <upstream-source> for the latest release of PACKAGE." +(define* (import-release package #:key (version #f)) + "Return an <upstream-source> for the latest release of PACKAGE. Optionally +include a VERSION string to fetch a specific version." (let* ((pypi-name (guix-package->pypi-name package)) (pypi-package (pypi-fetch pypi-name))) (and pypi-package (guard (c ((missing-source-error? c) #f)) (let* ((info (pypi-project-info pypi-package)) - (version (project-info-version info)) - (dist (source-release pypi-package)) + (version (or version (project-info-version info))) + (dist (source-release pypi-package version)) (url (distribution-url dist))) (upstream-source (urls (list url)) @@ -574,7 +576,7 @@ source. To build it from source, refer to the upstream repository at #f)) (input-changes (changed-inputs package - (pypi->guix-package pypi-name))) + (pypi->guix-package pypi-name #:version version))) (package (package-name package)) (version version))))))) @@ -583,4 +585,4 @@ source. To build it from source, refer to the upstream repository at (name 'pypi) (description "Updater for PyPI packages") (pred pypi-package?) - (latest latest-release))) + (import import-release))) diff --git a/guix/import/stackage.scm b/guix/import/stackage.scm index 49be982a7f..c0284e48a4 100644 --- a/guix/import/stackage.scm +++ b/guix/import/stackage.scm @@ -3,7 +3,8 @@ ;;; Copyright © 2018 Ricardo Wurmus <rekado@elephly.net> ;;; Copyright © 2020 Martin Becze <mjbecze@riseup.net> ;;; Copyright © 2021 Xinglu Chem <public@yoctocell.xyz> -;;; Copyright © 2021 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2021, 2023, 2023 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2022 Hartmut Goebel <h.goebel@crazy-compilers.com> ;;; ;;; This file is part of GNU Guix. ;;; @@ -108,7 +109,8 @@ (lts-version %default-lts-version) (packages (stackage-lts-packages - (stackage-lts-info-fetch lts-version)))) + (stackage-lts-info-fetch lts-version))) + #:allow-other-keys) "Fetch Cabal file for PACKAGE-NAME from hackage.haskell.org. The retrieved version corresponds to the version of PACKAGE-NAME specified in the LTS-VERSION release at stackage.org. Return the `package' S-expression corresponding to @@ -125,7 +127,7 @@ included in the Stackage LTS release." (define (stackage-recursive-import package-name . args) (recursive-import package-name - #:repo->guix-package (lambda* (name #:key repo version) + #:repo->guix-package (lambda* (name #:key version #:allow-other-keys) (apply stackage->guix-package (cons name args))) #:guix-name hackage-name->package-name)) @@ -139,9 +141,14 @@ included in the Stackage LTS release." (mlambda () (stackage-lts-packages (stackage-lts-info-fetch %default-lts-version))))) - (lambda* (pkg) + (lambda* (pkg #:key (version #f)) "Return an <upstream-source> for the latest Stackage LTS release of PACKAGE or #f if the package is not included in the Stackage LTS release." + (when version + (error + (formatted-message + (G_ "~a updater doesn't support updating to a specific version, sorry.") + "stackage"))) (let* ((hackage-name (guix-package->hackage-name pkg)) (version (lts-package-version (packages) hackage-name)) (name-version (hackage-name-version hackage-name version))) @@ -163,18 +170,19 @@ PACKAGE or #f if the package is not included in the Stackage LTS release." (define (stackage-lts-package? package) "Return whether PACKAGE is available on the default Stackage LTS release." (and (hackage-package? package) - (let ((packages (stackage-lts-packages - (stackage-lts-info-fetch %default-lts-version))) - (hackage-name (guix-package->hackage-name package))) - (find (lambda (package) - (string=? (stackage-package-name package) hackage-name)) - packages)))) + (false-if-networking-error + (let ((packages (stackage-lts-packages + (stackage-lts-info-fetch %default-lts-version))) + (hackage-name (guix-package->hackage-name package))) + (find (lambda (package) + (string=? (stackage-package-name package) hackage-name)) + packages))))) (define %stackage-updater (upstream-updater (name 'stackage) (description "Updater for Stackage LTS packages") (pred stackage-lts-package?) - (latest latest-lts-release))) + (import latest-lts-release))) ;;; stackage.scm ends here diff --git a/guix/import/test.scm b/guix/import/test.scm new file mode 100644 index 0000000000..767dcd5b61 --- /dev/null +++ b/guix/import/test.scm @@ -0,0 +1,88 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2023 Ludovic Courtès <ludo@gnu.org> +;;; +;;; 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 <http://www.gnu.org/licenses/>. + +(define-module (guix import test) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-26) + #:use-module (web uri) + #:use-module (guix packages) + #:use-module (guix upstream) + #:use-module ((guix utils) #:select (version-prefix?)) + #:use-module (ice-9 vlist) + #:use-module (ice-9 match) + #:export (%test-updater)) + +;;; Commentary: +;;; +;;; This module defines a pseudo updater whose sole purpose is to allow +;;; testing of the whole 'guix refresh' command. +;;; +;;; Code: + +(define test-target-version + ;; VHash that maps package names to version/URL tuples. + (make-parameter + (or (and=> (getenv "GUIX_TEST_UPDATER_TARGETS") + (lambda (str) + (alist->vhash (call-with-input-string str read)))) + vlist-null))) + +(define (available-updates package) + "Return the list of available <upstream-source> records for PACKAGE." + (vhash-fold* (lambda (version+updates result) + (match version+updates + ((version (updates ...)) + (if (version-prefix? version + (package-version package)) + (append (map (match-lambda + ((version url) + (upstream-source + (package (package-name package)) + (version version) + (urls (list url))))) + updates) + result) + result)))) + '() + (package-name package) + (test-target-version))) + +(define (test-package? package) + "Return true if PACKAGE has pseudo updates available." + (and (not (vlist-null? (test-target-version))) ;cheap test + (pair? (available-updates package)))) + +(define* (import-release package #:key (version #f)) + "Return the <upstream-source> record denoting either the latest version of +PACKAGE or VERSION." + (match (available-updates package) + (() #f) + ((sources ...) + (if version + (find (lambda (source) + (string=? (upstream-source-version source) + version)) + sources) + (first sources))))) + +(define %test-updater + (upstream-updater + (name 'test) + (description "Pseudo updater for testing purposes.") + (pred test-package?) + (import import-release))) diff --git a/guix/import/texlive.scm b/guix/import/texlive.scm index 116bd1f66a..6bf7f92e60 100644 --- a/guix/import/texlive.scm +++ b/guix/import/texlive.scm @@ -303,9 +303,9 @@ of those files are returned that are unexpectedly installed." (define texlive->guix-package (memoize (lambda* (name #:key - repo (version (number->string %texlive-revision)) - (package-database tlpdb)) + (package-database tlpdb) + #:allow-other-keys) "Find the metadata for NAME in the tlpdb and return the `package' s-expression corresponding to that package, or #f on failure." (tlpdb->package name version (package-database))))) diff --git a/guix/import/utils.scm b/guix/import/utils.scm index 7e7d116d1d..72795d2c61 100644 --- a/guix/import/utils.scm +++ b/guix/import/utils.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2012, 2013, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2012, 2013, 2018, 2019, 2020, 2023 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2016 Jelle Licht <jlicht@fsfe.org> ;;; Copyright © 2016 David Craven <david@craven.ch> ;;; Copyright © 2017, 2019, 2020, 2022 Ricardo Wurmus <rekado@elephly.net> @@ -12,6 +12,7 @@ ;;; Copyright © 2021 Xinglu Chen <public@yoctocell.xyz> ;;; Copyright © 2022 Alice Brenon <alice.brenon@ens-lyon.fr> ;;; Copyright © 2022 Kyle Meyer <kyle@kyleam.com> +;;; Copyright © 2022 Philip McGrath <philip@philipmcgrath.com> ;;; ;;; This file is part of GNU Guix. ;;; @@ -53,10 +54,12 @@ #:use-module (srfi srfi-9) #:use-module (srfi srfi-11) #:use-module (srfi srfi-26) + #:use-module (srfi srfi-34) #:use-module (srfi srfi-71) #:export (factorize-uri flatten + false-if-networking-error url-fetch guix-hash-url @@ -72,6 +75,7 @@ snake-case beautify-description + beautify-synopsis alist->package @@ -120,6 +124,26 @@ of the string VERSION is replaced by the symbol 'version." (cons elem memo))) '() lst)) +(define (call-with-networking-exception-handler thunk) + "Invoke THUNK, returning #f if one of the usual networking exception is +thrown." + (catch #t + (lambda () + (guard (c ((http-get-error? c) #f)) + (thunk))) + (lambda (key . args) + ;; Return false and move on upon connection failures and bogus HTTP + ;; servers. + (unless (memq key '(gnutls-error tls-certificate-error + system-error getaddrinfo-error + bad-header bad-header-component)) + (apply throw key args)) + #f))) + +(define-syntax-rule (false-if-networking-error exp) + "Evaluate EXP, returning #f if a networking-related exception is thrown." + (call-with-networking-exception-handler (lambda () exp))) + (define (url-fetch url file-name) "Save the contents of URL to FILE-NAME. Return #f on failure." (parameterize ((current-output-port (current-error-port))) @@ -129,135 +153,152 @@ of the string VERSION is replaced by the symbol 'version." "Return the hash of FILENAME in nix-base32 format." (bytevector->nix-base32-string (file-sha256 filename))) -(define (spdx-string->license str) - "Convert STR, a SPDX formatted license identifier, to a license object. - Return #f if STR does not match any known identifiers." +(define %spdx-license-identifiers ;; https://spdx.org/licenses/ ;; The gfl1.0, nmap, repoze ;; licenses doesn't have SPDX identifiers ;; ;; Please update guix/licenses.scm when modifying ;; this list to avoid mismatches. - (match str - ;; "GPL-N+" has been deprecated in favour of "GPL-N-or-later". - ;; "GPL-N" has been deprecated in favour of "GPL-N-only" - ;; or "GPL-N-or-later" as appropriate. Likewise for LGPL - ;; and AGPL - ("AGPL-1.0" 'license:agpl1) - ("AGPL-1.0-only" 'license:agpl1) - ("AGPL-3.0" 'license:agpl3) - ("AGPL-3.0-only" 'license:agpl3) - ("AGPL-3.0-or-later" 'license:agpl3+) - ("Apache-1.1" 'license:asl1.1) - ("Apache-2.0" 'license:asl2.0) - ("APSL-2.0" 'license:apsl2) - ("BSL-1.0" 'license:boost1.0) - ("0BSD" 'license:bsd-0) - ("BSD-2-Clause" 'license:bsd-2) - ("BSD-2-Clause-FreeBSD" 'license:bsd-2) ;flagged as deprecated on spdx - ("BSD-3-Clause" 'license:bsd-3) - ("BSD-4-Clause" 'license:bsd-4) - ("CC0-1.0" 'license:cc0) - ("CC-BY-2.0" 'license:cc-by2.0) - ("CC-BY-3.0" 'license:cc-by3.0) - ("CC-BY-4.0" 'license:cc-by4.0) - ("CC-BY-SA-2.0" 'license:cc-by-sa2.0) - ("CC-BY-SA-3.0" 'license:cc-by-sa3.0) - ("CC-BY-SA-4.0" 'license:cc-by-sa4.0) - ("CDDL-1.0" 'license:cddl1.0) - ("CDDL-1.1" 'license:cddl1.1) - ("CECILL-2.1" 'license:cecill) - ("CECILL-B" 'license:cecill-b) - ("CECILL-C" 'license:cecill-c) - ("Artistic-2.0" 'license:artistic2.0) - ("ClArtistic" 'license:clarified-artistic) - ("copyleft-next-0.3.0" 'license:copyleft-next) - ("CPL-1.0" 'license:cpl1.0) - ("EPL-1.0" 'license:epl1.0) - ("EPL-2.0" 'license:epl2.0) - ("EUPL-1.2" 'license:eupl1.2) - ("MIT" 'license:expat) - ("MIT-0" 'license:expat-0) - ("FTL" 'license:freetype) - ("FreeBSD-DOC" 'license:freebsd-doc) - ("Freetype" 'license:freetype) - ("FSFAP" 'license:fsf-free) - ("FSFUL" 'license:fsf-free) - ("GFDL-1.1" 'license:fdl1.1+) - ("GFDL-1.1-or-later" 'license:fdl1.1+) - ("GFDL-1.2" 'license:fdl1.2+) - ("GFDL-1.2-or-later" 'license:fdl1.2+) - ("GFDL-1.3" 'license:fdl1.3+) - ("GFDL-1.3-or-later" 'license:fdl1.3+) - ("Giftware" 'license:giftware) - ("GPL-1.0" 'license:gpl1) - ("GPL-1.0-only" 'license:gpl1) - ("GPL-1.0+" 'license:gpl1+) - ("GPL-1.0-or-later" 'license:gpl1+) - ("GPL-2.0" 'license:gpl2) - ("GPL-2.0-only" 'license:gpl2) - ("GPL-2.0+" 'license:gpl2+) - ("GPL-2.0-or-later" 'license:gpl2+) - ("GPL-3.0" 'license:gpl3) - ("GPL-3.0-only" 'license:gpl3) - ("GPL-3.0+" 'license:gpl3+) - ("GPL-3.0-or-later" 'license:gpl3+) - ("HPND" 'license:hpnd) - ("ISC" 'license:isc) - ("IJG" 'license:ijg) - ("Imlib2" 'license:imlib2) - ("IPA" 'license:ipa) - ("IPL-1.0" 'license:ibmpl1.0) - ("LAL-1.3" 'license:lal1.3) - ("LGPL-2.0" 'license:lgpl2.0) - ("LGPL-2.0-only" 'license:lgpl2.0) - ("LGPL-2.0+" 'license:lgpl2.0+) - ("LGPL-2.0-or-later" 'license:lgpl2.0+) - ("LGPL-2.1" 'license:lgpl2.1) - ("LGPL-2.1-only" 'license:lgpl2.1) - ("LGPL-2.1+" 'license:lgpl2.1+) - ("LGPL-2.1-or-later" 'license:lgpl2.1+) - ("LGPL-3.0" 'license:lgpl3) - ("LGPL-3.0-only" 'license:lgpl3) - ("LGPL-3.0+" 'license:lgpl3+) - ("LGPL-3.0-or-later" 'license:lgpl3+) - ("LPPL-1.0" 'license:lppl) - ("LPPL-1.1" 'license:lppl) - ("LPPL-1.2" 'license:lppl1.2) - ("LPPL-1.3a" 'license:lppl1.3a) - ("LPPL-1.3c" 'license:lppl1.3c) - ("MirOS" 'license:miros) - ("MPL-1.0" 'license:mpl1.0) - ("MPL-1.1" 'license:mpl1.1) - ("MPL-2.0" 'license:mpl2.0) - ("MS-PL" 'license:ms-pl) - ("NCSA" 'license:ncsa) - ("OGL-UK-1.0" 'license:ogl-psi1.0) - ("OpenSSL" 'license:openssl) - ("OLDAP-2.8" 'license:openldap2.8) - ("OPL-1.0" 'license:opl1.0+) - ("CUA-OPL-1.0" 'license:cua-opl1.0) - ("PSF-2.0" 'license:psfl) - ("OSL-2.1" 'license:osl2.1) - ("QPL-1.0" 'license:qpl) - ("Ruby" 'license:ruby) - ("SGI-B-2.0" 'license:sgifreeb2.0) - ("OFL-1.1" 'license:silofl1.1) - ("Sleepycat" 'license:sleepycat) - ("TCL" 'license:tcl/tk) - ("Unlicense" 'license:unlicense) - ("Vim" 'license:vim) - ("W3C" 'license:w3c) - ("WTFPL" 'license:wtfpl2) - ("wxWindow" 'license:wxwindows3.1+) ;flagged as deprecated on spdx - ("X11" 'license:x11) - ("ZPL-2.1" 'license:zpl2.1) - ("Zlib" 'license:zlib) - (_ #f))) + ;; + ;; "GPL-N+" has been deprecated in favour of "GPL-N-or-later". "GPL-N" has + ;; been deprecated in favour of "GPL-N-only" or "GPL-N-or-later" as + ;; appropriate. Likewise for LGPL and AGPL. However, we list the + ;; deprecated forms here (with and without the "+" operator) to get better + ;; results from old license expressions. + '(("AGPL-1.0" . license:agpl1) + ("AGPL-1.0-only" . license:agpl1) + ("AGPL-3.0" . license:agpl3) + ("AGPL-3.0-only" . license:agpl3) + ("AGPL-3.0-or-later" . license:agpl3+) + ("Apache-1.1" . license:asl1.1) + ("Apache-2.0" . license:asl2.0) + ("APSL-2.0" . license:apsl2) + ("BSL-1.0" . license:boost1.0) + ("0BSD" . license:bsd-0) + ("BSD-2-Clause" . license:bsd-2) + ("BSD-2-Clause-FreeBSD" . license:bsd-2) ;flagged as deprecated on spdx + ("BSD-3-Clause" . license:bsd-3) + ("BSD-4-Clause" . license:bsd-4) + ("CC0-1.0" . license:cc0) + ("CC-BY-2.0" . license:cc-by2.0) + ("CC-BY-3.0" . license:cc-by3.0) + ("CC-BY-4.0" . license:cc-by4.0) + ("CC-BY-SA-2.0" . license:cc-by-sa2.0) + ("CC-BY-SA-3.0" . license:cc-by-sa3.0) + ("CC-BY-SA-4.0" . license:cc-by-sa4.0) + ("CDDL-1.0" . license:cddl1.0) + ("CDDL-1.1" . license:cddl1.1) + ("CECILL-2.1" . license:cecill) + ("CECILL-B" . license:cecill-b) + ("CECILL-C" . license:cecill-c) + ("Artistic-2.0" . license:artistic2.0) + ("ClArtistic" . license:clarified-artistic) + ("copyleft-next-0.3.0" . license:copyleft-next) + ("CPL-1.0" . license:cpl1.0) + ("EPL-1.0" . license:epl1.0) + ("EPL-2.0" . license:epl2.0) + ("EUPL-1.2" . license:eupl1.2) + ("MIT" . license:expat) + ("MIT-0" . license:expat-0) + ("FTL" . license:freetype) + ("FreeBSD-DOC" . license:freebsd-doc) + ("Freetype" . license:freetype) + ("FSFAP" . license:fsf-free) + ("FSFUL" . license:fsf-free) + ("GFDL-1.1" . license:fdl1.1+) + ("GFDL-1.1-or-later" . license:fdl1.1+) + ("GFDL-1.2" . license:fdl1.2+) + ("GFDL-1.2-or-later" . license:fdl1.2+) + ("GFDL-1.3" . license:fdl1.3+) + ("GFDL-1.3-or-later" . license:fdl1.3+) + ("Giftware" . license:giftware) + ("GPL-1.0" . license:gpl1) + ("GPL-1.0-only" . license:gpl1) + ("GPL-1.0+" . license:gpl1+) + ("GPL-1.0-or-later" . license:gpl1+) + ("GPL-2.0" . license:gpl2) + ("GPL-2.0-only" . license:gpl2) + ("GPL-2.0+" . license:gpl2+) + ("GPL-2.0-or-later" . license:gpl2+) + ("GPL-3.0" . license:gpl3) + ("GPL-3.0-only" . license:gpl3) + ("GPL-3.0+" . license:gpl3+) + ("GPL-3.0-or-later" . license:gpl3+) + ("HPND" . license:hpnd) + ("ISC" . license:isc) + ("IJG" . license:ijg) + ("Imlib2" . license:imlib2) + ("IPA" . license:ipa) + ("IPL-1.0" . license:ibmpl1.0) + ("LAL-1.3" . license:lal1.3) + ("LGPL-2.0" . license:lgpl2.0) + ("LGPL-2.0-only" . license:lgpl2.0) + ("LGPL-2.0+" . license:lgpl2.0+) + ("LGPL-2.0-or-later" . license:lgpl2.0+) + ("LGPL-2.1" . license:lgpl2.1) + ("LGPL-2.1-only" . license:lgpl2.1) + ("LGPL-2.1+" . license:lgpl2.1+) + ("LGPL-2.1-or-later" . license:lgpl2.1+) + ("LGPL-3.0" . license:lgpl3) + ("LGPL-3.0-only" . license:lgpl3) + ("LGPL-3.0+" . license:lgpl3+) + ("LGPL-3.0-or-later" . license:lgpl3+) + ("LPPL-1.0" . license:lppl) + ("LPPL-1.1" . license:lppl) + ("LPPL-1.2" . license:lppl1.2) + ("LPPL-1.3a" . license:lppl1.3a) + ("LPPL-1.3c" . license:lppl1.3c) + ("MirOS" . license:miros) + ("MPL-1.0" . license:mpl1.0) + ("MPL-1.1" . license:mpl1.1) + ("MPL-2.0" . license:mpl2.0) + ("MS-PL" . license:ms-pl) + ("NCSA" . license:ncsa) + ("OGL-UK-1.0" . license:ogl-psi1.0) + ("OpenSSL" . license:openssl) + ("OLDAP-2.8" . license:openldap2.8) + ("OPL-1.0" . license:opl1.0+) + ("CUA-OPL-1.0" . license:cua-opl1.0) + ("PSF-2.0" . license:psfl) + ("OSL-2.1" . license:osl2.1) + ("QPL-1.0" . license:qpl) + ("Ruby" . license:ruby) + ("SGI-B-2.0" . license:sgifreeb2.0) + ("OFL-1.1" . license:silofl1.1) + ("Sleepycat" . license:sleepycat) + ("TCL" . license:tcl/tk) + ("Unlicense" . license:unlicense) + ("Vim" . license:vim) + ("W3C" . license:w3c) + ("WTFPL" . license:wtfpl2) + ("wxWindow" . license:wxwindows3.1+) ;flagged as deprecated on spdx + ("X11" . license:x11) + ("ZPL-2.1" . license:zpl2.1) + ("Zlib" . license:zlib))) + +(define (spdx-string->license str) + "Convert STR, an SPDX license identifier (possibly with a postfix + +operator), to a symbol like 'license:gpl3+ giving the prefixed name of a +license object exported from (guix licenses). Return #f if STR does not match +any known SPDX license identifiers. Per the SPDX specification, license +identifiers are compared case-insensitively." + ;; https://spdx.github.io/spdx-spec/v2.3/SPDX-license-expressions/#d2-case-sensitivity + ;; Operators AND, OR, and WITH are case-sensitive, but identifiers are + ;; case-insensitive for matching, though the canonical case is used in URIs. + (match (assoc str %spdx-license-identifiers string-ci=?) + ((_ . license) + license) + (#f + (and (string-suffix? "+" str) + ;; We try the form with the + to support deprecated identifiers for + ;; GNU licenses (see above). Here, we handle other uses of +. + (spdx-string->license (string-drop-right str 1)))))) (define (license->symbol license) - "Convert license to a symbol representing the variable the object is bound -to in the (guix licenses) module, or #f if there is no such known license." + "Convert LICENSE object to a prefixed symbol representing the variable the +object is bound to in the (guix licenses) module, such as 'license:gpl3+, or +#f if there is no such known license." (define licenses (module-map (lambda (sym var) `(,(variable-ref var) . ,sym)) (resolve-interface '(guix licenses) #:prefix 'license:))) @@ -272,30 +313,70 @@ with dashes." "Improve the package DESCRIPTION by turning a beginning sentence fragment into a proper sentence and by using two spaces between sentences, and wrap lines at LENGTH characters." - (let ((cleaned (cond - ((not (string? description)) - (G_ "This package lacks a description. Run \ + (unless (string? description) + (G_ "This package lacks a description. Run \ \"info '(guix) Synopses and Descriptions'\" for more information.")) - ((string-prefix? "A " description) - (string-append "This package provides a" - (substring description 1))) - ((string-prefix? "Provides " description) - (string-append "This package provides" - (substring description - (string-length "Provides")))) - ((string-prefix? "Implements " description) - (string-append "This package implements" - (substring description - (string-length "Implements")))) - ((string-prefix? "Functions " description) - (string-append "This package provides functions" - (substring description - (string-length "Functions")))) - (else description)))) + + (let* ((fix-word + (lambda (word) + (fold (lambda (proc acc) (proc acc)) word + (list + ;; Remove wrapping in single quotes, common in R packages. + (cut string-trim-both <> #\') + ;; Escape single @ to prevent it from being understood as + ;; invalid Texinfo syntax. + (cut regexp-substitute/global #f "@" <> 'pre "@@" 'post))))) + (words + (string-tokenize (string-trim-both description) + (char-set-complement + (char-set #\space #\newline)))) + (new-words + (match words + (((and (or "A" "Functions" "Methods") first) . rest) + (cons* "This" "package" "provides" + (string-downcase first) rest)) + (((and (or "Contains" + "Creates" + "Performs" + "Provides" + "Produces" + "Implements" + "Infers") first) . rest) + (cons* "This" "package" + (string-downcase first) rest)) + (_ words))) + (cleaned + (string-join (map fix-word new-words)))) ;; Use double spacing between sentences (fill-paragraph (regexp-substitute/global #f "\\. \\b" - cleaned 'pre ". " 'post) - length))) + cleaned 'pre + (lambda (m) + (let ((pre (match:prefix m)) + (abbrevs '("Dr" "Mr" "Mrs" + "Ms" "Prof" "vs" + "e.g"))) + (if (or (any (cut string-suffix? <> pre) abbrevs) + (char-upper-case? + (string-ref pre (1- (string-length pre))))) + ". " + ". "))) + 'post) + length))) + +(define (beautify-synopsis synopsis) + "Improve the package SYNOPSIS." + (let ((cleaned (cond + ((not (string? synopsis)) + (G_ "This package lacks a synopsis. Run \ +\"info '(guix) Synopses and Descriptions'\" for more information.")) + ((string-prefix? "A " synopsis) + (substring synopsis 1)) + ;; Remove trailing period. + ((string-suffix? "." synopsis) + (substring synopsis 0 + (1- (string-length synopsis)))) + (else synopsis)))) + (string-trim-both cleaned))) (define* (package-names->package-inputs names #:optional (output #f)) "Given a list of PACKAGE-NAMES or (PACKAGE-NAME VERSION) pairs, and an @@ -428,10 +509,20 @@ specifications to look up and replace them with plain symbols instead." ((key . value) (list (symbol->keyword (string->symbol key)) value))) arguments)) + (define (process-properties properties) + (map (match-lambda + ((key . value) + (cons (string->symbol key) value))) + properties)) + (package (name (assoc-ref meta "name")) (version (assoc-ref meta "version")) (source (source-spec->object (assoc-ref meta "source"))) + (properties + (or (and=> (assoc-ref meta "properties") + process-properties) + '())) (build-system (lookup-build-system-by-name (string->symbol (assoc-ref meta "build-system")))) @@ -511,11 +602,11 @@ obtain a node's uniquely identifying \"key\"." (set-insert (node-name head) visited)))))))) (define* (recursive-import package-name - #:key repo->guix-package guix-name version repo - #:allow-other-keys) + #:key repo->guix-package guix-name version + #:allow-other-keys #:rest rest) "Return a list of package expressions for PACKAGE-NAME and all its dependencies, sorted in topological order. For each package, -call (REPO->GUIX-PACKAGE NAME :KEYS version repo), which should return a +call (REPO->GUIX-PACKAGE NAME :KEYS version), which should return a package expression and a list of dependencies; call (GUIX-NAME PACKAGE-NAME) to obtain the Guix package name corresponding to the upstream name." (define-record-type <node> @@ -530,9 +621,12 @@ to obtain the Guix package name corresponding to the upstream name." (not (null? (find-packages-by-name (guix-name name) version)))) (define (lookup-node name version) - (let* ((package dependencies (repo->guix-package name - #:version version - #:repo repo)) + (let* ((pre post (break (cut eq? #:version <>) rest)) + (post* (match post + ((#:version v . more) more) + (_ post))) + (args (append pre (list #:version version) post*)) + (package dependencies (apply repo->guix-package (cons* name args))) (normalized-deps (map (match-lambda ((name version) (list name version)) (name (list name #f))) dependencies))) diff --git a/guix/inferior.scm b/guix/inferior.scm index 20a86bbfda..5dfd30a6c8 100644 --- a/guix/inferior.scm +++ b/guix/inferior.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2018-2022 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2018-2023 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -40,7 +40,7 @@ #:use-module (guix search-paths) #:use-module (guix profiles) #:use-module (guix channels) - #:use-module ((guix git) #:select (update-cached-checkout)) + #:use-module ((guix git) #:select (update-cached-checkout commit-id?)) #:use-module (guix monads) #:use-module (guix store) #:use-module (guix derivations) @@ -69,6 +69,8 @@ inferior-exception-arguments inferior-exception-inferior inferior-exception-stack + inferior-protocol-error? + inferior-protocol-error-inferior read-repl-response inferior-packages @@ -147,33 +149,47 @@ custom binary port)." ;; the REPL process wouldn't get EOF on standard input. (match (socketpair AF_UNIX (logior SOCK_STREAM SOCK_CLOEXEC) 0) ((parent . child) - (match (primitive-fork) - (0 - (dynamic-wind - (lambda () - #t) - (lambda () - (close-port parent) - (close-fdes 0) - (close-fdes 1) - (close-fdes 2) - (dup2 (fileno child) 0) - (dup2 (fileno child) 1) - ;; Mimic 'open-pipe*'. - (if (file-port? (current-error-port)) - (let ((error-port-fileno - (fileno (current-error-port)))) - (unless (eq? error-port-fileno 2) - (dup2 error-port-fileno - 2))) - (dup2 (open-fdes "/dev/null" O_WRONLY) - 2)) - (apply execlp command command args)) - (lambda () - (primitive-_exit 127)))) - (pid - (close-port child) - (values parent pid)))))) + (if (defined? 'spawn) + (let* ((void (open-fdes "/dev/null" O_WRONLY)) + (pid (catch 'system-error + (lambda () + (spawn command (cons command args) + #:input child + #:output child + #:error (if (file-port? (current-error-port)) + (current-error-port) + void))) + (const #f)))) ;can't exec, for instance ENOENT + (close-fdes void) + (close-port child) + (values parent pid)) + (match (primitive-fork) ;Guile < 3.0.9 + (0 + (dynamic-wind + (lambda () + #t) + (lambda () + (close-port parent) + (close-fdes 0) + (close-fdes 1) + (close-fdes 2) + (dup2 (fileno child) 0) + (dup2 (fileno child) 1) + ;; Mimic 'open-pipe*'. + (if (file-port? (current-error-port)) + (let ((error-port-fileno + (fileno (current-error-port)))) + (unless (eq? error-port-fileno 2) + (dup2 error-port-fileno + 2))) + (dup2 (open-fdes "/dev/null" O_WRONLY) + 2)) + (apply execlp command command args)) + (lambda () + (primitive-_exit 127)))) + (pid + (close-port child) + (values parent pid))))))) (define* (inferior-pipe directory command error-port) "Return two values: an input/output pipe on the Guix instance in DIRECTORY @@ -314,6 +330,10 @@ equivalent. Return #f if the inferior could not be launched." (inferior inferior-exception-inferior) ;<inferior> | #f (stack inferior-exception-stack)) ;list of (FILE COLUMN LINE) +(define-condition-type &inferior-protocol-error &error + inferior-protocol-error? + (inferior inferior-protocol-error-inferior)) ;<inferior> + (define* (read-repl-response port #:optional inferior) "Read a (guix repl) response from PORT and return it as a Scheme object. Raise '&inferior-exception' when an exception is read from PORT." @@ -339,7 +359,11 @@ Raise '&inferior-exception' when an exception is read from PORT." (raise (condition (&inferior-exception (arguments (cons key (map sexp->object objects))) (inferior inferior) - (stack '()))))))) + (stack '()))))) + (_ + ;; Protocol error. + (raise (condition (&inferior-protocol-error + (inferior inferior))))))) (define (read-inferior-response inferior) (read-repl-response (inferior-socket inferior) @@ -833,9 +857,9 @@ CHANNEL's 'commit' field is a full SHA1, return it as-is; if it's a SHA1 prefix, resolve it; and if 'commit' is unset, fetch CHANNEL's branch tip." (let ((commit (channel-commit channel)) (branch (channel-branch channel))) - (if (and commit (= (string-length commit) 40)) + (if (and commit (commit-id? commit)) commit - (let* ((ref (if commit `(commit . ,commit) `(branch . ,branch))) + (let* ((ref (if commit `(tag-or-commit . ,commit) `(branch . ,branch))) (cache commit relation (update-cached-checkout (channel-url channel) #:ref ref diff --git a/guix/licenses.scm b/guix/licenses.scm index 3b820ae07e..632c9174df 100644 --- a/guix/licenses.scm +++ b/guix/licenses.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2012, 2014, 2015, 2017, 2019, 2020 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2012, 2014, 2015, 2017, 2019, 2020, 2022 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2013, 2015 Andreas Enge <andreas@enge.fr> ;;; Copyright © 2012, 2013 Nikita Karetnikov <nikita@karetnikov.org> ;;; Copyright © 2015 Mark H Weaver <mhw@netris.org> @@ -57,6 +57,7 @@ edl1.0 epl1.0 epl2.0 + eupl1.1 eupl1.2 expat expat-0 freetype @@ -109,13 +110,6 @@ hpnd fsdg-compatible)) -(define-record-type <license> - (license name uri comment) - license? - (name license-name) - (uri license-uri) - (comment license-comment)) - ;;; Commentary: ;;; ;;; Available licenses. @@ -129,6 +123,53 @@ ;;; ;;; Code: +(define-record-type <license> + (license name uri comment) + actual-license? + (name license-name) + (uri license-uri) + (comment license-comment)) + +(define-syntax define-license-predicate + (syntax-rules (define define*) + "Define PREDICATE as a license predicate that, when applied to trivial +cases, reduces to #t at macro-expansion time." + ((_ predicate (variables ...) (procedures ...) + (define variable _) rest ...) + (define-license-predicate + predicate + (variable variables ...) (procedures ...) + rest ...)) + ((_ predicate (variables ...) (procedures ...) + (define* (procedure _ ...) _ ...) + rest ...) + (define-license-predicate + predicate + (variables ...) (procedure procedures ...) + rest ...)) + ((_ predicate (variables ...) (procedures ...)) + (define-syntax predicate + (lambda (s) + (syntax-case s (variables ... procedures ...) + ((_ variables) #t) ... + ((_ (procedures _)) #t) ... + ((_ obj) #'(actual-license? obj)) + (id + (identifier? #'id) + #'actual-license?))))))) + +(define-syntax begin-license-definitions + (syntax-rules () + ((_ predicate definitions ...) + (begin + ;; Define PREDICATE such that it expands to #t when passed one of the + ;; identifiers in DEFINITIONS. + (define-license-predicate predicate () () definitions ...) + + definitions ...)))) + +(begin-license-definitions license? + (define agpl1 (license "AGPL 1" "https://gnu.org/licenses/agpl.html" @@ -304,6 +345,11 @@ at URI, which may be a file:// URI pointing the package's tree." "https://www.eclipse.org/legal/epl-2.0/" "https://www.gnu.org/licenses/license-list#EPL2")) +(define eupl1.1 + (license "EUPL 1.1" + "https://directory.fsf.org/wiki/License:EUPL-1.1" + "https://www.gnu.org/licenses/license-list#EUPL-1.1")) + (define eupl1.2 (license "EUPL 1.2" "https://directory.fsf.org/wiki/License:EUPL-1.2" @@ -717,6 +763,6 @@ Data. More details can be found at URI. See also https://www.gnu.org/distros/free-system-distribution-guidelines.en.html#non-functional-data." (license "FSDG-compatible" uri - comment)) + comment))) ;;; licenses.scm ends here diff --git a/guix/lint.scm b/guix/lint.scm index 4ef3a46838..a8a375e502 100644 --- a/guix/lint.scm +++ b/guix/lint.scm @@ -1,7 +1,7 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2014 Cyril Roelandt <tipecaml@gmail.com> ;;; Copyright © 2014, 2015 Eric Bavier <bavier@member.fsf.org> -;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2013-2022 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2015, 2016 Mathieu Lirzin <mthl@gnu.org> ;;; Copyright © 2016 Danny Milosavljevic <dannym+a@scratchpost.org> ;;; Copyright © 2016 Hartmut Goebel <h.goebel@crazy-compilers.com> @@ -34,6 +34,7 @@ #:use-module (guix store) #:autoload (guix base16) (bytevector->base16-string) #:use-module (guix base32) + #:autoload (guix base64) (base64-encode) #:use-module (guix build-system) #:use-module (guix diagnostics) #:use-module (guix download) @@ -46,7 +47,6 @@ gexp->approximate-sexp)) #:use-module (guix licenses) #:use-module (guix records) - #:use-module (guix grafts) #:use-module (guix upstream) #:use-module (guix utils) #:use-module (guix memoization) @@ -59,10 +59,20 @@ #:use-module ((guix swh) #:hide (origin?)) #:autoload (guix git-download) (git-reference? git-reference-url git-reference-commit) + #:autoload (guix svn-download) (svn-reference? + svn-reference-url + svn-reference-user-name + svn-reference-password + + svn-multi-reference? + svn-multi-reference-url + svn-multi-reference-user-name + svn-multi-reference-password) #:use-module (guix import stackage) #:use-module (ice-9 match) #:use-module (ice-9 regex) #:use-module (ice-9 format) + #:autoload (rnrs bytevectors) (string->utf8) #:use-module (web client) #:use-module (web uri) #:use-module ((guix build download) @@ -720,8 +730,14 @@ response from URI, and additional details, such as the actual HTTP response. TIMEOUT is the maximum number of seconds (possibly an inexact number) to wait for connections to complete; when TIMEOUT is #f, wait as long as needed." (define headers - '((User-Agent . "GNU Guile") - (Accept . "*/*"))) + `((User-Agent . "GNU Guile") + (Accept . "*/*") + ,@(match (uri-userinfo uri) + ((? string? str) ;"basic authentication" + `((Authorization . ,(string-append "Basic " + (base64-encode + (string->utf8 str)))))) + (_ '())))) (let loop ((uri uri) (visited '())) @@ -1129,6 +1145,40 @@ descriptions maintained upstream." ((uris ...) uris))) +(define (svn-reference-uri-with-userinfo ref) + "Return the URI of REF, an <svn-reference> or <svn-multi-reference> object, +but with an additional 'userinfo' part corresponding to REF's user name and +password, provided REF's URI is HTTP or HTTPS." + ;; XXX: For lack of record type inheritance. + (define ->url + (if (svn-reference? ref) + svn-reference-url + svn-multi-reference-url)) + (define ->user-name + (if (svn-reference? ref) + svn-reference-user-name + svn-multi-reference-user-name)) + (define ->password + (if (svn-reference? ref) + svn-reference-password + svn-multi-reference-password)) + + (let ((uri (string->uri (->url ref)))) + (if (and (->user-name ref) + (memq (uri-scheme uri) '(http https))) + (build-uri (uri-scheme uri) + #:userinfo + (string-append (->user-name ref) + (if (->password ref) + (string-append + ":" (->password ref)) + "")) + #:host (uri-host uri) + #:port (uri-port uri) + #:query (uri-query uri) + #:fragment (uri-fragment uri)) + uri))) + (define (check-source package) "Emit a warning if PACKAGE has an invalid 'source' field, or if that 'source' is not reachable." @@ -1174,6 +1224,12 @@ descriptions maintained upstream." ((git-reference? (origin-uri origin)) (warnings-for-uris (list (string->uri (git-reference-url (origin-uri origin)))))) + ((or (svn-reference? (origin-uri origin)) + (svn-multi-reference? (origin-uri origin))) + (let ((uri (svn-reference-uri-with-userinfo (origin-uri origin)))) + (if (memq (uri-scheme uri) '(http https)) + (warnings-for-uris (list uri)) + '()))) ;TODO: handle svn:// URLs (else '())) '()))) diff --git a/guix/modules.scm b/guix/modules.scm index 61bc8e1978..77e1c2b6f4 100644 --- a/guix/modules.scm +++ b/guix/modules.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2016, 2017, 2018, 2019, 2021 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2016-2019, 2021-2022 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -77,7 +77,7 @@ CLAUSES." ((#:autoload module _ rest ...) (loop rest (cons module result))) (((or #:export #:re-export #:export-syntax #:re-export-syntax - #:re-export-and-replace #:replace #:version) + #:re-export-and-replace #:replace #:version #:declarative?) _ rest ...) (loop rest result)) (((or #:pure #:no-backtrace) rest ...) diff --git a/guix/packages.scm b/guix/packages.scm index 94e464cd01..041a872f9d 100644 --- a/guix/packages.scm +++ b/guix/packages.scm @@ -8,6 +8,7 @@ ;;; Copyright © 2020, 2021 Maxim Cournoyer <maxim.cournoyer@gmail.com> ;;; Copyright © 2021 Chris Marusich <cmmarusich@gmail.com> ;;; Copyright © 2022 Maxime Devos <maximedevos@telenet.be> +;;; Copyright © 2022 jgart <jgart@dismail.de> ;;; ;;; This file is part of GNU Guix. ;;; @@ -41,6 +42,9 @@ #:use-module (guix search-paths) #:use-module (guix sets) #:use-module (guix deprecation) + #:use-module ((guix diagnostics) + #:select (formatted-message define-with-syntax-properties)) + #:autoload (guix licenses) (license?) #:use-module (guix i18n) #:use-module (ice-9 match) #:use-module (ice-9 vlist) @@ -86,6 +90,7 @@ this-package package-name package-upstream-name + package-upstream-name* package-version package-full-name package-source @@ -159,6 +164,8 @@ &package-error package-error? package-error-package + package-license-error? + package-error-invalid-license &package-input-error package-input-error? package-error-invalid-input @@ -418,7 +425,7 @@ from forcing GEXP-PROMISE." (define %hurd-systems ;; The GNU/Hurd systems for which support is being developed. - '("i586-gnu" "i686-gnu")) + '("i586-gnu")) (define %cuirass-supported-systems ;; This is the list of system types for which build machines are available. @@ -533,6 +540,34 @@ Texinfo. Otherwise, return the string." ((_ obj) #'obj))))) +(define-syntax valid-license-value? + (syntax-rules (list package-license) + "Return #t if the given value is a valid license field, #f otherwise." + ;; Arrange so that the answer can be given at macro-expansion time in the + ;; most common cases. + ((_ (list x ...)) + (and (license? x) ...)) + ((_ (package-license _)) + #t) + ((_ obj) + (or (license? obj) + ;; Note: Avoid 'not' below due to <https://bugs.gnu.org/58217>. + (eq? #f obj) ;#f is considered valid + (let ((x obj)) + (and (pair? x) (every license? x))))))) + +(define-with-syntax-properties (validate-license (value properties)) + (unless (valid-license-value? value) + (raise + (make-compound-condition + (condition + (&error-location + (location (source-properties->location properties)))) + (condition + (&package-license-error (package #f) (license value))) + (formatted-message (G_ "~s: invalid package license~%") value)))) + value) + ;; A package. (define-record-type* <package> package make-package @@ -574,8 +609,9 @@ Texinfo. Otherwise, return the string." (sanitize validate-texinfo)) ; one-line description (description package-description (sanitize validate-texinfo)) ; one or two paragraphs - (license package-license) ; (list of) <license> - (home-page package-home-page) + (license package-license ; (list of) <license> + (sanitize validate-license)) + (home-page package-home-page) ; string (supported-systems package-supported-systems ; list of strings (default %supported-systems)) @@ -657,6 +693,38 @@ it has in Guix." (or (assq-ref (package-properties package) 'upstream-name) (package-name package))) +(define (package-upstream-name* package) + "Return the upstream name of PACKAGE, accounting for commonly-used +package name prefixes in addition to the @code{upstream-name} property." + (let ((namespaces (list "cl-" + "ecl-" + "emacs-" + "ghc-" + "go-" + "guile-" + "java-" + "julia-" + "lua-" + "minetest-" + "node-" + "ocaml-" + "perl-" + "python-" + "r-" + "ruby-" + "rust-" + "sbcl-" + "texlive-")) + (name (package-name package))) + (or (assq-ref (package-properties package) 'upstream-name) + (let loop ((prefixes namespaces)) + (match prefixes + (() name) + ((prefix rest ...) + (if (string-prefix? prefix name) + (substring name (string-length prefix)) + (loop rest)))))))) + (define (hidden-package p) "Return a \"hidden\" version of P--i.e., one that 'fold-packages' and thus, user interfaces, ignores." @@ -737,6 +805,10 @@ exist, return #f instead." package-error? (package package-error-package)) +(define-condition-type &package-license-error &package-error + package-license-error? + (license package-error-invalid-license)) + (define-condition-type &package-input-error &package-error package-input-error? (input package-error-invalid-input)) @@ -1138,9 +1210,9 @@ inputs of Coreutils and adds libcap: (modify-inputs (package-inputs coreutils) (delete \"gmp\" \"acl\") - (append libcap)) + (prepend libcap)) -Other types of clauses include 'prepend' and 'replace'. +Other types of clauses include 'append' and 'replace'. The first argument must be a labeled input list; the result is also a labeled input list." diff --git a/guix/pki.scm b/guix/pki.scm index 6326e065e9..c5b2fb9634 100644 --- a/guix/pki.scm +++ b/guix/pki.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2013, 2014, 2016 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2013, 2014, 2016, 2022 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -21,6 +21,7 @@ #:use-module (gcrypt pk-crypto) #:use-module ((guix utils) #:select (with-atomic-file-output)) #:use-module ((guix build utils) #:select (mkdir-p)) + #:autoload (srfi srfi-1) (delete-duplicates) #:use-module (ice-9 match) #:use-module (ice-9 rdelim) #:use-module (ice-9 binary-ports) @@ -61,9 +62,10 @@ element in KEYS must be a canonical sexp with type 'public-key'." ;; want to have name certificates and to use subject names instead of ;; complete keys. `(acl ,@(map (lambda (key) - `(entry ,(canonical-sexp->sexp key) + `(entry ,key (tag (guix import)))) - keys))) + (delete-duplicates + (map canonical-sexp->sexp keys))))) (define %acl-file (string-append %config-directory "/acl")) diff --git a/guix/platform.scm b/guix/platform.scm index f873913fe0..a2d95ab507 100644 --- a/guix/platform.scm +++ b/guix/platform.scm @@ -22,6 +22,8 @@ #:use-module (guix records) #:use-module (guix ui) #:use-module (srfi srfi-1) + #:use-module (srfi srfi-34) + #:use-module (srfi srfi-35) #:export (platform platform? platform-target @@ -29,6 +31,10 @@ platform-linux-architecture platform-glibc-dynamic-linker + &platform-not-found-error + platform-not-found-error? + false-if-platform-not-found + platform-modules platforms lookup-platform-by-system @@ -72,6 +78,20 @@ ;;; +;;; Exceptions. +;;; +(define-condition-type &platform-not-found-error &error + platform-not-found-error? + (target-or-system platform-not-found-error-target-or-system)) + +(define-syntax-rule (false-if-platform-not-found exp) + "Evaluate EXP but return #f if it raises a platform-not-found-error? +exception." + (guard (ex ((platform-not-found-error? ex) #f)) + exp)) + + +;;; ;;; Platforms. ;;; @@ -94,23 +114,32 @@ (platform-modules))))) (define (lookup-platform-by-system system) - "Return the platform corresponding to the given SYSTEM." - (find (lambda (platform) - (let ((s (platform-system platform))) - (and (string? s) (string=? s system)))) - (platforms))) + "Return the platform corresponding to the given SYSTEM. Raise +&PLATFORM-NOT-FOUND-ERROR when no platform could be found." + (or (find (lambda (platform) + (let ((s (platform-system platform))) + (and (string? s) (string=? s system)))) + (platforms)) + (raise-exception (condition (&platform-not-found-error + (target-or-system system)))))) (define (lookup-platform-by-target target) - "Return the platform corresponding to the given TARGET." - (find (lambda (platform) - (let ((t (platform-target platform))) - (and (string? t) (string=? t target)))) - (platforms))) + "Return the platform corresponding to the given TARGET. Raise +&PLATFORM-NOT-FOUND-ERROR when no platform could be found." + (or (find (lambda (platform) + (let ((t (platform-target platform))) + (and (string? t) (string=? t target)))) + (platforms)) + (raise-exception (condition (&platform-not-found-error + (target-or-system target)))))) (define (lookup-platform-by-target-or-system target-or-system) - "Return the platform corresponding to the given TARGET or SYSTEM." - (or (lookup-platform-by-target target-or-system) - (lookup-platform-by-system target-or-system))) + "Return the platform corresponding to the given TARGET or SYSTEM. Raise +&PLATFORM-NOT-FOUND-ERROR when no platform could be found." + (or (false-if-platform-not-found (lookup-platform-by-target target-or-system)) + (false-if-platform-not-found (lookup-platform-by-system target-or-system)) + (raise-exception (condition (&platform-not-found-error + (target-or-system target-or-system)))))) (define (platform-system->target system) "Return the target matching the given SYSTEM if it exists or false diff --git a/guix/profiles.scm b/guix/profiles.scm index 226d316dad..a7445c2ed8 100644 --- a/guix/profiles.scm +++ b/guix/profiles.scm @@ -1035,7 +1035,7 @@ MANIFEST." (setenv "LANGUAGE" language) (zero? (system* #+(file-append texinfo "/bin/install-info") - "--silent" info + info (apply string-append #$output "/share/info/dir" (if (string=? "en" language) '("") diff --git a/guix/read-print.scm b/guix/read-print.scm index 65b8cce37d..ccddca732d 100644 --- a/guix/read-print.scm +++ b/guix/read-print.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2021-2022 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2021-2023 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -277,7 +277,7 @@ expressions and blanks that were read." ('lambda 2) ('lambda* 2) ('match-lambda 1) - ('match-lambda* 2) + ('match-lambda* 1) ('define 2) ('define* 2) ('define-public 2) @@ -286,11 +286,15 @@ expressions and blanks that were read." ('define-syntax-rule 2) ('define-module 2) ('define-gexp-compiler 2) + ('define-record-type 2) + ('define-record-type* 4) + ('define-configuration 2) ('let 2) ('let* 2) ('letrec 2) ('letrec* 2) ('match 2) + ('match-record 3) ('when 2) ('unless 2) ('package 1) @@ -484,6 +488,19 @@ each line except the first one (they're assumed to be already there)." (8 "#o")) (number->string integer base))) +(define %special-non-extended-symbols + ;; Special symbols that can be written without the #{...}# notation for + ;; extended symbols: 1+, 1-, 123/, etc. + (make-regexp "^[0-9]+[[:graph:]]+$" regexp/icase)) + +(define (symbol->display-string symbol context) + "Return the most appropriate representation of SYMBOL, resorting to extended +symbol notation only when strictly necessary." + (let ((str (symbol->string symbol))) + (if (regexp-exec %special-non-extended-symbols str) + str ;no need for the #{...}# notation + (object->string symbol)))) + (define* (pretty-print-with-comments port obj #:key (format-comment @@ -557,7 +574,8 @@ FORMAT-VERTICAL-SPACE; a useful value of 'canonicalize-vertical-space'." ((? string? str) (>= (+ (string-width str) 2 indent) max-width)) ((? symbol? symbol) - (>= (+ (string-width (symbol->string symbol)) indent) + (>= (+ (string-width (symbol->display-string symbol context)) + indent) max-width)) ((? boolean?) (>= (+ 2 indent) max-width)) @@ -643,7 +661,7 @@ FORMAT-VERTICAL-SPACE; a useful value of 'canonicalize-vertical-space'." ;; and following arguments are less indented. (let* ((lead (special-form-lead head context)) (context (cons head context)) - (head (symbol->string head)) + (head (symbol->display-string head (cdr context))) (total (length arguments))) (unless delimited? (display " " port)) (display "(" port) @@ -723,6 +741,8 @@ FORMAT-VERTICAL-SPACE; a useful value of 'canonicalize-vertical-space'." (printed-string obj context)) ((integer? obj) (integer->string obj context)) + ((symbol? obj) + (symbol->display-string obj context)) (else (object->string obj)))) (len (string-width str))) diff --git a/guix/records.scm b/guix/records.scm index ed94c83dac..1f097c7108 100644 --- a/guix/records.scm +++ b/guix/records.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2012-2022 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2018 Mark H Weaver <mhw@netris.org> ;;; ;;; This file is part of GNU Guix. @@ -104,6 +104,10 @@ error-reporting purposes." (() #t))))))) +(define-syntax map-fields + (lambda (x) + (syntax-violation 'map-fields "bad use of syntactic keyword" x x))) + (define-syntax-parameter this-record (lambda (s) "Return the record being defined. This macro may only be used in the @@ -325,6 +329,15 @@ This expression returns a new object equal to 'x' except for its 'name' field and its 'loc' field---the latter is marked as \"innate\", so it is not inherited." + (define (rtd-identifier type) + ;; Return an identifier derived from TYPE to name its record type + ;; descriptor (RTD). + (let ((type-name (syntax->datum type))) + (datum->syntax + type + (string->symbol + (string-append "% " (symbol->string type-name) " rtd"))))) + (define (field-default-value s) (syntax-case s (default) ((field (default val) _ ...) @@ -428,10 +441,31 @@ inherited." field))) field-spec))) #`(begin - (define-record-type type + (define-record-type #,(rtd-identifier #'type) (ctor field ...) pred field-spec* ...) + + ;; Rectify the vtable type name... + (set-struct-vtable-name! #,(rtd-identifier #'type) 'type) + (cond-expand + (guile-3 + ;; ... and the record type name. + (struct-set! #,(rtd-identifier #'type) vtable-offset-user + 'type)) + (else #f)) + + (define-syntax type + (lambda (s) + "This macro lets us query record type info at +macro-expansion time." + (syntax-case s (map-fields) + ((_ map-fields macro) + #'(macro (field ...))) + (id + (identifier? #'id) + #'#,(rtd-identifier #'type))))) + (define #,(current-abi-identifier #'type) #,cookie) @@ -535,19 +569,53 @@ pairs. Stop upon an empty line (after consuming it) or EOF." (else (error "unmatched line" line)))))))) + +;;; +;;; Pattern matching. +;;; + +(define-syntax lookup-field + (lambda (s) + "Look up FIELD in the given list and return an expression that represents +its offset in the record. Raise a syntax violation when the field is not +found." + (syntax-case s () + ((_ field offset ()) + (syntax-violation 'lookup-field "unknown record type field" + s #'field)) + ((_ field offset (head tail ...)) + (free-identifier=? #'field #'head) + #'offset) + ((_ field offset (_ tail ...)) + #'(lookup-field field (+ 1 offset) (tail ...)))))) + +(define-syntax match-record-inner + (lambda (s) + (syntax-case s () + ((_ record type ((field variable) rest ...) body ...) + #'(let-syntax ((field-offset (syntax-rules () + ((_ f) + (lookup-field field 0 f))))) + (let* ((offset (type map-fields field-offset)) + (variable (struct-ref record offset))) + (match-record-inner record type (rest ...) body ...)))) + ((_ record type (field rest ...) body ...) + ;; Redirect to the canonical form above. + #'(match-record-inner record type ((field field) rest ...) body ...)) + ((_ record type () body ...) + #'(begin body ...))))) + (define-syntax match-record (syntax-rules () "Bind each FIELD of a RECORD of the given TYPE to it's FIELD name. +The order in which fields appear does not matter. A syntax error is raised if +an unknown field is queried. + The current implementation does not support thunked and delayed fields." - ((_ record type (field fields ...) body ...) + ;; TODO support thunked and delayed fields + ((_ record type (fields ...) body ...) (if (eq? (struct-vtable record) type) - ;; TODO compute indices and report wrong-field-name errors at - ;; expansion time - ;; TODO support thunked and delayed fields - (let ((field ((record-accessor type 'field) record))) - (match-record record type (fields ...) body ...)) - (throw 'wrong-type-arg record))) - ((_ record type () body ...) - (begin body ...)))) + (match-record-inner record type (fields ...) body ...) + (throw 'wrong-type-arg record))))) ;;; records.scm ends here diff --git a/guix/scripts.scm b/guix/scripts.scm index 3aabaf5c9c..4de8bc23b3 100644 --- a/guix/scripts.scm +++ b/guix/scripts.scm @@ -22,7 +22,6 @@ ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. (define-module (guix scripts) - #:use-module (guix grafts) #:use-module (guix utils) #:use-module (guix ui) #:use-module (guix store) diff --git a/guix/scripts/archive.scm b/guix/scripts/archive.scm index 1e961c84e6..3b2bdee835 100644 --- a/guix/scripts/archive.scm +++ b/guix/scripts/archive.scm @@ -26,7 +26,6 @@ #:select (fold-archive restore-file)) #:use-module (guix store) #:use-module ((guix status) #:select (with-status-verbosity)) - #:use-module (guix grafts) #:use-module (guix packages) #:use-module (guix derivations) #:use-module (guix monads) diff --git a/guix/scripts/build.scm b/guix/scripts/build.scm index 06d9ad1f0c..b4437172d7 100644 --- a/guix/scripts/build.scm +++ b/guix/scripts/build.scm @@ -28,10 +28,7 @@ #:use-module (guix derivations) #:use-module (guix packages) #:use-module (guix memoization) - #:use-module (guix grafts) - #:use-module (guix utils) - #:use-module (guix monads) #:use-module (guix gexp) #:use-module (guix profiles) @@ -383,8 +380,9 @@ use '--no-offload' instead~%"))) (format #f (G_ "Did you mean @code{~a}? Try @option{--list-targets} to view available targets.~%") closest)) - (display-hint (G_ "\ -Try @option{--list-targets} to view available targets.~%"))) + (display-hint + (format #f (G_ "\ +Try @option{--list-targets} to view available targets.~%")))) (exit 1)))))))) (define %standard-native-build-options @@ -409,8 +407,9 @@ Try @option{--list-targets} to view available targets.~%"))) (format #f (G_ "Did you mean @code{~a}? Try @option{--list-systems} to view available system types.~%") closest)) - (display-hint (G_ "\ -Try @option{--list-systems} to view available system types.~%"))) + (display-hint + (format #f (G_ "\ +Try @option{--list-systems} to view available system types.~%")))) (exit 1)))))))) diff --git a/guix/scripts/challenge.scm b/guix/scripts/challenge.scm index f1e5f67dab..620a1762a1 100644 --- a/guix/scripts/challenge.scm +++ b/guix/scripts/challenge.scm @@ -22,7 +22,6 @@ #:use-module (guix scripts) #:use-module (guix store) #:use-module (guix utils) - #:use-module (guix grafts) #:use-module (guix monads) #:use-module (guix base32) #:use-module (guix packages) diff --git a/guix/scripts/deploy.scm b/guix/scripts/deploy.scm index 2c76645173..ef6f9acc86 100644 --- a/guix/scripts/deploy.scm +++ b/guix/scripts/deploy.scm @@ -27,7 +27,6 @@ #:use-module (guix gexp) #:use-module (guix ui) #:use-module (guix utils) - #:use-module (guix grafts) #:use-module ((guix status) #:select (with-status-verbosity)) #:use-module (guix diagnostics) #:use-module (guix i18n) @@ -256,7 +255,7 @@ otherwise." (leave (G_ "missing deployment file argument~%"))) (when (and (pair? command) (not execute-command?)) - (leave (G_ "'--' was used by '-x' was not specified~%"))) + (leave (G_ "'--' was used, but '-x' was not specified~%"))) (with-status-verbosity (assoc-ref opts 'verbosity) (with-store store diff --git a/guix/scripts/describe.scm b/guix/scripts/describe.scm index 0c310e3da8..80cd0ce00a 100644 --- a/guix/scripts/describe.scm +++ b/guix/scripts/describe.scm @@ -3,6 +3,7 @@ ;;; Copyright © 2018 Oleg Pykhalov <go.wigust@gmail.com> ;;; Copyright © 2020 Ekaitz Zarraga <ekaitz@elenq.tech> ;;; Copyright © 2021 Simon Tournier <zimon.toutoune@gmail.com> +;;; Copyright © 2022 jgart <jgart@dismail.de> ;;; ;;; This file is part of GNU Guix. ;;; @@ -119,6 +120,7 @@ Display information about the channels currently in use.\n")) (let ((intro (channel-introduction channel))) `((name . ,(channel-name channel)) (url . ,(channel-url channel)) + (branch . ,(channel-branch channel)) (commit . ,(channel-commit channel)) ,@(if intro `((introduction @@ -135,6 +137,7 @@ Display information about the channels currently in use.\n")) (format port "name: ~a~%" (channel-name channel)) (format port "url: ~a~%" (channel-url channel)) + (format port "branch: ~a~%" (channel-branch channel)) (format port "commit: ~a~%" (channel-commit channel)) (when intro (format port "introductioncommit: ~a~%" diff --git a/guix/scripts/environment.scm b/guix/scripts/environment.scm index 2493134470..46435ae48e 100644 --- a/guix/scripts/environment.scm +++ b/guix/scripts/environment.scm @@ -1,7 +1,8 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2014, 2015, 2018 David Thompson <davet@gnu.org> -;;; Copyright © 2015-2022 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2015-2023 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2018 Mike Gerwitz <mtg@gnu.org> +;;; Copyright © 2022, 2023 John Kehayias <john.kehayias@protonmail.com> ;;; ;;; This file is part of GNU Guix. ;;; @@ -23,7 +24,6 @@ #:use-module (guix store) #:use-module (guix utils) #:use-module ((guix status) #:select (with-status-verbosity)) - #:use-module (guix grafts) #:use-module (guix derivations) #:use-module (guix packages) #:use-module (guix profiles) @@ -33,8 +33,10 @@ #:use-module ((guix gexp) #:select (lower-object)) #:use-module (guix scripts) #:use-module (guix scripts build) + #:autoload (guix scripts pack) (symlink-spec-option-parser) #:use-module (guix transformations) #:autoload (ice-9 ftw) (scandir) + #:use-module (gnu build install) #:autoload (gnu build linux-container) (call-with-container %namespaces user-namespace-supported? unprivileged-user-namespace-supported? @@ -120,6 +122,9 @@ shell'." --expose=SPEC for containers, expose read-only host file system according to SPEC")) (display (G_ " + -S, --symlink=SPEC for containers, add symlinks to the profile according + to SPEC, e.g. \"/usr/bin/env=bin/env\".")) + (display (G_ " -v, --verbosity=LEVEL use the given verbosity LEVEL")) (display (G_ " --bootstrap use bootstrap binaries to build the environment"))) @@ -157,6 +162,7 @@ COMMAND or an interactive shell in that environment.\n")) (define %default-options `((system . ,(%current-system)) (substitutes? . #t) + (symlinks . ()) (offload? . #t) (graft? . #t) (print-build-trace? . #t) @@ -256,6 +262,7 @@ use '--preserve' instead~%")) (alist-cons 'file-system-mapping (specification->file-system-mapping arg #f) result))) + (option '(#\S "symlink") #t #f symlink-spec-option-parser) (option '(#\r "root") #t #f (lambda (opt name arg result) (alist-cons 'gc-root arg result))) @@ -375,6 +382,65 @@ requisite store items i.e. the union closure of all the inputs." input->requisites inputs))) (return (delete-duplicates (concatenate reqs))))) +(define (setup-fhs profile) + "Setup the FHS container by creating and linking expected directories from +PROFILE (other bind mounts are done in LAUNCH-ENVIRONMENT/CONTAINER), +providing a symlink for CC if GCC is in the container PROFILE, and writing +/etc/ld.so.conf." + ;; Additional symlinks for an FHS container. + (define fhs-symlinks + `(("/lib" . "/usr/lib") + ,(if (target-64bit?) + '("/lib" . "/lib64") + '("/lib" . "/lib32")) + ("/bin" . "/usr/bin") + ("/sbin" . "/usr/sbin"))) + + ;; A procedure to symlink the contents (at the top level) of a directory, + ;; excluding the directory itself and parent, along with any others provided + ;; in EXCLUDE. + (define* (link-contents dir #:key (exclude '())) + (for-each (lambda (file) + (symlink (string-append profile dir "/" file) + (string-append dir "/" file))) + (scandir (string-append profile dir) + (negate (cut member <> + (append exclude '("." ".." ))))))) + + ;; The FHS container sets up the expected filesystem through MAPPINGS with + ;; FHS-MAPPINGS (in LAUNCH-ENVIRONMENT/CONTAINER), the symlinks through + ;; FHS-SYMLINKS, and linking the contents of PROFILE/bin and PROFILE/etc + ;; using LINK-CONTENTS, as these both have or will have contents for a + ;; non-FHS container so must be handled separately. + (mkdir-p "/usr") + (for-each (lambda (link) + (if (file-exists? (car link)) + (symlink (car link) (cdr link)))) + fhs-symlinks) + (link-contents "/bin" #:exclude '("sh")) + (mkdir-p "/etc") + (link-contents "/etc") + + ;; Provide a frequently expected 'cc' symlink to gcc (in case it is in + ;; PROFILE), though this could also be done by the user in the container, + ;; e.g. in $HOME/.local/bin and adding that to $PATH. Note: we do this in + ;; /bin since that already has the sh symlink and the other (optional) FHS + ;; bin directories will link to /bin. + (let ((gcc-path (string-append profile "/bin/gcc"))) + (if (file-exists? gcc-path) + (symlink gcc-path "/bin/cc"))) + + ;; Guix's ldconfig doesn't search in FHS default locations, so provide a + ;; minimal ld.so.conf. + (call-with-output-file "/etc/ld.so.conf" + (lambda (port) + (for-each (lambda (directory) + (display directory port) + (newline port)) + ;; /lib/nss is needed as Guix's nss puts libraries + ;; there rather than in the lib directory. + '("/lib" "/lib/nss"))))) + (define (status->exit-code status) "Compute the exit code made from STATUS, a value as returned by 'waitpid', and suitable for 'exit'." @@ -386,11 +452,13 @@ and suitable for 'exit'." (define primitive-exit/status (compose primitive-exit status->exit-code)) (define* (launch-environment command profile manifest - #:key pure? (white-list '())) - "Run COMMAND in a new environment containing INPUTS, using the native search -paths defined by the list PATHS. When PURE?, pre-existing environment -variables are cleared before setting the new ones, except those matching the -regexps in WHITE-LIST." + #:key pure? (white-list '()) + emulate-fhs?) + "Load the environment of PROFILE, which corresponds to MANIFEST, and execute +COMMAND. When PURE?, pre-existing environment variables are cleared before +setting the new ones, except those matching the regexps in WHITE-LIST. When +EMULATE-FHS?, first set up an FHS environment with $PATH and generate the LD +cache." ;; Properly handle SIGINT, so pressing C-c in an interactive terminal ;; application works. (sigaction SIGINT SIG_DFL) @@ -406,6 +474,15 @@ regexps in WHITE-LIST." ((program . args) (catch 'system-error (lambda () + (when emulate-fhs? + ;; When running in a container with EMULATE-FHS?, augment $PATH + ;; (optional, but to better match FHS expectations), and generate + ;; /etc/ld.so.cache. + (setenv "PATH" (string-append "/bin:/usr/bin:/sbin:/usr/sbin" + (if (getenv "PATH") + (string-append ":" (getenv "PATH")) + ""))) + (invoke "ldconfig" "-X")) (apply execlp program program args)) (lambda _ ;; Report the error from here because the parent process cannot @@ -527,7 +604,12 @@ environment~%"))) (match (vhash-assoc "PS1" actual) (#f #f) ((_ . str) - (when (and (getenv "PS1") (string=? str (getenv "PS1"))) + (when (and (getenv "PS1") (string=? str (getenv "PS1")) + + ;; 'PS1' might be conditional on 'GUIX_ENVIRONMENT', as + ;; shown in the hint below. + (not (or (string-contains str "$GUIX_ENVIRONMENT") + (string-contains str "${GUIX_ENVIRONMENT")))) (warning (G_ "'PS1' is the same in sub-shell~%")) (display-hint (G_ "Consider setting a different prompt for environment shells to make them distinguishable. @@ -536,10 +618,7 @@ If you are using Bash, you can do that by adding these lines to @file{~/.bashrc}: @example -if [ -n \"$GUIX_ENVIRONMENT\" ] -then - export PS1=\"\\u@@\\h \\w [env]\\$ \" -fi +PS1='\\u@@\\h \\w${GUIX_ENVIRONMENT:+ [env]}\\$ ' @end example ")))))) @@ -604,16 +683,27 @@ regexps in WHITE-LIST." (define* (launch-environment/container #:key command bash user user-mappings profile manifest link-profile? network? - map-cwd? (white-list '())) + map-cwd? emulate-fhs? (setup-hook #f) + (symlinks '()) (white-list '())) "Run COMMAND within a container that features the software in PROFILE. -Environment variables are set according to the search paths of MANIFEST. -The global shell is BASH, a file name for a GNU Bash binary in the -store. When NETWORK?, access to the host system network is permitted. -USER-MAPPINGS, a list of file system mappings, contains the user-specified -host file systems to mount inside the container. If USER is not #f, each -target of USER-MAPPINGS will be re-written relative to '/home/USER', and USER -will be used for the passwd entry. LINK-PROFILE? creates a symbolic link from -~/.guix-profile to the environment profile. +Environment variables are set according to the search paths of MANIFEST. The +global shell is BASH, a file name for a GNU Bash binary in the store. When +NETWORK?, access to the host system network is permitted. USER-MAPPINGS, a +list of file system mappings, contains the user-specified host file systems to +mount inside the container. If USER is not #f, each target of USER-MAPPINGS +will be re-written relative to '/home/USER', and USER will be used for the +passwd entry. + +When EMULATE-FHS?, set up the container to follow the Filesystem Hierarchy +Standard and provide a glibc that reads the cache from /etc/ld.so.cache. +SETUP-HOOK is an additional setup procedure to be called, currently only used +with the EMULATE-FHS? option. + +LINK-PROFILE? creates a symbolic link from ~/.guix-profile to the +environment profile. + +SYMLINKS must be a list of (SOURCE -> TARGET) tuples denoting symlinks to be +added to the container. Preserve environment variables whose name matches the one of the regexps in WHILE-LIST." @@ -621,6 +711,21 @@ WHILE-LIST." (and (file-exists? (file-system-mapping-source mapping)) (file-system-mapping->bind-mount mapping))) + ;; File system mappings for an FHS container, where the entire directory can + ;; be mapped. Others (bin and etc) will already have contents and need to + ;; use LINK-CONTENTS (defined in SETUP-FHS) to symlink the directory + ;; contents. + (define fhs-mappings + (map (lambda (mapping) + (file-system-mapping + (source (string-append profile (car mapping))) + (target (cdr mapping)))) + '(("/lib" . "/lib") + ("/include" . "/usr/include") + ("/sbin" . "/sbin") + ("/libexec" . "/usr/libexec") + ("/share" . "/usr/share")))) + (mlet %store-monad ((reqs (inputs->requisites (list (direct-store-path bash) profile)))) (return @@ -628,14 +733,21 @@ WHILE-LIST." (home (getenv "HOME")) (uid (if user 1000 (getuid))) (gid (if user 1000 (getgid))) - (passwd (let ((pwd (getpwuid (getuid)))) + + ;; On a foreign distro, the name service switch might be + ;; dysfunctional and 'getpwuid' throws. Don't let that hamper + ;; operations. + (passwd (let ((pwd (false-if-exception (getpwuid (getuid))))) (password-entry - (name (or user (passwd:name pwd))) - (real-name (if user + (name (or user + (and=> pwd passwd:name) + (getenv "USER") + "charlie")) + (real-name (if (or user (not pwd)) "" (passwd:gecos pwd))) (uid uid) (gid gid) (shell bash) - (directory (if user + (directory (if (or user (not pwd)) (string-append "/home/" user) (passwd:dir pwd)))))) (groups (list (group-entry (name "users") (gid gid)) @@ -675,6 +787,11 @@ WHILE-LIST." (filter-map optional-mapping->fs %network-file-mappings) '()) + ;; Mappings for an FHS container. + (if emulate-fhs? + (filter-map optional-mapping->fs + fhs-mappings) + '()) (map file-system-mapping->bind-mount mappings)))) (exit/status @@ -702,6 +819,19 @@ WHILE-LIST." (mkdir-p home-dir) (setenv "HOME" home-dir) + ;; Create symlinks. + (let ((symlink->directives + (match-lambda + ((source '-> target) + `((directory ,(dirname source)) + (,source -> ,(string-append profile "/" target))))))) + (for-each (cut evaluate-populate-directive <> ".") + (append-map symlink->directives symlinks))) + + ;; Call an additional setup procedure, if provided. + (when setup-hook + (setup-hook profile)) + ;; If requested, link $GUIX_ENVIRONMENT to $HOME/.guix-profile; ;; this allows programs expecting that path to continue working as ;; expected within a container. @@ -743,7 +873,8 @@ WHILE-LIST." (if link-profile? (string-append home-dir "/.guix-profile") profile) - manifest #:pure? #f))) + manifest #:pure? #f + #:emulate-fhs? emulate-fhs?))) #:guest-uid uid #:guest-gid gid #:namespaces (if network? @@ -861,147 +992,158 @@ message if any test fails." (category development) (synopsis "spawn one-off software environments (deprecated)") - (guix-environment* (parse-args args))) + (with-error-handling + (guix-environment* (parse-args args)))) (define (guix-environment* opts) "Run the 'guix environment' command on OPTS, an alist resulting for command-line option processing with 'parse-command-line'." - (with-error-handling - (let* ((pure? (assoc-ref opts 'pure)) - (container? (assoc-ref opts 'container?)) - (link-prof? (assoc-ref opts 'link-profile?)) - (network? (assoc-ref opts 'network?)) - (no-cwd? (assoc-ref opts 'no-cwd?)) - (user (assoc-ref opts 'user)) - (bootstrap? (assoc-ref opts 'bootstrap?)) - (system (assoc-ref opts 'system)) - (profile (assoc-ref opts 'profile)) - (command (or (assoc-ref opts 'exec) - ;; Spawn a shell if the user didn't specify - ;; anything in particular. - (if container? - ;; The user's shell is likely not available - ;; within the container. - '("/bin/sh") - (list %default-shell)))) - (mappings (pick-all opts 'file-system-mapping)) - (white-list (pick-all opts 'inherit-regexp))) - - (define store-needed? - ;; Whether connecting to the daemon is needed. - (or container? (not profile))) - - (define-syntax-rule (with-store/maybe store exp ...) - ;; Evaluate EXP... with STORE bound to a connection, unless - ;; STORE-NEEDED? is false, in which case STORE is bound to #f. - (let ((proc (lambda (store) exp ...))) - (if store-needed? - (with-store s - (set-build-options-from-command-line s opts) - (with-build-handler (build-notifier #:use-substitutes? - (assoc-ref opts 'substitutes?) - #:verbosity - (assoc-ref opts 'verbosity) - #:dry-run? - (assoc-ref opts 'dry-run?)) - (proc s))) - (proc #f)))) - - (when container? (assert-container-features)) - - (when (and (not container?) link-prof?) + (let* ((pure? (assoc-ref opts 'pure)) + (container? (assoc-ref opts 'container?)) + (link-prof? (assoc-ref opts 'link-profile?)) + (symlinks (assoc-ref opts 'symlinks)) + (network? (assoc-ref opts 'network?)) + (no-cwd? (assoc-ref opts 'no-cwd?)) + (emulate-fhs? (assoc-ref opts 'emulate-fhs?)) + (user (assoc-ref opts 'user)) + (bootstrap? (assoc-ref opts 'bootstrap?)) + (system (assoc-ref opts 'system)) + (profile (assoc-ref opts 'profile)) + (command (or (assoc-ref opts 'exec) + ;; Spawn a shell if the user didn't specify + ;; anything in particular. + (if container? + ;; The user's shell is likely not available + ;; within the container. + '("/bin/sh") + (list %default-shell)))) + (mappings (pick-all opts 'file-system-mapping)) + (white-list (pick-all opts 'inherit-regexp))) + + (define store-needed? + ;; Whether connecting to the daemon is needed. + (or container? (not profile))) + + (define-syntax-rule (with-store/maybe store exp ...) + ;; Evaluate EXP... with STORE bound to a connection, unless + ;; STORE-NEEDED? is false, in which case STORE is bound to #f. + (let ((proc (lambda (store) exp ...))) + (if store-needed? + (with-store s + (set-build-options-from-command-line s opts) + (with-build-handler (build-notifier #:use-substitutes? + (assoc-ref opts 'substitutes?) + #:verbosity + (assoc-ref opts 'verbosity) + #:dry-run? + (assoc-ref opts 'dry-run?)) + (proc s))) + (proc #f)))) + + (when container? (assert-container-features)) + + (when (not container?) + (when link-prof? (leave (G_ "'--link-profile' cannot be used without '--container'~%"))) - (when (and (not container?) user) + (when user (leave (G_ "'--user' cannot be used without '--container'~%"))) - (when (and (not container?) no-cwd?) - (leave (G_ "--no-cwd cannot be used without --container~%"))) - - - (with-store/maybe store - (with-status-verbosity (assoc-ref opts 'verbosity) - (define manifest-from-opts - (options/resolve-packages store opts)) - - (define manifest - (if profile - (profile-manifest profile) - manifest-from-opts)) - - (when (and profile - (> (length (manifest-entries manifest-from-opts)) 0)) - (leave (G_ "'--profile' cannot be used with package options~%"))) - - (when (null? (manifest-entries manifest)) - (warning (G_ "no packages specified; creating an empty environment~%"))) - - ;; Use the bootstrap Guile when requested. - (parameterize ((%graft? (assoc-ref opts 'graft?)) - (%guile-for-build - (and store-needed? - (package-derivation - store - (if bootstrap? - %bootstrap-guile - (default-guile)))))) - (run-with-store store - ;; Containers need a Bourne shell at /bin/sh. - (mlet* %store-monad ((bash (environment-bash container? - bootstrap? - system)) - (prof-drv (if profile - (return #f) - (manifest->derivation - manifest system bootstrap?))) - (profile -> (if profile - (readlink* 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 - (mwhen store-needed? - (built-derivations (append - (if prof-drv (list prof-drv) '()) - (if (derivation? bash) (list bash) '())))) - (mwhen gc-root - (register-gc-root profile gc-root)) - - (mwhen (assoc-ref opts 'check?) - (return - (if container? - (warning (G_ "'--check' is unnecessary \ + (when no-cwd? + (leave (G_ "--no-cwd cannot be used without '--container'~%"))) + (when emulate-fhs? + (leave (G_ "'--emulate-fhs' cannot be used without '--container~%'"))) + (when (pair? symlinks) + (leave (G_ "'--symlink' cannot be used without '--container~%'")))) + + (with-store/maybe store + (with-status-verbosity (assoc-ref opts 'verbosity) + (define manifest-from-opts + (options/resolve-packages store opts)) + + (define manifest + (if profile + (profile-manifest profile) + manifest-from-opts)) + + (when (and profile + (> (length (manifest-entries manifest-from-opts)) 0)) + (leave (G_ "'--profile' cannot be used with package options~%"))) + + (when (null? (manifest-entries manifest)) + (warning (G_ "no packages specified; creating an empty environment~%"))) + + ;; Use the bootstrap Guile when requested. + (parameterize ((%graft? (assoc-ref opts 'graft?)) + (%guile-for-build + (and store-needed? + (package-derivation + store + (if bootstrap? + %bootstrap-guile + (default-guile)))))) + (run-with-store store + ;; Containers need a Bourne shell at /bin/sh. + (mlet* %store-monad ((bash (environment-bash container? + bootstrap? + system)) + (prof-drv (if profile + (return #f) + (manifest->derivation + manifest system bootstrap?))) + (profile -> (if profile + (readlink* 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 + (mwhen store-needed? + (built-derivations (append + (if prof-drv (list prof-drv) '()) + (if (derivation? bash) (list bash) '())))) + (mwhen gc-root + (register-gc-root profile gc-root)) + + (mwhen (assoc-ref opts 'check?) + (return + (if container? + (warning (G_ "'--check' is unnecessary \ when using '--container'; doing nothing~%")) - (validate-child-shell-environment profile manifest)))) - - (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?)))))))))))))) + (validate-child-shell-environment profile manifest)))) + + (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?) + #:emulate-fhs? emulate-fhs? + #:symlinks symlinks + #:setup-hook + (and emulate-fhs? + setup-fhs)))) + + (else + (return + (exit/status + (launch-environment/fork command profile manifest + #:white-list white-list + #:pure? pure?))))))))))))) ;;; Local Variables: ;;; eval: (put 'with-store/maybe 'scheme-indent-function 1) diff --git a/guix/scripts/gc.scm b/guix/scripts/gc.scm index 65cd4bdf8b..5e775c5cdb 100644 --- a/guix/scripts/gc.scm +++ b/guix/scripts/gc.scm @@ -1,5 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2012-2013, 2015-2020, 2022 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2022 Efraim Flashner <efraim@flashner.co.il> ;;; ;;; This file is part of GNU Guix. ;;; @@ -27,6 +28,7 @@ generation-number) #:autoload (guix scripts package) (delete-generations) #:autoload (gnu home) (home-generation-base) + #:autoload (guix store database) (vacuum-database) #:use-module (ice-9 match) #:use-module (ice-9 regex) #:use-module (srfi srfi-1) @@ -87,6 +89,10 @@ Invoke the garbage collector.\n")) --clear-failures remove PATHS from the set of cached failures")) (newline) (display (G_ " + --vacuum-database repack the sqlite database tracking the store + using less space")) + (newline) + (display (G_ " -h, --help display this help and exit")) (display (G_ " -V, --version display version information and exit")) @@ -131,6 +137,11 @@ current one." (lambda args (show-version-and-exit "guix gc"))) + (option '("vacuum-database") #f #f + (lambda args + (vacuum-database) + (exit 0))) + (option '(#\C "collect-garbage") #f #t (lambda (opt name arg result) (let ((result (alist-cons 'action 'collect-garbage diff --git a/guix/scripts/graph.scm b/guix/scripts/graph.scm index 2f102180c9..6847dd1962 100644 --- a/guix/scripts/graph.scm +++ b/guix/scripts/graph.scm @@ -569,6 +569,12 @@ Emit a representation of the dependency graph of PACKAGE...\n")) (category packaging) (synopsis "view and query package dependency graphs") + (define (shorter? str1 str2) + (< (string-length str1) (string-length str2))) + + (define length-sorted + (cut sort <> shorter?)) + (with-error-handling (define opts (parse-command-line args %options @@ -598,13 +604,17 @@ Emit a representation of the dependency graph of PACKAGE...\n")) (run-with-store store ;; XXX: Since grafting can trigger unsolicited builds, disable it. - (mlet %store-monad ((_ (set-grafting #f)) + (mlet %store-monad ((_g (set-grafting #f)) (nodes (mapm %store-monad (node-type-convert type) (reverse items)))) (if (assoc-ref opts 'path?) + ;; Sort by string length such that, in case of multiple + ;; outputs, the shortest one (which corresponds to "out") is + ;; picked (yup, a hack). (match nodes - (((node1 _ ...) (node2 _ ...)) + (((= length-sorted (node1 _ ...)) + (= length-sorted (node2 _ ...))) (display-path node1 node2 type)) (_ (leave (G_ "'--path' option requires exactly two \ diff --git a/guix/scripts/home.scm b/guix/scripts/home.scm index ae830d0b48..a37f059711 100644 --- a/guix/scripts/home.scm +++ b/guix/scripts/home.scm @@ -3,7 +3,7 @@ ;;; Copyright © 2021 Xinglu Chen <public@yoctocell.xyz> ;;; Copyright © 2021 Pierre Langlois <pierre.langlois@gmx.com> ;;; Copyright © 2021 Oleg Pykhalov <go.wigust@gmail.com> -;;; Copyright © 2022 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2022-2023 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2022 Arun Isaac <arunisaac@systemreboot.net> ;;; Copyright © 2022 Antero Mejr <antero@mailbox.org> ;;; @@ -48,7 +48,6 @@ #:use-module (guix derivations) #:use-module (guix ui) #:autoload (guix colors) (supports-hyperlinks? file-hyperlink) - #:use-module (guix grafts) #:use-module (guix packages) #:use-module (guix profiles) #:use-module (guix store) @@ -173,7 +172,7 @@ Some ACTIONS support additional ARGS.\n")) (alist-cons 'dry-run? #t result))) (option '(#\V "version") #f #f (lambda args - (show-version-and-exit "guix show"))) + (show-version-and-exit "guix home"))) (option '(#\v "verbosity") #t #f (lambda (opt name arg result) (let ((level (string->number* arg))) @@ -477,7 +476,7 @@ resulting from command-line parsing." (define (ensure-home-environment file-or-exp obj) (ensure-profile-directory) (unless (home-environment? obj) - (leave (G_ "'~a' does not return a home environment ~%") + (leave (G_ "'~a' does not return a home environment~%") file-or-exp)) obj) @@ -707,7 +706,7 @@ deploy the home environment described by these files.\n") (define (service-type-description-string type) "Return the rendered and localised description of TYPE, a service type." (and=> (service-type-description type) - (compose texi->plain-text P_))) + (compose texi->plain-text G_))) (define %service-type-metrics ;; Metrics used to estimate the relevance of a search result. diff --git a/guix/scripts/import.scm b/guix/scripts/import.scm index bd3cfd2dc3..2bca927d63 100644 --- a/guix/scripts/import.scm +++ b/guix/scripts/import.scm @@ -97,7 +97,9 @@ Run IMPORTER with ARGS.\n")) ((? list? expressions) (for-each (lambda (expr) (print expr) - (newline)) + ;; Two newlines: one after the closing paren, and + ;; one to leave a blank line. + (newline) (newline)) expressions)) (x (leave (G_ "'~a' import failed~%") importer)))) diff --git a/guix/scripts/import/cran.scm b/guix/scripts/import/cran.scm index 2934d4300a..5298f059f2 100644 --- a/guix/scripts/import/cran.scm +++ b/guix/scripts/import/cran.scm @@ -53,6 +53,9 @@ Import and convert the CRAN package for PACKAGE-NAME.\n")) (display (G_ " -s, --style=STYLE choose output style, either specification or variable")) (display (G_ " + -p, --license-prefix=PREFIX + add custom prefix to licenses")) + (display (G_ " -V, --version display version information and exit")) (newline) (show-bug-report-information)) @@ -74,6 +77,10 @@ Import and convert the CRAN package for PACKAGE-NAME.\n")) (lambda (opt name arg result) (alist-cons 'style (string->symbol arg) (alist-delete 'style result)))) + (option '(#\p "license-prefix") #t #f + (lambda (opt name arg result) + (alist-cons 'license-prefix arg + (alist-delete 'license-prefix result)))) (option '(#\r "recursive") #f #f (lambda (opt name arg result) (alist-cons 'recursive #t result))) @@ -95,7 +102,13 @@ Import and convert the CRAN package for PACKAGE-NAME.\n")) (('argument . value) value) (_ #f)) - (reverse opts)))) + (reverse opts))) + (prefix (assoc-ref opts 'license-prefix)) + (prefix-proc (if (string? prefix) + (lambda (symbol) + (string->symbol + (string-append prefix (symbol->string symbol)))) + identity))) (parameterize ((%input-style (assoc-ref opts 'style))) (match args ((spec) @@ -107,11 +120,13 @@ Import and convert the CRAN package for PACKAGE-NAME.\n")) (filter identity (cran-recursive-import name #:version version - #:repo (or (assoc-ref opts 'repo) 'cran))))) + #:repo (or (assoc-ref opts 'repo) 'cran) + #:license-prefix prefix-proc)))) ;; Single import (let ((sexp (cran->guix-package name #:version version - #:repo (or (assoc-ref opts 'repo) 'cran)))) + #:repo (or (assoc-ref opts 'repo) 'cran) + #:license-prefix prefix-proc))) (unless sexp (leave (G_ "failed to download description for package '~a'~%") name)) diff --git a/guix/scripts/offload.scm b/guix/scripts/offload.scm index 925325ef5f..578b3b9888 100644 --- a/guix/scripts/offload.scm +++ b/guix/scripts/offload.scm @@ -25,7 +25,7 @@ #:autoload (ssh auth) (userauth-public-key!) #:autoload (ssh session) (make-session connect! get-error - disconnect! session-set!) + disconnect! session-set! session-get) #:autoload (ssh version) (zlib-support?) #:use-module (guix config) #:use-module (guix records) @@ -34,7 +34,8 @@ send-files retrieve-files retrieve-files* remote-inferior report-guile-error) #:use-module (guix store) - #:autoload (guix inferior) (inferior-eval close-inferior inferior?) + #:autoload (guix inferior) (inferior-eval close-inferior + inferior? inferior-protocol-error?) #:autoload (guix derivations) (read-derivation-from-file derivation-file-name build-derivations) @@ -111,7 +112,7 @@ ;; A #f value tells the offload scheduler to disregard the load of the build ;; machine when selecting the best offload machine. (overload-threshold build-machine-overload-threshold ; inexact real between - (default 0.6)) ; 0.0 and 1.0 | #f + (default 0.8)) ; 0.0 and 1.0 | #f (parallel-builds build-machine-parallel-builds ; number (default 1)) (speed build-machine-speed ; inexact real @@ -473,6 +474,15 @@ logical cores available, to give a rough estimation of CPU usage. Return (vector-set! vec j (vector-ref vec (- i 1))) (loop (cons val result) (- i 1)))))))) +(define (remote-inferior* session) + "Like 'remote-inferior', but upon error return #f." + (or (guard (c ((inferior-protocol-error? c) #f)) + (remote-inferior session)) + (begin + (warning (G_ "failed to run 'guix repl' on machine '~a'~%") + (session-get session 'host)) + #f))) + (define (choose-build-machine machines) "Return two values: the best machine among MACHINES and its build slot (which must later be released with 'release-build-slot'), or #f and #f." @@ -511,7 +521,7 @@ slot (which must later be released with 'release-build-slot'), or #f and #f." ;; too costly to call it once for every machine. (let* ((session (false-if-exception (open-ssh-session best %short-timeout))) - (node (and session (remote-inferior session))) + (node (and session (remote-inferior* session))) (load (and node (node-load node))) (threshold (build-machine-overload-threshold best)) (space (and node (node-free-disk-space node)))) @@ -708,6 +718,11 @@ machine." (and (string=? (build-machine-name m1) (build-machine-name m2)) (= (build-machine-port m1) (build-machine-port m2)))) + (define (if-true proc) + (lambda args + (when (every ->bool args) + (apply proc args)))) + ;; A given build machine may appear several times (e.g., once for ;; "x86_64-linux" and a second time for "i686-linux"); test them only once. (let ((machines (filter pred @@ -718,12 +733,12 @@ machine." (let* ((names (map build-machine-name machines)) (sockets (map build-machine-daemon-socket machines)) (sessions (map (cut open-ssh-session <> %short-timeout) machines)) - (nodes (map remote-inferior sessions))) - (for-each assert-node-has-guix nodes names) - (for-each assert-node-repl nodes names) - (for-each assert-node-can-import sessions nodes names sockets) - (for-each assert-node-can-export sessions nodes names sockets) - (for-each close-inferior nodes) + (nodes (map remote-inferior* sessions))) + (for-each (if-true assert-node-has-guix) nodes names) + (for-each (if-true assert-node-repl) nodes names) + (for-each (if-true assert-node-can-import) sessions nodes names sockets) + (for-each (if-true assert-node-can-export) sessions nodes names sockets) + (for-each (if-true close-inferior) nodes) (for-each disconnect! sessions)))) (define (check-machine-status machine-file pred) @@ -743,10 +758,9 @@ machine." (define session (open-ssh-session machine %short-timeout)) - (match (remote-inferior session) + (match (remote-inferior* session) (#f - (warning (G_ "failed to run 'guix repl' on machine '~a'~%") - (build-machine-name machine))) + #f) ((? inferior? inferior) (let ((now (car (gettimeofday)))) (match (inferior-eval '(list (uname) diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm index 78b6978c92..f65642fb85 100644 --- a/guix/scripts/pack.scm +++ b/guix/scripts/pack.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2015, 2017, 2018, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2015, 2017-2022 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2017, 2018 Ricardo Wurmus <rekado@elephly.net> ;;; Copyright © 2018 Konrad Hinsen <konrad.hinsen@fastmail.net> ;;; Copyright © 2018 Chris Marusich <cmmarusich@gmail.com> @@ -33,7 +33,6 @@ #:use-module (guix store) #:use-module ((guix status) #:select (with-status-verbosity)) #:use-module ((guix self) #:select (make-config.scm)) - #:use-module (guix grafts) #:autoload (guix inferior) (inferior-package? inferior-package-name inferior-package-version) @@ -43,6 +42,7 @@ #:use-module (guix profiles) #:use-module (guix describe) #:use-module (guix derivations) + #:use-module (guix diagnostics) #:use-module (guix search-paths) #:use-module (guix build-system gnu) #:use-module (guix scripts build) @@ -60,9 +60,12 @@ #:use-module (srfi srfi-1) #:use-module (srfi srfi-9) #:use-module (srfi srfi-26) + #:use-module (srfi srfi-35) #:use-module (srfi srfi-37) #:use-module (ice-9 match) - #:export (self-contained-tarball + #:export (symlink-spec-option-parser + + self-contained-tarball debian-archive docker-image squashfs-image @@ -161,6 +164,36 @@ its source property." ((_) str) ((names ... _) (loop names)))))) +(define (symlink-spec-option-parser opt name arg result) + "A SRFI-37 option parser for the --symlink option. The symlink spec accepts +the link file name as its left-hand side value and its target as its +right-hand side value. The target must be a relative link." + ;; Note: Using 'string-split' allows us to handle empty + ;; TARGET (as in "/opt/guile=", meaning that /opt/guile is + ;; a symlink to the profile) correctly. + (match (string-split arg #\=) + ((source target) + (when (string-prefix? "/" target) + (raise-exception + (make-compound-condition + (formatted-message (G_ "symlink target is absolute: '~a'~%") target) + (condition + (&fix-hint (hint (format #f (G_ "The target of the symlink must be +relative rather than absolute, as it is relative to the profile created. +Perhaps the source and target components of the symlink spec were inverted? +Below is a valid example, where the @file{/usr/bin/env} symbolic link is to +target the profile's @file{bin/env} file: +@example +--symlink=/usr/bin/env=bin/env +@end example")))))))) + (let ((symlinks (assoc-ref result 'symlinks))) + (alist-cons 'symlinks + `((,source -> ,target) ,@symlinks) + (alist-delete 'symlinks result eq?)))) + (x + (leave (G_ "~a: invalid symlink specification~%") + arg)))) + ;;; ;;; Tarball format. @@ -227,8 +260,9 @@ its source property." `(,@(if (string=? parent "/") '() `((directory ,parent))) - (,source - -> ,(relative-file-name parent target))))))) + ;; Use a relative file name for compatibility with + ;; relocatable packs. + (,source -> ,(relative-file-name parent target))))))) (define directives ;; Fully-qualified symlinks. @@ -668,7 +702,6 @@ Valid compressors are: ~a~%") compressor-name %valid-compressors))) (guix build utils) (guix profiles) (ice-9 match) - ((oop goops) #:select (get-keyword)) (srfi srfi-1)) (define machine-type @@ -729,15 +762,20 @@ Valid compressors are: ~a~%") compressor-name %valid-compressors))) (copy-file #+data-tarball data-tarball-file-name) + (define (keyword-ref lst keyword) + (match (memq keyword lst) + ((_ value . _) value) + (#f #f))) + ;; Generate the control archive. (define control-file - (get-keyword #:control-file '#$extra-options)) + (keyword-ref '#$extra-options #:control-file)) (define postinst-file - (get-keyword #:postinst-file '#$extra-options)) + (keyword-ref '#$extra-options #:postinst-file)) (define triggers-file - (get-keyword #:triggers-file '#$extra-options)) + (keyword-ref '#$extra-options #:triggers-file)) (define control-tarball-file-name (string-append "control.tar" @@ -1209,20 +1247,7 @@ last resort for relocation." (lambda (opt name arg result) (alist-cons 'compressor (lookup-compressor arg) result))) - (option '(#\S "symlink") #t #f - (lambda (opt name arg result) - ;; Note: Using 'string-split' allows us to handle empty - ;; TARGET (as in "/opt/guile=", meaning that /opt/guile is - ;; a symlink to the profile) correctly. - (match (string-split arg (char-set #\=)) - ((source target) - (let ((symlinks (assoc-ref result 'symlinks))) - (alist-cons 'symlinks - `((,source -> ,target) ,@symlinks) - (alist-delete 'symlinks result eq?)))) - (x - (leave (G_ "~a: invalid symlink specification~%") - arg))))) + (option '(#\S "symlink") #t #f symlink-spec-option-parser) (option '("save-provenance") #f #f (lambda (opt name arg result) (alist-cons 'save-provenance? #t result))) @@ -1322,74 +1347,74 @@ Create a bundle of PACKAGE.\n")) (category development) (synopsis "create application bundles") - (define opts - (parse-command-line args %options (list %default-options))) - - (define maybe-package-argument - ;; Given an option pair, return a package, a package/output tuple, or #f. - (match-lambda - (('argument . spec) - (call-with-values - (lambda () - (specification->package+output spec)) - list)) - (('expression . exp) - (read/eval-package-expression exp)) - (x #f))) - - (define (manifest-from-args store opts) - (let* ((transform (options->transformation opts)) - (packages (map (match-lambda - (((? package? package) output) - (list (transform package) output)) - ((? package? package) - (list (transform package) "out"))) - (reverse - (filter-map maybe-package-argument opts)))) - (manifests (filter-map (match-lambda - (('manifest . file) file) - (_ #f)) - opts))) - (define with-provenance - (if (assoc-ref opts 'save-provenance?) - (lambda (manifest) - (map-manifest-entries - (lambda (entry) - (let ((entry (manifest-entry-with-provenance entry))) - (unless (assq 'provenance (manifest-entry-properties entry)) - (warning (G_ "could not determine provenance of package ~a~%") - (manifest-entry-name entry))) - entry)) - manifest)) - identity)) - - (with-provenance - (cond - ((and (not (null? manifests)) (not (null? packages))) - (leave (G_ "both a manifest and a package list were given~%"))) - ((not (null? manifests)) - (concatenate-manifests - (map (lambda (file) - (let ((user-module (make-user-module - '((guix profiles) (gnu))))) - (load* file user-module))) - manifests))) - (else - (packages->manifest packages)))))) - - (define (process-file-arg opts name) - ;; Validate that the file exists and return it as a <local-file> object, - ;; else #f. - (let ((value (assoc-ref opts name))) - (match value - ((and (? string?) (not (? file-exists?))) - (leave (G_ "file provided with option ~a does not exist: ~a~%") - (string-append "--" (symbol->string name)) value)) - ((? string?) - (local-file value)) - (#f #f)))) - (with-error-handling + (define opts + (parse-command-line args %options (list %default-options))) + + (define maybe-package-argument + ;; Given an option pair, return a package, a package/output tuple, or #f. + (match-lambda + (('argument . spec) + (call-with-values + (lambda () + (specification->package+output spec)) + list)) + (('expression . exp) + (read/eval-package-expression exp)) + (x #f))) + + (define (manifest-from-args store opts) + (let* ((transform (options->transformation opts)) + (packages (map (match-lambda + (((? package? package) output) + (list (transform package) output)) + ((? package? package) + (list (transform package) "out"))) + (reverse + (filter-map maybe-package-argument opts)))) + (manifests (filter-map (match-lambda + (('manifest . file) file) + (_ #f)) + opts))) + (define with-provenance + (if (assoc-ref opts 'save-provenance?) + (lambda (manifest) + (map-manifest-entries + (lambda (entry) + (let ((entry (manifest-entry-with-provenance entry))) + (unless (assq 'provenance (manifest-entry-properties entry)) + (warning (G_ "could not determine provenance of package ~a~%") + (manifest-entry-name entry))) + entry)) + manifest)) + identity)) + + (with-provenance + (cond + ((and (not (null? manifests)) (not (null? packages))) + (leave (G_ "both a manifest and a package list were given~%"))) + ((not (null? manifests)) + (concatenate-manifests + (map (lambda (file) + (let ((user-module (make-user-module + '((guix profiles) (gnu))))) + (load* file user-module))) + manifests))) + (else + (packages->manifest packages)))))) + + (define (process-file-arg opts name) + ;; Validate that the file exists and return it as a <local-file> object, + ;; else #f. + (let ((value (assoc-ref opts name))) + (match value + ((and (? string?) (not (? file-exists?))) + (leave (G_ "file provided with option ~a does not exist: ~a~%") + (string-append "--" (symbol->string name)) value)) + ((? string?) + (local-file value)) + (#f #f)))) + (with-store store (with-status-verbosity (assoc-ref opts 'verbosity) ;; Set the build options before we do anything else. diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm index 134337b13e..2f774621bb 100644 --- a/guix/scripts/package.scm +++ b/guix/scripts/package.scm @@ -34,7 +34,6 @@ #:use-module ((guix status) #:select (with-status-verbosity)) #:use-module ((guix build syscalls) #:select (terminal-rows)) #:use-module (guix store) - #:use-module (guix grafts) #:use-module (guix derivations) #:use-module (guix packages) #:use-module (guix profiles) diff --git a/guix/scripts/publish.scm b/guix/scripts/publish.scm index 3bf3bd9c7c..6307ae54bb 100644 --- a/guix/scripts/publish.scm +++ b/guix/scripts/publish.scm @@ -4,7 +4,7 @@ ;;; Copyright © 2015-2022 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2020 Maxim Cournoyer <maxim.cournoyer@gmail.com> ;;; Copyright © 2021 Simon Tournier <zimon.toutoune@gmail.com> -;;; Copyright © 2021 Mathieu Othacehe <othacehe@gnu.org> +;;; Copyright © 2021, 2022 Mathieu Othacehe <othacehe@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -375,14 +375,28 @@ References: ~a~%" compression))) compressions)))) +;; Custom header to indicate that baking is in progress. +(declare-opaque-header! "X-Baking") + (define* (not-found request - #:key (phrase "Resource not found") + #:key + baking? + (phrase "Resource not found") ttl) "Render 404 response for REQUEST." + (format #t "-> ~a ~a: 404~a~%" + (request-method request) + (uri-path (request-uri request)) + (if baking? " (baking)" "")) (values (build-response #:code 404 - #:headers (if ttl - `((cache-control (max-age . ,ttl))) - '())) + #:headers + (append + (if ttl + `((cache-control (max-age . ,ttl))) + '()) + (if baking? + '((x-baking . "1")) + '()))) (string-append phrase ": " (uri-path (request-uri request))))) @@ -587,6 +601,7 @@ requested using POOL." #:nar-path nar-path #:compressions compressions) (not-found request + #:baking? #t #:phrase "We're baking it" #:ttl 300))) ;should be available within 5m (else diff --git a/guix/scripts/pull.scm b/guix/scripts/pull.scm index 19224cf70b..7b6c58dbc3 100644 --- a/guix/scripts/pull.scm +++ b/guix/scripts/pull.scm @@ -31,7 +31,6 @@ #:use-module (guix derivations) #:use-module (guix profiles) #:use-module (guix gexp) - #:use-module (guix grafts) #:use-module (guix memoization) #:use-module (guix monads) #:use-module (guix channels) diff --git a/guix/scripts/refresh.scm b/guix/scripts/refresh.scm index 14329751f8..6498d73c2b 100644 --- a/guix/scripts/refresh.scm +++ b/guix/scripts/refresh.scm @@ -9,6 +9,7 @@ ;;; Copyright © 2019 Ricardo Wurmus <rekado@elephly.net> ;;; Copyright © 2020 Simon Tournier <zimon.toutoune@gmail.com> ;;; Copyright © 2021 Sarah Morgensen <iskarian@mgsn.dev> +;;; Copyright © 2022 Hartmut Goebel <h.goebel@crazy-compilers.com> ;;; ;;; This file is part of GNU Guix. ;;; @@ -46,6 +47,7 @@ #:use-module (ice-9 vlist) #:use-module (ice-9 format) #:use-module (srfi srfi-1) + #:use-module (srfi srfi-9) #:use-module (srfi srfi-26) #:use-module (srfi srfi-37) #:use-module (srfi srfi-71) @@ -181,9 +183,31 @@ specified with `--select'.\n")) (newline) (show-bug-report-information)) -(define (options->packages opts) - "Return the list of packages requested by OPTS, honoring options like -'--recursive'." + +;;; +;;; Utilities. +;;; + +(define-record-type <update-spec> + (%update-spec package version) + update? + (package update-spec-package) + (version update-spec-version)) + +(define* (update-spec package #:optional version) + (%update-spec package version)) + +(define (update-specification->update-spec spec) + "Given SPEC, a package name like \"guile@2.0=2.0.8\", return a <update> +record with two fields: the package to upgrade, and the target version." + (match (string-rindex spec #\=) + (#f (update-spec (specification->package spec) #f)) + (idx (update-spec (specification->package (substring spec 0 idx)) + (substring spec (1+ idx)))))) + +(define (options->update-specs opts) + "Return the list of <update-spec> records requested by OPTS, honoring +options like '--recursive'." (define core-package? (let* ((input->package (match-lambda ((name (? package? package) _ ...) package) @@ -218,41 +242,43 @@ update would trigger a complete rebuild." (_ (cons package lst))))) - (define args-packages - ;; Packages explicitly passed as command-line arguments. - (match (filter-map (match-lambda + (define update-specs + ;; Update specs explicitly passed as command-line arguments. + (match (append-map (match-lambda (('argument . spec) ;; Take either the specified version or the ;; latest one. - (specification->package spec)) + (list (update-specification->update-spec spec))) (('expression . exp) - (read/eval-package-expression exp)) - (_ #f)) + (list (update-spec (read/eval-package-expression exp)))) + (('manifest . manifest) + (map update-spec (packages-from-manifest manifest))) + (_ + '())) opts) (() ;default to all packages (let ((select? (match (assoc-ref opts 'select) ('core core-package?) ('non-core (negate core-package?)) (_ (const #t))))) - (fold-packages (lambda (package result) - (if (select? package) - (keep-newest package result) - result)) - '()))) + (map update-spec + (fold-packages (lambda (package result) + (if (select? package) + (keep-newest package result) + result)) + '())))) (some ;user-specified packages some))) - (define packages - (match (assoc-ref opts 'manifest) - (#f args-packages) - ((? string? file) (packages-from-manifest file)))) - (if (assoc-ref opts 'recursive?) - (mlet %store-monad ((edges (node-edges %bag-node-type - (all-packages)))) - (return (node-transitive-edges packages edges))) + (mlet* %store-monad ((edges (node-edges %bag-node-type (all-packages))) + (packages -> (node-transitive-edges + (map update-spec-package update-specs) + edges))) + ;; FIXME: The 'version' field of each update spec is lost. + (return (map update-spec packages))) (with-monad %store-monad - (return packages)))) + (return update-specs)))) ;;; @@ -298,7 +324,7 @@ update would trigger a complete rebuild." (G_ "no updater for ~a~%") (package-name package))) -(define* (update-package store package updaters +(define* (update-package store package version updaters #:key (key-download 'interactive) warn?) "Update the source file that defines PACKAGE with the new version. KEY-DOWNLOAD specifies a download policy for missing OpenPGP keys; allowed @@ -307,7 +333,7 @@ warn about packages that have no matching updater." (if (lookup-updater package updaters) (let ((version output source (package-update store package updaters - #:key-download key-download)) + #:key-download key-download #:version version)) (loc (or (package-field-location package 'version) (package-location package)))) (when version @@ -361,10 +387,15 @@ downloaded and authenticated; not updating~%") (when warn? (warn-no-updater package)))) -(define* (check-for-package-update package updaters #:key warn?) - "Check whether an update is available for PACKAGE and print a message. When -WARN? is true and no updater exists for PACKAGE, print a warning." - (match (package-latest-release package updaters) +(define* (check-for-package-update update-spec updaters #:key warn?) + "Check whether UPDATE-SPEC is feasible, and print a message. +When WARN? is true and no updater exists for PACKAGE, print a warning." + (define package + (update-spec-package update-spec)) + + (match (package-latest-release package updaters + #:version + (update-spec-version update-spec)) ((? upstream-source? source) (let ((loc (or (package-field-location package 'version) (package-location package)))) @@ -382,23 +413,34 @@ WARN? is true and no updater exists for PACKAGE, print a warning." (package-version package) (package-name package)))) (else - (when warn? - (warning loc - (G_ "~a is greater than \ + (if (update-spec-version update-spec) + (info loc + (G_ "~a would be downgraded from ~a to ~a~%") + (package-name package) + (package-version package) + (upstream-source-version source)) + (when warn? + (warning loc + (G_ "~a is greater than \ the latest known version of ~a (~a)~%") - (package-version package) - (package-name package) - (upstream-source-version source))))))) + (package-version package) + (package-name package) + (upstream-source-version source)))))))) (#f (when warn? ;; Distinguish between "no updater" and "failing updater." (match (lookup-updater package updaters) ((? upstream-updater? updater) - (warning (package-location package) - (G_ "'~a' updater failed to determine available \ + (if (update-spec-version update-spec) + (warning (G_ "'~a' updater failed to find version ~a of '~a'~%") + (upstream-updater-name updater) + (update-spec-version update-spec) + (package-name package)) + (warning (package-location package) + (G_ "'~a' updater failed to determine available \ releases for ~a~%") - (upstream-updater-name updater) - (package-name package))) + (upstream-updater-name updater) + (package-name package)))) (#f (warn-no-updater package))))))) @@ -540,12 +582,12 @@ all are dependent packages: ~{~a~^ ~}~%") (with-error-handling (with-store store (run-with-store store - (mlet %store-monad ((packages (options->packages opts))) + (mlet %store-monad ((update-specs (options->update-specs opts))) (cond (list-dependent? - (list-dependents packages)) + (list-dependents (map update-spec-package update-specs))) (list-transitive? - (list-transitive packages)) + (list-transitive (map update-spec-package update-specs))) (update? (parameterize ((%openpgp-key-server (or (assoc-ref opts 'key-server) @@ -558,13 +600,17 @@ all are dependent packages: ~{~a~^ ~}~%") (string-append (config-directory) "/upstream/trustedkeys.kbx")))) (for-each - (cut update-package store <> updaters - #:key-download key-download - #:warn? warn?) - packages) + (lambda (update) + (update-package store + (update-spec-package update) + (update-spec-version update) + updaters + #:key-download key-download + #:warn? warn?)) + update-specs) (return #t))) (else (for-each (cut check-for-package-update <> updaters #:warn? warn?) - packages) + update-specs) (return #t))))))))) diff --git a/guix/scripts/repl.scm b/guix/scripts/repl.scm index 50d18c7760..787c63d48e 100644 --- a/guix/scripts/repl.scm +++ b/guix/scripts/repl.scm @@ -52,12 +52,19 @@ (option '(#\t "type") #t #f (lambda (opt name arg result) (alist-cons 'type (string->symbol arg) result))) + (option '("list-types") #f #f + (lambda (opt name arg result) + (display (string-join '("guile" "machine") "\n" 'suffix)) + (exit 0))) (option '("listen") #t #f (lambda (opt name arg result) (alist-cons 'listen arg result))) (option '(#\q) #f #f (lambda (opt name arg result) (alist-cons 'ignore-dot-guile? #t result))) + (option '(#\i "interactive") #f #f + (lambda (opt name arg result) + (alist-cons 'interactive? #t result))) (option '(#\L "load-path") #t #f (lambda (opt name arg result) ;; XXX: Imperatively modify the search paths. @@ -71,6 +78,8 @@ In the Guix execution environment, run FILE as a Guile script with command-line arguments ARGS. If no FILE is given, start a Guile REPL.\n")) (display (G_ " + --list-types display REPL types and exit")) + (display (G_ " -t, --type=TYPE start a REPL of the given TYPE")) (display (G_ " --listen=ENDPOINT listen to ENDPOINT instead of standard input")) @@ -78,6 +87,9 @@ command-line arguments ARGS. If no FILE is given, start a Guile REPL.\n")) -q inhibit loading of ~/.guile")) (newline) (display (G_ " + -i, --interactive launch REPL after evaluating FILE")) + (newline) + (display (G_ " -L, --load-path=DIR prepend DIR to the package module search path")) (newline) (display (G_ " @@ -190,7 +202,7 @@ call THUNK." ;; file in %LOAD-PATH. Thus, pass (getcwd) instead of ".". (load-in-vicinity (getcwd) (car script))))) - (when (null? script) + (when (or (null? script) (assoc-ref opts 'interactive?)) ;; Start REPL (let ((type (assoc-ref opts 'type))) (call-with-connection (assoc-ref opts 'listen) diff --git a/guix/scripts/shell.scm b/guix/scripts/shell.scm index c115a00320..64b5c2e8e9 100644 --- a/guix/scripts/shell.scm +++ b/guix/scripts/shell.scm @@ -20,7 +20,8 @@ #:use-module (guix ui) #:use-module ((guix diagnostics) #:select (location)) #:use-module (guix scripts environment) - #:autoload (guix scripts build) (show-build-options-help) + #:autoload (guix scripts build) (show-build-options-help + show-native-build-options-help) #:autoload (guix transformations) (options->transformation transformation-option-key? show-transformation-options-help) @@ -68,11 +69,16 @@ interactive shell in that environment.\n")) --rebuild-cache rebuild cached environment, if any")) (display (G_ " --export-manifest print a manifest for the given options")) + (display (G_ " + -F, --emulate-fhs for containers, emulate the Filesystem Hierarchy + Standard (FHS)")) (show-environment-options-help) (newline) (show-build-options-help) (newline) + (show-native-build-options-help) + (newline) (show-transformation-options-help) (newline) (display (G_ " @@ -136,7 +142,11 @@ interactive shell in that environment.\n")) (alist-cons 'explicit-loading? #t result))) (option '("rebuild-cache") #f #f (lambda (opt name arg result) - (alist-cons 'rebuild-cache? #t result)))) + (alist-cons 'rebuild-cache? #t result))) + + (option '(#\F "emulate-fhs") #f #f + (lambda (opt name arg result) + (alist-cons 'emulate-fhs? #t result)))) (filter-map (lambda (opt) (and (not (any (lambda (name) (member name to-remove)) @@ -157,8 +167,18 @@ interactive shell in that environment.\n")) ;; The '--' token is used to separate the command to run from the rest of ;; the operands. (let ((args command (break (cut string=? "--" <>) args))) - (let ((opts (parse-command-line args %options (list %default-options) - #:argument-handler handle-argument))) + (let* ((args-parsed (parse-command-line args %options (list %default-options) + #:argument-handler handle-argument)) + ;; For an FHS-container, add the (hidden) package glibc-for-fhs + ;; which uses the global cache at /etc/ld.so.cache. We handle + ;; adding this package here to ensure it will always appear in the + ;; container as it is the first package in OPTS. + (opts (if (assoc-ref args-parsed 'emulate-fhs?) + (alist-cons 'expression + '(ad-hoc-package + "(@@ (gnu packages base) glibc-for-fhs)") + args-parsed) + args-parsed))) (options-with-caching (auto-detect-manifest (match command @@ -517,43 +537,44 @@ concatenates MANIFESTS, a list of expressions." (category development) (synopsis "spawn one-off software environments") - (define (cache-entries directory) - (filter-map (match-lambda - ((or "." "..") #f) - (file (string-append directory "/" file))) - (or (scandir directory) '()))) - - (define* (entry-expiration file) - ;; Return the time at which FILE, a cached profile, is considered expired. - (match (false-if-exception (lstat file)) - (#f 0) ;FILE may have been deleted in the meantime - (st (+ (stat:atime st) (* 60 60 24 7))))) - - (define opts - (parse-args args)) - - (define interactive? - (not (assoc-ref opts 'exec))) - - (if (assoc-ref opts 'check?) - (record-hint 'shell-check) - (when (and interactive? - (not (hint-given? 'shell-check)) - (not (assoc-ref opts 'container?)) - (not (assoc-ref opts 'search-paths))) - (display-hint (G_ "Consider passing the @option{--check} option once + (with-error-handling + (define (cache-entries directory) + (filter-map (match-lambda + ((or "." "..") #f) + (file (string-append directory "/" file))) + (or (scandir directory) '()))) + + (define* (entry-expiration file) + ;; Return the time at which FILE, a cached profile, is considered expired. + (match (false-if-exception (lstat file)) + (#f 0) ;FILE may have been deleted in the meantime + (st (+ (stat:atime st) (* 60 60 24 7))))) + + (define opts + (parse-args args)) + + (define interactive? + (not (assoc-ref opts 'exec))) + + (if (assoc-ref opts 'check?) + (record-hint 'shell-check) + (when (and interactive? + (not (hint-given? 'shell-check)) + (not (assoc-ref opts 'container?)) + (not (assoc-ref opts 'search-paths))) + (display-hint (G_ "Consider passing the @option{--check} option once to make sure your shell does not clobber environment variables."))) ) - ;; Clean the cache in EXIT-HOOK so that (1) it happens after potential use - ;; of cached profiles, and (2) cleanup actually happens, even when - ;; 'guix-environment*' calls 'exit'. - (add-hook! exit-hook - (lambda _ - (maybe-remove-expired-cache-entries - (%profile-cache-directory) - cache-entries - #:entry-expiration entry-expiration))) - - (if (assoc-ref opts 'export-manifest?) - (export-manifest opts (current-output-port)) - (guix-environment* opts))) + ;; Clean the cache in EXIT-HOOK so that (1) it happens after potential use + ;; of cached profiles, and (2) cleanup actually happens, even when + ;; 'guix-environment*' calls 'exit'. + (add-hook! exit-hook + (lambda _ + (maybe-remove-expired-cache-entries + (%profile-cache-directory) + cache-entries + #:entry-expiration entry-expiration))) + + (if (assoc-ref opts 'export-manifest?) + (export-manifest opts (current-output-port)) + (guix-environment* opts)))) diff --git a/guix/scripts/size.scm b/guix/scripts/size.scm index 5bb970443c..48b8ecc881 100644 --- a/guix/scripts/size.scm +++ b/guix/scripts/size.scm @@ -24,7 +24,6 @@ #:use-module (guix store) #:use-module (guix monads) #:use-module (guix combinators) - #:use-module (guix grafts) #:use-module (guix packages) #:use-module (guix derivations) #:use-module (gnu packages) diff --git a/guix/scripts/style.scm b/guix/scripts/style.scm index c0b9ea1a28..fa7175fb16 100644 --- a/guix/scripts/style.scm +++ b/guix/scripts/style.scm @@ -335,13 +335,15 @@ PACKAGE." (define* (format-whole-file file #:rest rest) "Reformat all of FILE." - (let ((lst (call-with-input-file file read-with-comments/sequence))) - (with-atomic-file-output file - (lambda (port) - (apply pretty-print-with-comments/splice port lst - #:format-comment canonicalize-comment - #:format-vertical-space canonicalize-vertical-space - rest))))) + (with-fluids ((%default-port-encoding "UTF-8")) + (let ((lst (call-with-input-file file read-with-comments/sequence + #:guess-encoding #t))) + (with-atomic-file-output file + (lambda (port) + (apply pretty-print-with-comments/splice port lst + #:format-comment canonicalize-comment + #:format-vertical-space canonicalize-vertical-space + rest)))))) ;;; diff --git a/guix/scripts/substitute.scm b/guix/scripts/substitute.scm index cdf591ac4d..fedb33019d 100755 --- a/guix/scripts/substitute.scm +++ b/guix/scripts/substitute.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2013-2022 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2013-2023 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2014 Nikita Karetnikov <nikita@karetnikov.org> ;;; Copyright © 2018 Kyle Meyer <kyle@kyleam.com> ;;; Copyright © 2020 Christopher Baines <mail@cbaines.net> @@ -366,7 +366,7 @@ authorized substitutes." When FRESH? is true, delete any cached connections for URI and open a new one. Return #f if URI's scheme is 'file' or #f. -When true, TIMEOUT is the maximum number of milliseconds to wait for +When true, TIMEOUT is the maximum number of seconds to wait for connection establishment. When VERIFY-CERTIFICATE? is true, verify HTTPS server certificates." (define host (uri-host uri)) @@ -437,20 +437,13 @@ server certificates." "Bind PORT with EXP... to a socket connected to URI." (call-with-cached-connection uri (lambda (port) exp ...))) -(define* (process-substitution port store-item destination - #:key cache-urls acl - deduplicate? print-build-trace?) - "Substitute STORE-ITEM (a store file name) from CACHE-URLS, and write it to -DESTINATION as a nar file. Verify the substitute against ACL, and verify its -hash against what appears in the narinfo. When DEDUPLICATE? is true, and if -DESTINATION is in the store, deduplicate its files. Print a status line to -PORT." - (define narinfo - (lookup-narinfo cache-urls store-item - (if (%allow-unauthenticated-substitutes?) - (const #t) - (cut valid-narinfo? <> acl)))) - +(define* (download-nar narinfo destination + #:key status-port + deduplicate? print-build-trace?) + "Download the nar prescribed in NARINFO, which is assumed to be authentic +and authorized, and write it to DESTINATION. When DEDUPLICATE? is true, and +if DESTINATION is in the store, deduplicate its files. Print a status line to +STATUS-PORT." (define destination-in-store? (string-prefix? (string-append (%store-prefix) "/") destination)) @@ -467,33 +460,24 @@ PORT." (let ((port (open-file (uri-path uri) "r0b"))) (values port (stat:size (stat port))))) ((http https) - (guard (c ((http-get-error? c) - (leave (G_ "download from '~a' failed: ~a, ~s~%") - (uri->string (http-get-error-uri c)) - (http-get-error-code c) - (http-get-error-reason c)))) - ;; Test this with: - ;; sudo tc qdisc add dev eth0 root netem delay 1500ms - ;; and then cancel with: - ;; sudo tc qdisc del dev eth0 root - (with-timeout %fetch-timeout - (begin - (warning (G_ "while fetching ~a: server is somewhat slow~%") - (uri->string uri)) - (warning (G_ "try `--no-substitutes' if the problem persists~%"))) - (with-cached-connection uri port - (http-fetch uri #:text? #f - #:port port - #:keep-alive? #t - #:buffered? #f))))) + ;; Test this with: + ;; sudo tc qdisc add dev eth0 root netem delay 1500ms + ;; and then cancel with: + ;; sudo tc qdisc del dev eth0 root + (with-timeout %fetch-timeout + (begin + (warning (G_ "while fetching ~a: server is somewhat slow~%") + (uri->string uri)) + (warning (G_ "try `--no-substitutes' if the problem persists~%"))) + (with-cached-connection uri port + (http-fetch uri #:text? #f + #:port port + #:keep-alive? #t + #:buffered? #f)))) (else (leave (G_ "unsupported substitute URI scheme: ~a~%") (uri->string uri))))) - (unless narinfo - (leave (G_ "no valid substitute for '~a'~%") - store-item)) - (let ((uri compression file-size (narinfo-best-uri narinfo #:fast-decompression? @@ -575,14 +559,109 @@ PORT." (let ((actual (get-hash))) (if (bytevector=? actual expected) ;; Tell the daemon that we're done. - (format port "success ~a ~a~%" + (format status-port "success ~a ~a~%" (narinfo-hash narinfo) (narinfo-size narinfo)) ;; The actual data has a different hash than that in NARINFO. - (format port "hash-mismatch ~a ~a ~a~%" + (format status-port "hash-mismatch ~a ~a ~a~%" (hash-algorithm-name algorithm) (bytevector->nix-base32-string expected) (bytevector->nix-base32-string actual))))))) +(define system-error? + (let ((kind-and-args? (exception-predicate &exception-with-kind-and-args))) + (lambda (exception) + "Return true if EXCEPTION is a Guile 'system-error exception." + (and (kind-and-args? exception) + (eq? 'system-error (exception-kind exception)))))) + +(define network-error? + (let ((kind-and-args? (exception-predicate &exception-with-kind-and-args))) + (lambda (exception) + "Return true if EXCEPTION denotes a networking error." + (or (and (system-error? exception) + (let ((errno (system-error-errno + (cons 'system-error (exception-args exception))))) + (memv errno (list ECONNRESET ECONNABORTED + ECONNREFUSED EHOSTUNREACH + ENOENT)))) ;for "file://" + (and (kind-and-args? exception) + (memq (exception-kind exception) + '(gnutls-error getaddrinfo-error))) + (and (http-get-error? exception) + (begin + (warning (G_ "download from '~a' failed: ~a, ~s~%") + (uri->string (http-get-error-uri exception)) + (http-get-error-code exception) + (http-get-error-reason exception)) + #t)))))) + +(define* (process-substitution/fallback port narinfo destination + #:key cache-urls acl + deduplicate? print-build-trace?) + "Attempt to substitute NARINFO, which is assumed to be authorized or +equivalent, by trying to download its nar from each entry in CACHE-URLS. + +This can be less efficient than 'lookup-narinfo', which stops at the first +entry that provides a valid narinfo, but it makes sure we eventually find a +way to download the nar." + ;; Note: Keep NARINFO's uri-base in CACHE-URLS: that lets us retry in case + ;; this was a transient issue. + (let loop ((cache-urls cache-urls)) + (match cache-urls + (() + (leave (G_ "failed to find alternative substitute for '~a'~%") + (narinfo-path narinfo))) + ((cache-url rest ...) + (match (lookup-narinfos cache-url + (list (narinfo-path narinfo)) + #:open-connection + open-connection-for-uri/cached) + ((alternate) + (if (or (equivalent-narinfo? narinfo alternate) + (valid-narinfo? alternate acl) + (%allow-unauthenticated-substitutes?)) + (guard (c ((network-error? c) (loop rest))) + (download-nar alternate destination + #:status-port port + #:deduplicate? deduplicate? + #:print-build-trace? print-build-trace?)) + (loop rest))) + (() + (loop rest))))))) + +(define* (process-substitution port store-item destination + #:key cache-urls acl + deduplicate? print-build-trace?) + "Substitute STORE-ITEM (a store file name) from CACHE-URLS, and write it to +DESTINATION as a nar file. Verify the substitute against ACL, and verify its +hash against what appears in the narinfo. When DEDUPLICATE? is true, and if +DESTINATION is in the store, deduplicate its files. Print a status line to +PORT." + (define narinfo + (lookup-narinfo cache-urls store-item + (if (%allow-unauthenticated-substitutes?) + (const #t) + (cut valid-narinfo? <> acl)))) + + (unless narinfo + (leave (G_ "no valid substitute for '~a'~%") + store-item)) + + (guard (c ((network-error? c) + (format (current-error-port) + (G_ "retrying download of '~a' with other substitute URLs...~%") + store-item) + (process-substitution/fallback port narinfo destination + #:cache-urls cache-urls + #:acl acl + #:deduplicate? deduplicate? + #:print-build-trace? + print-build-trace?))) + (download-nar narinfo destination + #:status-port port + #:deduplicate? deduplicate? + #:print-build-trace? print-build-trace?))) + ;;; ;;; Entry point. @@ -627,10 +706,12 @@ substitutes may be unavailable\n"))))) (string-drop option=value (+ 1 equal-sign)))))) (string-tokenize newline-separated %not-newline))))) -(define (find-daemon-option option) - "Return the value of build daemon option OPTION, or #f if it could not be +(define find-daemon-option + (let ((options (delay (daemon-options)))) + (lambda (option) + "Return the value of build daemon option OPTION, or #f if it could not be found." - (assoc-ref (daemon-options) option)) + (assoc-ref (force options) option)))) (define %default-substitute-urls (match (and=> (or (find-daemon-option "untrusted-substitute-urls") ;client diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm index 4bcf789703..6fd915cb5e 100644 --- a/guix/scripts/system.scm +++ b/guix/scripts/system.scm @@ -38,7 +38,6 @@ (sqlite-register store-database-file call-with-database) #:autoload (guix build store-copy) (copy-store-item) #:use-module (guix describe) - #:use-module (guix grafts) #:use-module (guix gexp) #:use-module (guix derivations) #:use-module (guix diagnostics) @@ -92,6 +91,7 @@ #:use-module (ice-9 match) #:use-module (rnrs bytevectors) #:export (guix-system + read-operating-system service-node-type shepherd-service-node-type)) @@ -107,6 +107,11 @@ (gnu services) (gnu system shadow)))) +;; Note: The procedure below is used in external projects such as Emacs-Guix. +(define (read-operating-system file) + "Read the operating-system declaration from FILE and return it." + (load* file %user-module)) + ;;; ;;; Installation. @@ -837,7 +842,10 @@ static checks." (check-mapped-devices os) (when (zero? (getuid)) (check-file-system-availability (operating-system-file-systems os)) - (check-initrd-modules os))) + (unless (%current-target-system) + ;; Skip the check if the user is making use of --target, as it cannot + ;; be checked against the running kernel. + (check-initrd-modules os)))) (mlet* %store-monad ((sys (system-derivation-for-action image action @@ -1040,7 +1048,7 @@ Some ACTIONS support additional ARGS.\n")) (newline) (display (G_ " --graph-backend=BACKEND - use BACKEND for 'extension-graphs' and 'shepherd-graph'")) + use BACKEND for 'extension-graph' and 'shepherd-graph'")) (newline) (display (G_ " -I, --list-installed[=REGEXP] diff --git a/guix/scripts/system/reconfigure.scm b/guix/scripts/system/reconfigure.scm index f12bc2db88..9948df0ca6 100644 --- a/guix/scripts/system/reconfigure.scm +++ b/guix/scripts/system/reconfigure.scm @@ -41,9 +41,9 @@ #:use-module (guix diagnostics) #:use-module (ice-9 match) #:use-module (srfi srfi-1) - #:use-module (srfi srfi-11) #:use-module (srfi srfi-34) #:use-module (srfi srfi-35) + #:use-module (srfi srfi-71) #:use-module ((guix config) #:select (%guix-package-name)) #:export (switch-system-program switch-to-system @@ -186,8 +186,8 @@ services as defined by OS." #:target-type shepherd-root-service-type)))) (mlet* %store-monad ((live-services (running-services eval))) - (let*-values (((to-unload to-restart) - (shepherd-service-upgrade live-services target-services))) + (let ((to-unload to-restart + (shepherd-service-upgrade live-services target-services))) (let* ((to-unload (map live-service-canonical-name to-unload)) (to-restart (map shepherd-service-canonical-name to-restart)) (running (map live-service-canonical-name @@ -349,14 +349,12 @@ to commits of channels in NEW." (channel-name old))) new))) (and new - (let-values (((checkout commit relation) - (update-cached-checkout - (channel-url new) - #:ref - `(commit . ,(channel-commit new)) - #:starting-commit - (channel-commit old) - #:check-out? #f))) + (let ((checkout commit relation + (update-cached-checkout + (channel-url new) + #:ref `(commit . ,(channel-commit new)) + #:starting-commit (channel-commit old) + #:check-out? #f))) (list new (channel-commit old) (channel-commit new) relation))))) diff --git a/guix/scripts/system/search.scm b/guix/scripts/system/search.scm index 44f00194cd..d978884518 100644 --- a/guix/scripts/system/search.scm +++ b/guix/scripts/system/search.scm @@ -127,7 +127,7 @@ procedure that may return a colorized version of its argument." (parameterize ((%text-width width*)) (texi->plain-text (string-append "description: " - (or (and=> (service-type-description type) P_) + (or (and=> (service-type-description type) G_) "")))) #\newline))))) @@ -144,7 +144,7 @@ procedure that may return a colorized version of its argument." (define (service-type-description-string type) "Return the rendered and localised description of TYPE, a service type." (and=> (service-type-description type) - (compose texi->plain-text P_))) + (compose texi->plain-text G_))) (define %service-type-metrics ;; Metrics used to estimate the relevance of a search result. diff --git a/guix/scripts/weather.scm b/guix/scripts/weather.scm index f46c11b1a5..dc27f81984 100644 --- a/guix/scripts/weather.scm +++ b/guix/scripts/weather.scm @@ -29,7 +29,6 @@ #:use-module (guix progress) #:use-module (guix monads) #:use-module (guix store) - #:use-module (guix grafts) #:use-module (guix gexp) #:use-module (guix colors) #:use-module ((guix build syscalls) #:select (terminal-columns)) diff --git a/guix/self.scm b/guix/self.scm index fc80e78804..93019e1c64 100644 --- a/guix/self.scm +++ b/guix/self.scm @@ -62,7 +62,7 @@ ("guile-lzlib" (ref '(gnu packages guile) 'guile-lzlib)) ("guile-zstd" (ref '(gnu packages guile) 'guile-zstd)) ("guile-gcrypt" (ref '(gnu packages gnupg) 'guile-gcrypt)) - ("gnutls" (ref '(gnu packages tls) 'gnutls)) + ("guile-gnutls" (ref '(gnu packages tls) 'guile-gnutls)) ("disarchive" (ref '(gnu packages backup) 'disarchive)) ("guile-lzma" (ref '(gnu packages guile) 'guile-lzma)) ("gzip" (ref '(gnu packages compression) 'gzip)) @@ -787,8 +787,8 @@ itself." (define guile-semver (specification->package "guile-semver")) - (define gnutls - (specification->package "gnutls")) + (define guile-gnutls + (specification->package "guile-gnutls")) (define disarchive (specification->package "disarchive")) @@ -798,7 +798,7 @@ itself." (define dependencies (append-map transitive-package-dependencies - (list guile-gcrypt gnutls guile-git guile-avahi + (list guile-gcrypt guile-gnutls guile-git guile-avahi guile-json guile-semver guile-ssh guile-sqlite3 guile-lib guile-zlib guile-lzlib guile-zstd))) @@ -1090,6 +1090,12 @@ itself." (scheme-file "config.scm" #~(;; The following expressions get spliced. (#$defmod (guix config) + + ;; Mark it as non-declarative to prevent cross-module + ;; inlining that could lead to inlining %GUIX-VERSION in + ;; (guix ui). + #:declarative? #f + #:export (%guix-package-name %guix-version %guix-bug-report-address diff --git a/guix/store.scm b/guix/store.scm index 4d21c5ff1a..a36dce416e 100644 --- a/guix/store.scm +++ b/guix/store.scm @@ -182,6 +182,11 @@ interned-file interned-file-tree + %graft? + without-grafting + set-grafting + grafting? + %store-prefix store-path output-path @@ -2173,6 +2178,37 @@ connection, and return the result." ;;; +;;; Whether to enable grafts. +;;; + +(define %graft? + ;; Whether to honor package grafts by default. + (make-parameter #t)) + +(define (call-without-grafting thunk) + (lambda (store) + (values (parameterize ((%graft? #f)) + (run-with-store store (thunk))) + store))) + +(define-syntax-rule (without-grafting mexp ...) + "Bind monadic expressions MEXP in a dynamic extent where '%graft?' is +false." + (call-without-grafting (lambda () (mbegin %store-monad mexp ...)))) + +(define-inlinable (set-grafting enable?) + ;; This monadic procedure enables grafting when ENABLE? is true, and + ;; disables it otherwise. It returns the previous setting. + (lambda (store) + (values (%graft? enable?) store))) + +(define-inlinable (grafting?) + ;; Return a Boolean indicating whether grafting is enabled. + (lambda (store) + (values (%graft?) store))) + + +;;; ;;; Store paths. ;;; diff --git a/guix/store/database.scm b/guix/store/database.scm index 8d08def833..e664015673 100644 --- a/guix/store/database.scm +++ b/guix/store/database.scm @@ -2,6 +2,7 @@ ;;; Copyright © 2017, 2019 Caleb Ristvedt <caleb.ristvedt@cune.org> ;;; Copyright © 2018, 2020, 2021 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2020 Jan (janneke) Nieuwenhuizen <janneke@gnu.org> +;;; Copyright © 2022 Efraim Flashner <efraim@flashner.co.il> ;;; ;;; This file is part of GNU Guix. ;;; @@ -45,7 +46,8 @@ sqlite-register register-items %epoch - reset-timestamps)) + reset-timestamps + vacuum-database)) ;;; Code for working with the store database directly. @@ -438,3 +440,8 @@ typically by adding them as temp-roots." (register db item) (report)) items))))) + +(define (vacuum-database) + (let ((db (sqlite-open (store-database-file)))) + (sqlite-exec db "VACUUM;") + (sqlite-close db))) diff --git a/guix/store/deduplication.scm b/guix/store/deduplication.scm index ab982e3b3d..acb6ffcc4a 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 <caleb.ristvedt@cune.org> -;;; Copyright © 2018-2021 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2018-2022 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -262,7 +262,10 @@ down the road." (deduplicate file (dump-and-compute-hash) #:store store) (call-with-output-file file (lambda (output) - (dump-port input output size))))) + (if (file-port? input) + (sendfile output input size 0) + (dump-port input output size + #:buffer-size %deduplication-minimum-size)))))) (define* (copy-file/deduplicate source target #:key (store (%store-directory))) diff --git a/guix/substitutes.scm b/guix/substitutes.scm index 9014cf61ec..edff84aac3 100644 --- a/guix/substitutes.scm +++ b/guix/substitutes.scm @@ -90,6 +90,16 @@ (string-append %state-directory "/substitute/cache")) (string-append (cache-directory #:ensure? #f) "/substitute"))) +(define %debug? + ;; Enable debug mode by setting the GUIX_SUBSTITUTE_DEBUG environmnent + ;; variable. + (make-parameter + (getenv "GUIX_SUBSTITUTE_DEBUG"))) + +(define-syntax-rule (debug fmt args ...) + (when (%debug?) + (format #t fmt args ...))) + (define (narinfo-cache-file cache-url path) "Return the name of the local file that contains an entry for PATH. The entry is stored in a sub-directory specific to CACHE-URL." @@ -224,6 +234,13 @@ if file doesn't exist, and the narinfo otherwise." (let* ((path (uri-path (request-uri request))) (hash-part (basename (string-drop-right path 8)))) ;drop ".narinfo" + ;; Log the failing queries and indicate if it failed because the + ;; narinfo is being baked. + (let ((baking? + (assoc-ref (response-headers response) 'x-baking))) + (debug "could not fetch ~a~a ~a~a~%" + url path code + (if baking? " (baking)" ""))) (if len (get-bytevector-n port len) (read-to-eof port)) diff --git a/guix/svn-download.scm b/guix/svn-download.scm index 55ce0d7351..e0a26b73ee 100644 --- a/guix/svn-download.scm +++ b/guix/svn-download.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2014, 2015, 2016, 2019, 2021 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2014-2016, 2019, 2021-2022 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2014 Sree Harsha Totakura <sreeharsha@totakura.in> ;;; Copyright © 2017, 2019, 2021 Ricardo Wurmus <rekado@elephly.net> ;;; @@ -34,6 +34,8 @@ svn-reference-url svn-reference-revision svn-reference-recursive? + svn-reference-user-name + svn-reference-password svn-fetch download-svn-to-store @@ -43,6 +45,8 @@ svn-multi-reference-revision svn-multi-reference-locations svn-multi-reference-recursive? + svn-multi-reference-user-name + svn-multi-reference-password svn-multi-fetch download-multi-svn-to-store)) @@ -79,17 +83,42 @@ HASH-ALGO (a symbol). Use NAME as the file name, or a generic name if #f." (with-imported-modules '((guix build svn) (guix build utils)) #~(begin - (use-modules (guix build svn)) - (svn-fetch '#$(svn-reference-url ref) - '#$(svn-reference-revision ref) + (use-modules (guix build svn) + (ice-9 match)) + + (svn-fetch (getenv "svn url") + (string->number (getenv "svn revision")) #$output - #:svn-command (string-append #+svn "/bin/svn") - #:recursive? #$(svn-reference-recursive? ref) - #:user-name #$(svn-reference-user-name ref) - #:password #$(svn-reference-password ref))))) + #:svn-command #+(file-append svn "/bin/svn") + #:recursive? (match (getenv "svn recursive?") + ("yes" #t) + (_ #f)) + #:user-name (getenv "svn user name") + #:password (getenv "svn password"))))) (mlet %store-monad ((guile (package->derivation guile system))) (gexp->derivation (or name "svn-checkout") build + + ;; Use environment variables and a fixed script name so + ;; there's only one script in store for all the + ;; downloads. + #:script-name "svn-download" + #:env-vars + `(("svn url" . ,(svn-reference-url ref)) + ("svn revision" + . ,(number->string (svn-reference-revision ref))) + ,@(if (svn-reference-recursive? ref) + `(("svn recursive?" . "yes")) + '()) + ,@(if (svn-reference-user-name ref) + `(("svn user name" + . ,(svn-reference-user-name ref))) + '()) + ,@(if (svn-reference-password ref) + `(("svn password" + . ,(svn-reference-password ref))) + '())) + #:system system #:hash-algo hash-algo #:hash hash @@ -120,27 +149,53 @@ HASH-ALGO (a symbol). Use NAME as the file name, or a generic name if #f." #~(begin (use-modules (guix build svn) (guix build utils) - (srfi srfi-1)) - (every (lambda (location) - ;; The directory must exist if we are to fetch only a - ;; single file. - (unless (string-suffix? "/" location) - (mkdir-p (string-append #$output "/" (dirname location)))) - (svn-fetch (string-append '#$(svn-multi-reference-url ref) - "/" location) - '#$(svn-multi-reference-revision ref) - (if (string-suffix? "/" location) - (string-append #$output "/" location) - (string-append #$output "/" (dirname location))) - #:svn-command (string-append #+svn "/bin/svn") - #:recursive? - #$(svn-multi-reference-recursive? ref) - #:user-name #$(svn-multi-reference-user-name ref) - #:password #$(svn-multi-reference-password ref))) - '#$(sexp->gexp (svn-multi-reference-locations ref)))))) + (srfi srfi-1) + (ice-9 match)) + + (for-each (lambda (location) + ;; The directory must exist if we are to fetch only a + ;; single file. + (unless (string-suffix? "/" location) + (mkdir-p (string-append #$output "/" (dirname location)))) + (svn-fetch (string-append (getenv "svn url") "/" location) + (string->number (getenv "svn revision")) + (if (string-suffix? "/" location) + (string-append #$output "/" location) + (string-append #$output "/" (dirname location))) + #:svn-command #+(file-append svn "/bin/svn") + #:recursive? (match (getenv "svn recursive?") + ("yes" #t) + (_ #f)) + #:user-name (getenv "svn user name") + #:password (getenv "svn password"))) + (call-with-input-string (getenv "svn locations") + read))))) (mlet %store-monad ((guile (package->derivation guile system))) (gexp->derivation (or name "svn-checkout") build + + ;; Use environment variables and a fixed script name so + ;; there's only one script in store for all the + ;; downloads. + #:script-name "svn-multi-download" + #:env-vars + `(("svn url" . ,(svn-multi-reference-url ref)) + ("svn locations" + . ,(object->string (svn-multi-reference-locations ref))) + ("svn revision" + . ,(number->string (svn-multi-reference-revision ref))) + ,@(if (svn-multi-reference-recursive? ref) + `(("svn recursive?" . "yes")) + '()) + ,@(if (svn-multi-reference-user-name ref) + `(("svn user name" + . ,(svn-multi-reference-user-name ref))) + '()) + ,@(if (svn-multi-reference-password ref) + `(("svn password" + . ,(svn-multi-reference-password ref))) + '())) + #:leaked-env-vars '("http_proxy" "https_proxy" "LC_ALL" "LC_MESSAGES" "LANG" "COLUMNS") diff --git a/guix/transformations.scm b/guix/transformations.scm index 411c4014cb..8ff472ad21 100644 --- a/guix/transformations.scm +++ b/guix/transformations.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2016-2022 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2016-2023 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2021 Marius Bakke <marius@gnu.org> ;;; ;;; This file is part of GNU Guix. @@ -43,11 +43,11 @@ #:use-module (srfi srfi-1) #:use-module (srfi srfi-9) - #:use-module (srfi srfi-11) #:use-module (srfi srfi-26) #:use-module (srfi srfi-34) #:use-module (srfi srfi-35) #:use-module (srfi srfi-37) + #:use-module (srfi srfi-71) #:use-module (ice-9 match) #:use-module (ice-9 vlist) #:export (options->transformation @@ -115,8 +115,7 @@ extensions." "Return a package based on P but with its source taken from URI. Extract the new package's version number from URI." (let ((base (tarball-base-name (basename uri)))) - (let-values (((_ version*) - (hyphen-package-name->name+version base))) + (let ((_ version* (hyphen-package-name->name+version base))) (package (inherit p) (version (or version version* (package-version p))) @@ -129,42 +128,45 @@ the new package's version number from URI." ;;; Transformations. ;;; -(define (transform-package-source sources) - "Return a transformation procedure that replaces package sources with the -matching URIs given in SOURCES." - (define new-sources - (map (lambda (uri) - (match (string-index uri #\=) - (#f - ;; Determine the package name and version from URI. - (call-with-values - (lambda () - (hyphen-package-name->name+version - (tarball-base-name (basename uri)))) - (lambda (name version) - (list name version uri)))) - (index - ;; What's before INDEX is a "PKG@VER" or "PKG" spec. - (call-with-values - (lambda () - (package-name->name+version (string-take uri index))) - (lambda (name version) - (list name version - (string-drop uri (+ 1 index)))))))) - sources)) +(define (evaluate-source-replacement-specs specs) + "Parse SPECS, a list of strings like \"guile=/tmp/guile-4.2.tar.gz\" or just +\"/tmp/guile-4.2.tar.gz\" and return a list of package spec/procedure pairs as +expected by 'package-input-rewriting/spec'. Raise an error if an element of +SPECS uses invalid syntax." + (define not-equal + (char-set-complement (char-set #\=))) - (lambda (obj) - (let loop ((sources new-sources) - (result '())) - (match obj - ((? package? p) - (match (assoc-ref sources (package-name p)) - ((version source) - (package-with-source p source version)) - (#f - p))) - (_ - obj))))) + (map (lambda (spec) + (match (string-tokenize spec not-equal) + ((uri) + (let* ((base (tarball-base-name (basename uri))) + (name (hyphen-package-name->name+version base))) + (cons name + (lambda (old) + (package-with-source old uri))))) + ((spec uri) + (let ((name version (package-name->name+version spec))) + ;; Note: Here VERSION is used as the version string of the new + ;; package rather than as part of the spec of the package being + ;; targeted. + (cons name + (lambda (old) + (package-with-source old uri version))))) + (_ + (raise (formatted-message + (G_ "invalid source replacement specification: ~s") + spec))))) + specs)) + +(define (transform-package-source replacement-specs) + "Return a transformation procedure that replaces package sources with the +matching URIs given in REPLACEMENT-SPECS." + (let* ((replacements (evaluate-source-replacement-specs replacement-specs)) + (rewrite (package-input-rewriting/spec replacements))) + (lambda (obj) + (if (package? obj) + (rewrite obj) + obj)))) (define (evaluate-replacement-specs specs proc) "Parse SPECS, a list of strings like \"guile=guile@2.1\" and return a list @@ -755,35 +757,72 @@ additional patches." (rewrite obj) obj))) +(define* (package-with-upstream-version p #:optional version) + "Return package P changed to use the given upstream VERSION or, if VERSION +is #f, the latest known upstream version." + (let ((source (package-latest-release p #:version version))) + (cond ((not source) + (if version + (warning + (G_ "could not find version ~a of '~a' upstream~%") + version (package-name p)) + (warning + (G_ "could not determine latest upstream release of '~a'~%") + (package-name p))) + p) + ((string=? (upstream-source-version source) + (package-version p)) + (unless version + (info (G_ "~a is already the latest version of '~a'~%") + (package-version p) (package-name p))) + p) + (else + (when (version>? (package-version p) + (upstream-source-version source)) + (warning (G_ "using ~a ~a, which is older than the packaged \ +version (~a)~%") + (package-name p) + (upstream-source-version source) + (package-version p))) + + (unless (pair? (upstream-source-signature-urls source)) + (warning (G_ "cannot authenticate source of '~a', version ~a~%") + (package-name p) + (upstream-source-version source))) + + ;; TODO: Take 'upstream-source-input-changes' into account. + (package + (inherit p) + (version (upstream-source-version source)) + (source source)))))) + (define (transform-package-latest specs) "Return a procedure that rewrites package graphs such that those in SPECS are replaced by their latest upstream version." - (define (package-with-latest-upstream p) - (let ((source (package-latest-release p))) - (cond ((not source) - (warning - (G_ "could not determine latest upstream release of '~a'~%") - (package-name p)) - p) - ((string=? (upstream-source-version source) - (package-version p)) - p) - (else - (unless (pair? (upstream-source-signature-urls source)) - (warning (G_ "cannot authenticate source of '~a', version ~a~%") - (package-name p) - (upstream-source-version source))) - - ;; TODO: Take 'upstream-source-input-changes' into account. - (package - (inherit p) - (version (upstream-source-version source)) - (source source)))))) + (define rewrite + (package-input-rewriting/spec + (map (lambda (spec) + (cons spec package-with-upstream-version)) + specs))) + (lambda (obj) + (if (package? obj) + (rewrite obj) + obj))) + +(define (transform-package-version specs) + "Return a procedure that rewrites package graphs such that those in SPECS +are replaced by the specified upstream version." (define rewrite (package-input-rewriting/spec (map (lambda (spec) - (cons spec package-with-latest-upstream)) + (match (string-tokenize spec %not-equal) + ((spec version) + (cons spec (cut package-with-upstream-version <> version))) + (_ + (raise (formatted-message + (G_ "~a: invalid upstream version specification") + spec))))) specs))) (lambda (obj) @@ -807,7 +846,8 @@ are replaced by their latest upstream version." (with-debug-info . ,transform-package-with-debug-info) (without-tests . ,transform-package-tests) (with-patch . ,transform-package-patches) - (with-latest . ,transform-package-latest))) + (with-latest . ,transform-package-latest) + (with-version . ,transform-package-version))) (define (transformation-procedure key) "Return the transformation procedure associated with KEY, a symbol such as @@ -879,6 +919,8 @@ building for ~a instead of ~a, so tuning cannot be guessed~%") (parser 'with-patch)) (option '("with-latest") #t #f (parser 'with-latest)) + (option '("with-version") #t #f + (parser 'with-version)) (option '("help-transform") #f #f (lambda _ @@ -914,6 +956,9 @@ building for ~a instead of ~a, so tuning cannot be guessed~%") --with-latest=PACKAGE use the latest upstream release of PACKAGE")) (display (G_ " + --with-version=PACKAGE=VERSION + use the given upstream VERSION of PACKAGE")) + (display (G_ " --with-c-toolchain=PACKAGE=TOOLCHAIN build PACKAGE and its dependents with TOOLCHAIN")) (display (G_ " diff --git a/guix/ui.scm b/guix/ui.scm index dad2b853ac..9f81ff3b8e 100644 --- a/guix/ui.scm +++ b/guix/ui.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2012-2022 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2012-2023 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2013, 2018 Mark H Weaver <mhw@netris.org> ;;; Copyright © 2013 Nikita Karetnikov <nikita@karetnikov.org> ;;; Copyright © 2014 Cyril Roelandt <tipecaml@gmail.com> @@ -518,7 +518,7 @@ See the \"Application Setup\" section in the manual, for more info.\n")) "Display version information for COMMAND and `(exit 0)'." (simple-format #t "~a (~a) ~a~%" command %guix-package-name %guix-version) - (format #t "Copyright ~a 2022 ~a" + (format #t "Copyright ~a 2023 ~a" ;; TRANSLATORS: Translate "(C)" to the copyright symbol ;; (C-in-a-circle), if this symbol is available in the user's ;; locale. Otherwise, do not translate "(C)"; leave it as-is. */ @@ -591,6 +591,9 @@ FILE." (set! execlp (error-reporting-wrapper execlp (filename . args) filename)) +(set! mkdir + (error-reporting-wrapper mkdir (directory . args) directory)) + (define (make-regexp* regexp . flags) "Like 'make-regexp' but error out if REGEXP is invalid, reporting the error nicely." @@ -1512,7 +1515,16 @@ that may return a colorized version of its argument." (sort packages package<?))) " "))) (split-lines list (string-length "dependencies: ")))) - (define (output->recutils package output) + (define %default-output-synopses + `(("bin" . ,(G_ "executable programs and scripts")) + ("debug" . ,(G_ "debug information")) + ("doc" . ,(G_ "documentation")) + ("lib" . ,(G_ "shared libraries")) + ("static" . ,(G_ "static libraries")) + ("out" . ,(G_ "everything else")))) + + (define* (output->recutils package output #:optional + (default-synopses %default-output-synopses)) (string-append "+ " output ": " (or @@ -1522,13 +1534,8 @@ that may return a colorized version of its argument." (and (string=? key output) (P_ synopsis))) (_ #f)) (package-properties package)) - (assoc-ref `(("bin" . ,(G_ "executable programs and scripts")) - ("debug" . ,(G_ "debug information")) - ("lib" . ,(G_ "shared libraries")) - ("static" . ,(G_ "static libraries")) - ("out" . ,(G_ "everything else"))) - output) - (G_ "see Appendix H")))) + (assoc-ref default-synopses output) + (G_ "[description missing]")))) (define (package-outputs/out-last package) ((compose append partition) @@ -1546,8 +1553,16 @@ that may return a colorized version of its argument." ;; Note: Don't i18n field names so that people can post-process it. (format port "name: ~a~%" (highlight (package-name p) port*)) (format port "version: ~a~%" (highlight (package-version p) port*)) - (format port "outputs:~%~{~a~%~}" - (map (cut output->recutils p <>) (package-outputs/out-last p))) + (match (package-outputs/out-last p) + (("out") ; one output has everything + (format port "outputs:~%~a~%" + (output->recutils p "out" + (alist-cons "out" (G_ "everything") + %default-output-synopses)))) + (outputs ; multiple outputs + (format port "outputs:~%~{~a~%~}" + (map (cut output->recutils p <>) (package-outputs/out-last p))))) + (format port "systems: ~a~%" (split-lines (string-join (package-transitive-supported-systems p)) (string-length "systems: "))) @@ -1656,6 +1671,7 @@ score, the more relevant OBJ is to REGEXPS." ;; Metrics used to compute the "relevance score" of a package against a set ;; of regexps. `((,package-name . 4) + (,package-upstream-name* . 2) ;; Match against uncommon outputs. (,(lambda (package) diff --git a/guix/upstream.scm b/guix/upstream.scm index cbfd1aa609..4c72388bf3 100644 --- a/guix/upstream.scm +++ b/guix/upstream.scm @@ -4,6 +4,7 @@ ;;; Copyright © 2019, 2022 Ricardo Wurmus <rekado@elephly.net> ;;; Copyright © 2021 Sarah Morgensen <iskarian@mgsn.dev> ;;; Copyright © 2021, 2022 Maxime Devos <maximedevos@telenet.be> +;;; Copyright © 2022 Hartmut Goebel <h.goebel@crazy-compilers.com> ;;; ;;; This file is part of GNU Guix. ;;; @@ -66,7 +67,7 @@ upstream-updater-name upstream-updater-description upstream-updater-predicate - upstream-updater-latest + upstream-updater-import upstream-input-change? upstream-input-change-name @@ -78,6 +79,7 @@ lookup-updater download-tarball + package-archive-type package-latest-release package-latest-release* package-update @@ -240,7 +242,7 @@ correspond to the same version." (name upstream-updater-name) (description upstream-updater-description) (pred upstream-updater-predicate) - (latest upstream-updater-latest)) + (import upstream-updater-import)) (define (importer-modules) "Return the list of importer modules." @@ -271,22 +273,23 @@ correspond to the same version." "Return an updater among UPDATERS that matches PACKAGE, or #f if none of them matches." (find (match-lambda - (($ <upstream-updater> name description pred latest) + (($ <upstream-updater> name description pred import) (pred package))) updaters)) (define* (package-latest-release package #:optional - (updaters (force %updaters))) + (updaters (force %updaters)) + #:key (version #f)) "Return an upstream source to update PACKAGE, a <package> object, or #f if none of UPDATERS matches PACKAGE. When several updaters match PACKAGE, try them until one of them returns an upstream source. It is the caller's responsibility to ensure that the returned source is newer than the current one." (any (match-lambda - (($ <upstream-updater> name description pred latest) + (($ <upstream-updater> name description pred import) (and (pred package) - (latest package)))) + (import package #:version version)))) updaters)) (define* (package-latest-release* package @@ -430,6 +433,19 @@ values: the item from LST1 and the item from LST2 that match PRED." (() (values #f #f))))) +(define (package-archive-type package) + "If PACKAGE's source is a tarball or zip archive, return its archive type--a +string such as \"xz\". Otherwise return #f." + (match (and=> (package-source package) origin-actual-file-name) + (#f #f) + (file + (let ((extension (file-extension file))) + ;; FILE might be "example-1.2-checkout", in which case we want to + ;; ignore the extension. + (and (or (string-contains extension "z") + (string-contains extension "tar")) + extension))))) + (define* (package-update/url-fetch store package source #:key key-download) "Return the version, tarball, and SOURCE, to update PACKAGE to @@ -437,17 +453,7 @@ SOURCE, an <upstream-source>." (match source (($ <upstream-source> _ version urls signature-urls) (let*-values (((archive-type) - (match (and=> (package-source package) origin-uri) - ((? string? uri) - (let ((type (or (file-extension (basename uri)) ""))) - ;; Sometimes we have URLs such as - ;; "https://github.com/…/tarball/v0.1", in which case - ;; we must not consider "1" as the extension. - (and (or (string-contains type "z") - (string=? type "tar")) - type))) - (_ - "gz"))) + (package-archive-type package)) ((url signature-url) ;; Try to find a URL that matches ARCHIVE-TYPE. (find2 (lambda (url sig-url) @@ -490,16 +496,27 @@ SOURCE, an <upstream-source>." (define* (package-update store package #:optional (updaters (force %updaters)) - #:key (key-download 'interactive)) + #:key (key-download 'interactive) (version #f)) "Return the new version, the file name of the new version tarball, and input changes for PACKAGE; return #f (three values) when PACKAGE is up-to-date; raise an error when the updater could not determine available releases. KEY-DOWNLOAD specifies a download policy for missing OpenPGP keys; allowed -values: 'always', 'never', and 'interactive' (default)." - (match (package-latest-release package updaters) +values: 'always', 'never', and 'interactive' (default). + +When VERSION is specified, update PACKAGE to that version, even if that is a +downgrade." + (match (package-latest-release package updaters #:version version) ((? upstream-source? source) - (if (version>? (upstream-source-version source) - (package-version package)) + (if (or (version>? (upstream-source-version source) + (package-version package)) + (and version + (begin + (warning (package-location package) + (G_ "downgrading '~a' from ~a to ~a~%") + (package-name package) + (package-version package) + (upstream-source-version source)) + #t))) (let ((method (match (package-source package) ((? origin? origin) (origin-method origin)) @@ -520,8 +537,11 @@ this method: ~s") (values #f #f #f))) (#f ;; Warn rather than abort so that other updates can still take place. - (warning (G_ "updater failed to determine available releases for ~a~%") - (package-name package)) + (if version + (warning (G_ "updater failed to find release ~a@~a~%") + (package-name package) version) + (warning (G_ "updater failed to determine available releases for ~a~%") + (package-name package))) (values #f #f #f)))) (define* (update-package-source package source hash) |