diff options
Diffstat (limited to 'guix')
132 files changed, 4364 insertions, 1655 deletions
diff --git a/guix/build-system/agda.scm b/guix/build-system/agda.scm index 64983dff60..ec6ad860e0 100644 --- a/guix/build-system/agda.scm +++ b/guix/build-system/agda.scm @@ -38,7 +38,7 @@ (define %agda-build-system-modules `((guix build agda-build-system) - ,@%gnu-build-system-modules)) + ,@%default-gnu-imported-modules)) (define %default-modules '((guix build agda-build-system) @@ -69,7 +69,6 @@ (list "ghc" (default-haskell)) (standard-packages)) '()) - ,(assoc "locales" (standard-packages)) ,@native-inputs)) (outputs outputs) (build agda-build) diff --git a/guix/build-system/android-ndk.scm b/guix/build-system/android-ndk.scm index aa7cc06279..b8cd56b871 100644 --- a/guix/build-system/android-ndk.scm +++ b/guix/build-system/android-ndk.scm @@ -31,7 +31,7 @@ (define %android-ndk-build-system-modules ;; Build-side modules imported by default. `((guix build android-ndk-build-system) - ,@%gnu-build-system-modules)) + ,@%default-gnu-imported-modules)) (define* (android-ndk-build name inputs #:key diff --git a/guix/build-system/ant.scm b/guix/build-system/ant.scm index 84bf951fab..9816cc061c 100644 --- a/guix/build-system/ant.scm +++ b/guix/build-system/ant.scm @@ -43,7 +43,7 @@ (guix build maven plugin) (guix build maven pom) (guix build java-utils) - ,@%gnu-build-system-modules)) + ,@%default-gnu-imported-modules)) (define (default-jdk) "Return the default JDK package." diff --git a/guix/build-system/asdf.scm b/guix/build-system/asdf.scm index 2b17cee37b..26b5a5008a 100644 --- a/guix/build-system/asdf.scm +++ b/guix/build-system/asdf.scm @@ -56,7 +56,7 @@ `((guix build asdf-build-system) (guix build lisp-utils) (guix build union) - ,@%gnu-build-system-modules)) + ,@%default-gnu-imported-modules)) (define %asdf-build-modules ;; Used (visible) build-side modules diff --git a/guix/build-system/cargo.scm b/guix/build-system/cargo.scm index c029cc1dda..0e9a4b1d23 100644 --- a/guix/build-system/cargo.scm +++ b/guix/build-system/cargo.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2013, 2014, 2015, 2016, 2019, 2021 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2013-2016, 2019, 2021, 2024 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2013 Andreas Enge <andreas@enge.fr> ;;; Copyright © 2013 Nikita Karetnikov <nikita@karetnikov.org> ;;; Copyright © 2016 David Craven <david@craven.ch> @@ -70,7 +70,7 @@ to NAME and VERSION." (define %cargo-utils-modules ;; Build-side modules imported by default. `((guix build cargo-utils) - ,@%gnu-build-system-modules)) + ,@%default-gnu-imported-modules)) (define %cargo-build-system-modules ;; Build-side modules imported by default. @@ -227,24 +227,22 @@ do not extract the conventional inputs)." (let loop ((inputs inputs) (result '()) (propagated '()) - (first? #t) (seen vlist-null)) (match inputs (() (if (null? propagated) (reverse result) - (loop (reverse (concatenate propagated)) result '() #f seen))) + (loop (reverse (concatenate propagated)) result '() seen))) (((and input (label (? package? package))) rest ...) - (if (and (not first?) (seen? seen package)) - (loop rest result propagated first? seen) + (if (seen? seen package) + (loop rest result propagated seen) (loop rest (cons input result) (cons (package-cargo-inputs package) propagated) - first? (vhash-consq package package seen)))) ((input rest ...) - (loop rest (cons input result) propagated first? seen))))) + (loop rest (cons input result) propagated seen))))) (define (expand-crate-sources cargo-inputs cargo-development-inputs) "Extract all transitive sources for CARGO-INPUTS and CARGO-DEVELOPMENT-INPUTS diff --git a/guix/build-system/chicken.scm b/guix/build-system/chicken.scm index 9f518e66e6..e6fcfa7ee3 100644 --- a/guix/build-system/chicken.scm +++ b/guix/build-system/chicken.scm @@ -42,7 +42,7 @@ EXTENSION is the file name extension, such as '.tar.gz'." ;; Build-side modules imported and used by default. `((guix build chicken-build-system) (guix build union) - ,@%gnu-build-system-modules)) + ,@%default-gnu-imported-modules)) (define (default-chicken) ;; Lazily resolve the binding to avoid a circular dependency. diff --git a/guix/build-system/cmake.scm b/guix/build-system/cmake.scm index aa187c9844..0b8a651ee0 100644 --- a/guix/build-system/cmake.scm +++ b/guix/build-system/cmake.scm @@ -42,7 +42,7 @@ (define %cmake-build-system-modules ;; Build-side modules imported by default. `((guix build cmake-build-system) - ,@%gnu-build-system-modules)) + ,@%default-gnu-imported-modules)) (define (default-cmake target) "Return the default CMake package." @@ -116,6 +116,7 @@ (imported-modules %cmake-build-system-modules) (modules '((guix build cmake-build-system) (guix build utils))) + allowed-references disallowed-references) "Build SOURCE using CMAKE, and with INPUTS. This assumes that SOURCE provides a 'CMakeLists.txt' file as its build system." @@ -158,6 +159,7 @@ provides a 'CMakeLists.txt' file as its build system." #:target #f #:graft? #f #:substitutable? substitutable? + #:allowed-references allowed-references #:disallowed-references disallowed-references #:guile-for-build guile))) @@ -193,6 +195,7 @@ provides a 'CMakeLists.txt' file as its build system." (imported-modules %cmake-build-system-modules) (modules '((guix build cmake-build-system) (guix build utils))) + allowed-references disallowed-references) "Cross-build NAME using CMAKE for TARGET, where TARGET is a GNU triplet and with INPUTS. This assumes that SOURCE provides a 'CMakeLists.txt' file as its @@ -250,6 +253,8 @@ build system." #:target target #:graft? #f #:substitutable? substitutable? + #:allowed-references allowed-references + #:disallowed-references disallowed-references #:guile-for-build guile))) (define cmake-build-system diff --git a/guix/build-system/composer.scm b/guix/build-system/composer.scm index 2ad7bbb36a..48ad90f253 100644 --- a/guix/build-system/composer.scm +++ b/guix/build-system/composer.scm @@ -62,7 +62,7 @@ ;; Build-side modules imported by default. `((guix build composer-build-system) (guix build union) - ,@%gnu-build-system-modules)) + ,@%default-gnu-imported-modules)) (define* (lower name #:key source inputs native-inputs outputs system target diff --git a/guix/build-system/copy.scm b/guix/build-system/copy.scm index d58931b33c..1f2937e0f1 100644 --- a/guix/build-system/copy.scm +++ b/guix/build-system/copy.scm @@ -46,7 +46,7 @@ (define %copy-build-system-modules ;; Build-side modules imported by default. `((guix build copy-build-system) - ,@%gnu-build-system-modules)) + ,@%default-gnu-imported-modules)) (define (default-glibc) "Return the default glibc package." diff --git a/guix/build-system/dub.scm b/guix/build-system/dub.scm index 951c084398..831a34af0d 100644 --- a/guix/build-system/dub.scm +++ b/guix/build-system/dub.scm @@ -59,7 +59,7 @@ (define %dub-build-system-modules ;; Build-side modules imported by default. `((guix build dub-build-system) - ,@%gnu-build-system-modules)) + ,@%default-gnu-imported-modules)) (define* (dub-build name inputs #:key diff --git a/guix/build-system/elm.scm b/guix/build-system/elm.scm index f5321f811b..7405db3d98 100644 --- a/guix/build-system/elm.scm +++ b/guix/build-system/elm.scm @@ -88,7 +88,7 @@ given VERSION with sha256 checksum HASH." `((guix build elm-build-system) (guix build json) (guix build union) - ,@%gnu-build-system-modules)) + ,@%default-gnu-imported-modules)) (define %elm-default-modules ;; Modules in scope in the build-side environment. diff --git a/guix/build-system/emacs.scm b/guix/build-system/emacs.scm index ebf97a5344..03273d738b 100644 --- a/guix/build-system/emacs.scm +++ b/guix/build-system/emacs.scm @@ -46,7 +46,7 @@ ;; Build-side modules imported by default. `((guix build emacs-build-system) (guix build emacs-utils) - ,@%gnu-build-system-modules)) + ,@%default-gnu-imported-modules)) (define (default-emacs) "Return the default Emacs package." diff --git a/guix/build-system/font.scm b/guix/build-system/font.scm index c57c304f52..a4eeca00ca 100644 --- a/guix/build-system/font.scm +++ b/guix/build-system/font.scm @@ -40,7 +40,7 @@ (define %font-build-system-modules ;; Build-side modules imported by default. `((guix build font-build-system) - ,@%gnu-build-system-modules)) + ,@%default-gnu-imported-modules)) (define* (lower name #:key source inputs native-inputs outputs system target @@ -76,6 +76,7 @@ (tests? #t) (test-target "test") (configure-flags ''()) + (license-file-regexp '%license-file-regexp) (phases '%standard-phases) (outputs '("out")) (search-paths '()) @@ -97,6 +98,7 @@ #:system #$system #:test-target #$test-target #:tests? #$tests? + #:license-file-regexp #$license-file-regexp #:phases #$(if (pair? phases) (sexp->gexp phases) phases) diff --git a/guix/build-system/glib-or-gtk.scm b/guix/build-system/glib-or-gtk.scm index 726d19efad..5d026ec5ab 100644 --- a/guix/build-system/glib-or-gtk.scm +++ b/guix/build-system/glib-or-gtk.scm @@ -72,7 +72,7 @@ (define %glib-or-gtk-build-system-modules ;; Build-side modules imported and used by default. `((guix build glib-or-gtk-build-system) - ,@%gnu-build-system-modules)) + ,@%default-gnu-imported-modules)) (define (default-glib) "Return the default glib package from which we use diff --git a/guix/build-system/gnu.scm b/guix/build-system/gnu.scm index cdbb547773..3a314d34b7 100644 --- a/guix/build-system/gnu.scm +++ b/guix/build-system/gnu.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2012-2023 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2012-2024 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -19,6 +19,7 @@ (define-module (guix build-system gnu) #:use-module (guix store) #:use-module (guix utils) + #:use-module (guix deprecation) #:use-module (guix memoization) #:use-module (guix gexp) #:use-module (guix monads) @@ -27,7 +28,8 @@ #:use-module (guix packages) #:use-module (srfi srfi-1) #:use-module (ice-9 match) - #:export (%gnu-build-system-modules + #:export (%default-gnu-imported-modules + %default-gnu-modules %strip-flags %strip-directories gnu-build @@ -48,14 +50,17 @@ ;; ;; Code: -(define %gnu-build-system-modules +(define %default-gnu-imported-modules ;; Build-side modules imported and used by default. '((guix build gnu-build-system) (guix build utils) (guix build gremlin) (guix elf))) -(define %default-modules +(define-deprecated/public-alias %gnu-build-system-modules + %default-gnu-imported-modules) + +(define %default-gnu-modules ;; Modules in scope in the build-side environment. '((guix build gnu-build-system) (guix build utils))) @@ -184,21 +189,22 @@ flags for VARIABLE, the associated value is augmented." (input input)) inputs)) - (package (inherit p) + (package + (inherit p) (arguments (let ((args (package-arguments p))) (substitute-keyword-arguments args ((#:configure-flags flags) (let* ((var= (string-append variable "=")) (len (string-length var=))) - `(cons ,(string-append var= value) - (map (lambda (flag) - (if (string-prefix? ,var= flag) - (string-append - ,(string-append var= value " ") - (substring flag ,len)) - flag)) - ,flags))))))) + #~(cons #$(string-append var= value) + (map (lambda (flag) + (if (string-prefix? #$var= flag) + (string-append + #$(string-append var= value " ") + (substring flag #$len)) + flag)) + #$flags))))))) (replacement (let ((replacement (package-replacement p))) (and replacement @@ -237,10 +243,10 @@ exact build phases are defined by PHASES." (arguments ;; Use the right phases and modules. (substitute-keyword-arguments (package-arguments p) - ((#:modules modules %default-modules) + ((#:modules modules %default-gnu-modules) `((guix build gnu-dist) ,@modules)) - ((#:imported-modules modules %gnu-build-system-modules) + ((#:imported-modules modules %default-gnu-imported-modules) `((guix build gnu-dist) ,@modules)) ((#:phases _ #f) @@ -356,11 +362,12 @@ standard packages used as implicit inputs of the GNU build system." (make-dynamic-linker-cache? #t) (license-file-regexp %license-file-regexp) (phases '%standard-phases) - (locale "en_US.utf8") + (locale "C.UTF-8") + (separate-from-pid1? #t) (system (%current-system)) (build (nix-system->gnu-triplet system)) - (imported-modules %gnu-build-system-modules) - (modules %default-modules) + (imported-modules %default-gnu-imported-modules) + (modules %default-gnu-modules) (substitutable? #t) allowed-references disallowed-references) @@ -399,6 +406,7 @@ are allowed to refer to." (sexp->gexp phases) phases) #:locale #$locale + #:separate-from-pid1? #$separate-from-pid1? #:bootstrap-scripts #$bootstrap-scripts #:configure-flags #$(if (pair? configure-flags) (sexp->gexp configure-flags) @@ -499,11 +507,12 @@ is one of `host' or `target'." (license-file-regexp %license-file-regexp) (phases '%standard-phases) - (locale "en_US.utf8") + (locale "C.UTF-8") + (separate-from-pid1? #t) (system (%current-system)) (build (nix-system->gnu-triplet system)) - (imported-modules %gnu-build-system-modules) - (modules %default-modules) + (imported-modules %default-gnu-imported-modules) + (modules %default-gnu-modules) (substitutable? #t) allowed-references disallowed-references) @@ -545,6 +554,7 @@ platform." (sexp->gexp phases) phases) #:locale #$locale + #:separate-from-pid1? #$separate-from-pid1? #:bootstrap-scripts #$bootstrap-scripts #:configure-flags #$configure-flags #:make-flags #$make-flags diff --git a/guix/build-system/go.scm b/guix/build-system/go.scm index 0934fded07..97581a14c6 100644 --- a/guix/build-system/go.scm +++ b/guix/build-system/go.scm @@ -5,6 +5,9 @@ ;;; Copyright © 2021-2022 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2021, 2023 Efraim Flashner <efraim@flashner.co.il> ;;; Copyright © 2021 Sarah Morgensen <iskarian@mgsn.dev> +;;; Copyright © 2024 Christina O'Donnell <cdo@mutix.org> +;;; Copyright © 2024 Troy Figiel <troy@troyfigiel.com> +;;; Copyright © 2024 Sharlatan Hellseher <sharlatanus@gmail.com> ;;; ;;; This file is part of GNU Guix. ;;; @@ -33,6 +36,8 @@ #:use-module (ice-9 match) #:use-module (ice-9 regex) #:use-module (srfi srfi-1) + #:use-module (srfi srfi-34) + #:use-module (srfi srfi-35) #:export (%go-build-system-modules go-build go-build-system @@ -56,11 +61,13 @@ "([0-9A-Fa-f]{12})" ;commit hash "(\\+incompatible)?$"))) ;optional +incompatible tag -(define (go-version->git-ref version) +(define* (go-version->git-ref version #:key subdir) "Parse VERSION, a \"pseudo-version\" as defined at <https://golang.org/ref/mod#pseudo-versions>, and extract the commit hash from it, defaulting to full VERSION (stripped from the \"+incompatible\" suffix if -present) if a pseudo-version pattern is not recognized." +present) if a pseudo-version pattern is not recognized. If SUBDIR is +specified and this is not a pseudo-version, then this will prefix SUBDIR/ to +the returned tag; when VERSION misses 'v' prefix use SUBDIR/v instead." ;; A module version like v1.2.3 is introduced by tagging a revision in the ;; underlying source repository. Untagged revisions can be referred to ;; using a "pseudo-version" like v0.0.0-yyyymmddhhmmss-abcdefabcdef, where @@ -78,7 +85,13 @@ present) if a pseudo-version pattern is not recognized." (match (regexp-exec %go-pseudo-version-rx version))) (if match (match:substring match 2) - version))) + (cond + ((and subdir (string-prefix? "v" version)) + (string-append subdir "/" version)) + ((and subdir (not (string-prefix? "v" version))) + (string-append subdir "/v" version)) + (else + version))))) (define (go-pseudo-version? version) "True if VERSION is a Go pseudo-version, i.e., a version string made of a @@ -101,13 +114,19 @@ commit hash and its date rather than a proper release tag." (_ arch)) (match os ((or "mingw32" "cygwin") "windows") - (_ os)))))) + (_ os)))) + (_ + (raise + (condition + (&unsupported-cross-compilation-target-error + (build-system go-build-system) + (target target))))))) (define %go-build-system-modules ;; Build-side modules imported and used by default. `((guix build go-build-system) (guix build union) - ,@%gnu-build-system-modules)) + ,@%default-gnu-imported-modules)) (define (default-go) ;; Lazily resolve the binding to avoid a circular dependency. @@ -180,10 +199,14 @@ commit hash and its date rather than a proper release tag." (outputs '("out")) (search-paths '()) (install-source? #t) + (embed-files ''()) (import-path "") (unpack-path "") (build-flags ''()) (tests? #t) + (test-flags ''()) + (parallel-build? #t) + (parallel-tests? #t) (allow-go-reference? #f) (system (%current-system)) (goarch #f) @@ -206,6 +229,7 @@ commit hash and its date rather than a proper release tag." #:substitutable? #$substitutable? #:goarch #$goarch #:goos #$goos + #:embed-files #$embed-files #:search-paths '#$(sexp->gexp (map search-path-specification->sexp search-paths)) @@ -214,6 +238,9 @@ commit hash and its date rather than a proper release tag." #:unpack-path #$unpack-path #:build-flags #$build-flags #:tests? #$tests? + #:test-flags #$test-flags + #:parallel-build? #$parallel-build? + #:parallel-tests? #$parallel-tests? #:allow-go-reference? #$allow-go-reference? #:inputs #$(input-tuples->gexp inputs))))) @@ -236,10 +263,12 @@ commit hash and its date rather than a proper release tag." (unpack-path "") (build-flags ''()) (tests? #f) ; nothing can be done + (test-flags ''()) (allow-go-reference? #f) (system (%current-system)) (goarch (first (go-target target))) (goos (last (go-target target))) + (embed-files ''()) (guile #f) (imported-modules %go-build-system-modules) (modules '((guix build go-build-system) @@ -273,6 +302,7 @@ commit hash and its date rather than a proper release tag." #:target #$target #:goarch #$goarch #:goos #$goos + #:embed-files #$embed-files #:inputs %build-target-inputs #:native-inputs %build-host-inputs #:search-paths '#$(map search-path-specification->sexp @@ -285,6 +315,7 @@ commit hash and its date rather than a proper release tag." #:unpack-path #$unpack-path #:build-flags #$build-flags #:tests? #$tests? + #:test-flags #$test-flags #:make-dynamic-linker-cache? #f ;cross-compiling #:allow-go-reference? #$allow-go-reference? #:inputs %build-inputs)))) diff --git a/guix/build-system/guile.scm b/guix/build-system/guile.scm index bd3bb1c870..ee59bb15f2 100644 --- a/guix/build-system/guile.scm +++ b/guix/build-system/guile.scm @@ -36,7 +36,7 @@ (define %guile-build-system-modules ;; Build-side modules imported by default. `((guix build guile-build-system) - ,@%gnu-build-system-modules)) + ,@%default-gnu-imported-modules)) (define* (lower name #:key source inputs native-inputs outputs system target @@ -64,7 +64,7 @@ ,@native-inputs ,@(if implicit-inputs? (map (cute assoc <> (standard-packages)) - '("tar" "gzip" "bzip2" "xz" "locales")) + '("tar" "gzip" "bzip2" "xz")) '()))) (outputs outputs) (build (if target guile-cross-build guile-build)) diff --git a/guix/build-system/haskell.scm b/guix/build-system/haskell.scm index f8568e33db..b0019dd014 100644 --- a/guix/build-system/haskell.scm +++ b/guix/build-system/haskell.scm @@ -55,7 +55,7 @@ to NAME and VERSION." (define %haskell-build-system-modules ;; Build-side modules imported by default. `((guix build haskell-build-system) - ,@%gnu-build-system-modules)) + ,@%default-gnu-imported-modules)) (define (default-haskell) "Return the default Haskell package." diff --git a/guix/build-system/julia.scm b/guix/build-system/julia.scm index b5521e38e4..e098749683 100644 --- a/guix/build-system/julia.scm +++ b/guix/build-system/julia.scm @@ -42,7 +42,7 @@ (define %julia-build-system-modules ;; Build-side modules imported by default. `((guix build julia-build-system) - ,@%gnu-build-system-modules)) + ,@%default-gnu-imported-modules)) (define (default-julia) "Return the default Julia package." diff --git a/guix/build-system/linux-module.scm b/guix/build-system/linux-module.scm index e46195b53c..d8ebef60d0 100644 --- a/guix/build-system/linux-module.scm +++ b/guix/build-system/linux-module.scm @@ -3,6 +3,7 @@ ;;; Copyright © 2020 Mathieu Othacehe <m.othacehe@gmail.com> ;;; Copyright © 2021 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2021 Tobias Geerinckx-Rice <me@tobias.gr> +;;; Copyright © 2024 Zheng Junjie <873216071@qq.com> ;;; ;;; This file is part of GNU Guix. ;;; @@ -41,7 +42,7 @@ (define %linux-module-build-system-modules ;; Build-side modules imported by default. `((guix build linux-module-build-system) - ,@%gnu-build-system-modules)) + ,@%default-gnu-imported-modules)) (define (default-linux) "Return the default Linux package." @@ -222,7 +223,7 @@ (use-modules #$@(sexp->gexp modules)) (define %build-host-inputs - '#+(input-tuples->gexp build-inputs)) + #+(input-tuples->gexp build-inputs)) (define %build-target-inputs (append #$(input-tuples->gexp host-inputs) diff --git a/guix/build-system/maven.scm b/guix/build-system/maven.scm index 4bbeaed6a4..03e4e96b89 100644 --- a/guix/build-system/maven.scm +++ b/guix/build-system/maven.scm @@ -46,7 +46,7 @@ ;; Build-side modules imported by default. `((guix build maven-build-system) (guix build maven pom) - ,@%gnu-build-system-modules)) + ,@%default-gnu-imported-modules)) (define (default-maven) "Return the default maven package." diff --git a/guix/build-system/meson.scm b/guix/build-system/meson.scm index bf9ca15ecc..67be007717 100644 --- a/guix/build-system/meson.scm +++ b/guix/build-system/meson.scm @@ -1,7 +1,7 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2017 Peter Mikkelsen <petermikkelsen10@gmail.com> ;;; Copyright © 2018, 2019 Marius Bakke <mbakke@fastmail.com> -;;; Copyright © 2021, 2022 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2021-2022, 2024 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2021 Maxime Devos <maximedevos@telenet.be> ;;; Copyright © 2022 Efraim Flashner <efraim@flashner.co.il> ;;; @@ -30,6 +30,8 @@ #:use-module (guix build-system gnu) #:use-module (guix build-system glib-or-gtk) #:use-module (guix packages) + #:use-module (srfi srfi-34) + #:use-module (srfi srfi-35) #:export (%meson-build-system-modules meson-build-system make-cross-file)) @@ -50,7 +52,12 @@ for TRIPLET." ((target-linux? triplet) "linux") ((target-mingw? triplet) "windows") ((target-avr? triplet) "none") - (#t (error "meson: unknown operating system")))) + (else + (raise + (condition + (&unsupported-cross-compilation-target-error + (build-system meson-build-system) + (target triplet))))))) (cpu_family . ,(cond ((target-x86-32? triplet) "x86") ((target-x86-64? triplet) "x86_64") ((target-arm32? triplet) "arm") @@ -62,7 +69,12 @@ for TRIPLET." "ppc64" "ppc")) ((target-riscv64? triplet) "riscv64") - (#t (error "meson: unknown architecture")))) + (else + (raise + (condition + (&unsupported-cross-compilation-target-error + (build-system meson-build-system) + (target triplet))))))) (cpu . ,(cond ((target-x86-32? triplet) ; i386, ..., i686 (substring triplet 0 4)) ((target-x86-64? triplet) "x86_64") @@ -176,12 +188,13 @@ TRIPLET." (outputs '("out")) (configure-flags ''()) (search-paths '()) + (out-of-source? #t) (build-type "debugoptimized") (tests? #t) (test-options ''()) (glib-or-gtk? #f) (parallel-build? #t) - (parallel-tests? #f) + (parallel-tests? #t) (validate-runpath? #t) (patch-shebangs? #t) (strip-binaries? #t) @@ -225,9 +238,12 @@ has a 'meson.build' file." #$(if (pair? configure-flags) (sexp->gexp configure-flags) configure-flags) + #:out-of-source? #$out-of-source? #:build-type #$build-type #:tests? #$tests? - #:test-options #$(sexp->gexp test-options) + #:test-options #$(if (pair? test-options) + (sexp->gexp test-options) + test-options) #:parallel-build? #$parallel-build? #:parallel-tests? #$parallel-tests? #:validate-runpath? #$validate-runpath? @@ -257,7 +273,7 @@ has a 'meson.build' file." (configure-flags ''()) (search-paths '()) (native-search-paths '()) - + (out-of-source? #t) (build-type "debugoptimized") (tests? #f) (test-options ''()) @@ -338,9 +354,12 @@ SOURCE has a 'meson.build' file." ,@#$(if (pair? configure-flags) (sexp->gexp configure-flags) configure-flags)) + #:out-of-source? #$out-of-source? #:build-type #$build-type #:tests? #$tests? - #:test-options #$(sexp->gexp test-options) + #:test-options #$(if (pair? test-options) + (sexp->gexp test-options) + test-options) #:parallel-build? #$parallel-build? #:parallel-tests? #$parallel-tests? #:validate-runpath? #$validate-runpath? diff --git a/guix/build-system/minetest.scm b/guix/build-system/minetest.scm index 1fae3a47e9..9774c5882a 100644 --- a/guix/build-system/minetest.scm +++ b/guix/build-system/minetest.scm @@ -37,6 +37,9 @@ (define (default-minetest) (module-ref (resolve-interface '(gnu packages minetest)) 'minetest)) +(define (default-minetest-game) + (module-ref (resolve-interface '(gnu packages minetest)) 'minetest-game)) + (define (default-xvfb-run) (module-ref (resolve-interface '(gnu packages xorg)) 'xvfb-run)) @@ -57,6 +60,7 @@ standard packages used as implicit inputs of the Minetest build system." `(("xvfb-run" ,(default-xvfb-run)) ("optipng" ,(default-optipng)) ("minetest" ,(default-minetest)) + ("minetest-game" ,(default-minetest-game)) ,@(filter (lambda (input) (member (car input) '("libc" "tar" "gzip" "bzip2" "xz" "locales"))) diff --git a/guix/build-system/minify.scm b/guix/build-system/minify.scm index b377b506b5..98c6e75980 100644 --- a/guix/build-system/minify.scm +++ b/guix/build-system/minify.scm @@ -39,7 +39,7 @@ (define %minify-build-system-modules ;; Build-side modules imported by default. `((guix build minify-build-system) - ,@%gnu-build-system-modules)) + ,@%default-gnu-imported-modules)) (define (default-esbuild) "Return the default package to minify JavaScript source files." diff --git a/guix/build-system/mix.scm b/guix/build-system/mix.scm index 1b04053d70..4a3ba9fb60 100644 --- a/guix/build-system/mix.scm +++ b/guix/build-system/mix.scm @@ -38,11 +38,6 @@ #:use-module (srfi srfi-26) #:export (mix-build-system hexpm-uri)) -;; Lazily resolve bindings to avoid circular dependencies. -(define (default-glibc-utf8-locales) - (let* ((base (resolve-interface '(gnu packages base)))) - (module-ref base 'glibc-utf8-locales))) - (define (default-elixir-hex) (let ((elixir (resolve-interface '(gnu packages elixir)))) (module-ref elixir 'elixir-hex))) @@ -90,7 +85,7 @@ See: https://github.com/hexpm/specifications/blob/main/endpoints.md" (system (%current-system)) (guile #f) (imported-modules `((guix build mix-build-system) - ,@%gnu-build-system-modules)) + ,@%default-gnu-imported-modules)) (modules '((guix build mix-build-system) (guix build utils)))) "Build SOURCE using Elixir, and with INPUTS." @@ -144,7 +139,6 @@ See: https://github.com/hexpm/specifications/blob/main/endpoints.md" #:key (elixir (default-elixir)) (elixir-hex (default-elixir-hex)) - (glibc-utf8-locales (default-glibc-utf8-locales)) (inputs '()) (native-inputs '()) (propagated-inputs '()) @@ -159,11 +153,10 @@ See: https://github.com/hexpm/specifications/blob/main/endpoints.md" (let ((private-keywords '(#:inputs #:native-inputs #:outputs #:system #:target - #:elixir #:elixir-hex #:glibc-utf8-locales + #:elixir #:elixir-hex #:rebar3 #:erlang)) (build-inputs `(,@(standard-packages) - ("glibc-utf8-locales" ,glibc-utf8-locales) ("erlang" ,(lookup-package-input elixir "erlang")) ("rebar3" ,rebar3) ("elixir" ,elixir) diff --git a/guix/build-system/node.scm b/guix/build-system/node.scm index 3f73390809..57fe5f6030 100644 --- a/guix/build-system/node.scm +++ b/guix/build-system/node.scm @@ -37,7 +37,7 @@ ;; Build-side modules imported by default. `((guix build node-build-system) (guix build json) - ,@%gnu-build-system-modules)) + ,@%default-gnu-imported-modules)) (define (default-node) "Return the default Node package." diff --git a/guix/build-system/ocaml.scm b/guix/build-system/ocaml.scm index 582d00b4cd..2f2e6dd62e 100644 --- a/guix/build-system/ocaml.scm +++ b/guix/build-system/ocaml.scm @@ -65,7 +65,7 @@ (define %ocaml-build-system-modules ;; Build-side modules imported by default. `((guix build ocaml-build-system) - ,@%gnu-build-system-modules)) + ,@%default-gnu-imported-modules)) (define (default-ocaml) "Return the default OCaml package." diff --git a/guix/build-system/perl.scm b/guix/build-system/perl.scm index 3f7a2dea27..98d48fec7c 100644 --- a/guix/build-system/perl.scm +++ b/guix/build-system/perl.scm @@ -45,7 +45,7 @@ (define %perl-build-system-modules ;; Build-side modules imported by default. `((guix build perl-build-system) - ,@%gnu-build-system-modules)) + ,@%default-gnu-imported-modules)) (define (default-perl) "Return the default Perl package." diff --git a/guix/build-system/pyproject.scm b/guix/build-system/pyproject.scm index 2a2c3af3f3..bdf8f440ac 100644 --- a/guix/build-system/pyproject.scm +++ b/guix/build-system/pyproject.scm @@ -46,13 +46,19 @@ ;; Build-side modules imported by default. `((guix build pyproject-build-system) (guix build json) + (guix build toml) ,@%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))) + ;; We are using python-sans-pip-wrapper, because it does not contain + ;; setuptools. This allows us to skip the dependency on setuptools for + ;; packages which don’t need it. And it allows us to more easily swap + ;; out setuptools if a different version is required. + ;; Using python-toolchain here might cause dependency cycles. + (module-ref python 'python-sans-pip-wrapper))) (define sanity-check.py (search-auxiliary-file "python/sanity-check.py")) @@ -87,7 +93,8 @@ (define* (pyproject-build name inputs #:key source (tests? #t) - (configure-flags ''()) + (configure-flags ''(@)) + (backend-path #f) (build-backend #f) (test-backend #f) (test-flags ''()) @@ -98,7 +105,9 @@ (guile #f) (imported-modules %pyproject-build-system-modules) (modules '((guix build pyproject-build-system) - (guix build utils)))) + (guix build utils))) + allowed-references + disallowed-references) "Build SOURCE using PYTHON, and with INPUTS." (define build (with-imported-modules imported-modules @@ -111,6 +120,7 @@ #:source #+source #:configure-flags #$configure-flags #:system #$system + #:backend-path #$backend-path #:build-backend #$build-backend #:test-backend #$test-backend #:test-flags #$test-flags @@ -131,7 +141,9 @@ #:system system #:graft? #f ;consistent with 'gnu-build' #:target #f - #:guile-for-build guile))) + #:guile-for-build guile + #:allowed-references allowed-references + #:disallowed-references disallowed-references))) (define pyproject-build-system (build-system diff --git a/guix/build-system/python.scm b/guix/build-system/python.scm index cca009fb28..a51c033d01 100644 --- a/guix/build-system/python.scm +++ b/guix/build-system/python.scm @@ -59,7 +59,7 @@ extension, such as '.tar.gz'." (define %python-build-system-modules ;; Build-side modules imported by default. `((guix build python-build-system) - ,@%gnu-build-system-modules)) + ,@%default-gnu-imported-modules)) (define (default-python) "Return the default Python package." @@ -179,7 +179,9 @@ pre-defined variants." (guile #f) (imported-modules %python-build-system-modules) (modules '((guix build python-build-system) - (guix build utils)))) + (guix build utils))) + allowed-references + disallowed-references) "Build SOURCE using PYTHON, and with INPUTS. This assumes that SOURCE provides a 'setup.py' file as its build system." (define build @@ -204,14 +206,15 @@ provides a 'setup.py' file as its build system." 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))) + #:guile-for-build guile + #:allowed-references allowed-references + #:disallowed-references disallowed-references))) (define python-build-system (build-system diff --git a/guix/build-system/qt.scm b/guix/build-system/qt.scm index 978aed0fc1..d1f721c54e 100644 --- a/guix/build-system/qt.scm +++ b/guix/build-system/qt.scm @@ -4,6 +4,7 @@ ;;; Copyright © 2017 Ricardo Wurmus <rekado@elephly.net> ;;; Copyright © 2019 Hartmut Goebel <h.goebel@crazy-compilers.com> ;;; Copyright © 2020 Jakub Kądziołka <kuba@kadziolka.net> +;;; Copyright © 2021 Maxime Devos <maximedevos@telenet.be> ;;; Copyright © 2022 Maxim Cournoyer <maxim.cournoyer@gmail.com> ;;; ;;; This file is part of GNU Guix. @@ -130,7 +131,7 @@ (build-type "RelWithDebInfo") (tests? #t) (test-target "test") - (parallel-build? #t) (parallel-tests? #f) + (parallel-build? #t) (parallel-tests? #t) (validate-runpath? #t) (patch-shebangs? #t) (strip-binaries? #t) @@ -142,7 +143,9 @@ (system (%current-system)) (imported-modules %qt-build-system-modules) (modules '((guix build qt-build-system) - (guix build utils)))) + (guix build utils))) + allowed-references + disallowed-references) "Build SOURCE using CMAKE, and with INPUTS. This assumes that SOURCE provides a 'CMakeLists.txt' file as its build system." (define builder @@ -181,7 +184,9 @@ provides a 'CMakeLists.txt' file as its build system." (gexp->derivation name builder #:graft? #f ;consistent with 'gnu-build' #:system system - #:guile-for-build guile))) + #:guile-for-build guile + #:allowed-references allowed-references + #:disallowed-references disallowed-references))) ;;; @@ -214,7 +219,9 @@ provides a 'CMakeLists.txt' file as its build system." (build (nix-system->gnu-triplet system)) (imported-modules %qt-build-system-modules) (modules '((guix build qt-build-system) - (guix build utils)))) + (guix build utils))) + allowed-references + disallowed-references) "Cross-build NAME using CMAKE for TARGET, where TARGET is a GNU triplet and with INPUTS. This assumes that SOURCE provides a 'CMakeLists.txt' file as its build system." @@ -268,7 +275,9 @@ build system." (gexp->derivation name builder #:graft? #f ;consistent with 'gnu-build' #:system system - #:guile-for-build guile))) + #:guile-for-build guile + #:allowed-references allowed-references + #:disallowed-references disallowed-references))) (define qt-build-system (build-system diff --git a/guix/build-system/r.scm b/guix/build-system/r.scm index 37786f02a0..92449c7dbb 100644 --- a/guix/build-system/r.scm +++ b/guix/build-system/r.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2015-2023 Ricardo Wurmus <rekado@elephly.net> +;;; Copyright © 2015-2024 Ricardo Wurmus <rekado@elephly.net> ;;; Copyright © 2021 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. @@ -60,7 +60,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.19" + (string-append "https://bioconductor.org/packages/3.20" type-url-part "/src/contrib/" name "_" version ".tar.gz")))) @@ -68,7 +68,7 @@ release corresponding to NAME and VERSION." (define %r-build-system-modules ;; Build-side modules imported by default. `((guix build r-build-system) - ,@%gnu-build-system-modules)) + ,@%default-gnu-imported-modules)) (define (default-r) "Return the default R package." @@ -107,6 +107,7 @@ release corresponding to NAME and VERSION." source (tests? #t) (test-target "tests") + (test-types #f) (configure-flags ''()) (phases '%standard-phases) (outputs '("out")) @@ -128,6 +129,7 @@ release corresponding to NAME and VERSION." #:system #$system #:tests? #$tests? #:test-target #$test-target + #:test-types #$test-types #:phases #$phases #:outputs #$(outputs->gexp outputs) #:search-paths '#$(sexp->gexp diff --git a/guix/build-system/rakudo.scm b/guix/build-system/rakudo.scm index 3b30fdfd0e..ee13c50791 100644 --- a/guix/build-system/rakudo.scm +++ b/guix/build-system/rakudo.scm @@ -41,7 +41,7 @@ (define %rakudo-build-system-modules ;; Build-side modules imported by default. `((guix build rakudo-build-system) - ,@%gnu-build-system-modules)) + ,@%default-gnu-imported-modules)) (define (default-rakudo) "Return the default Rakudo package." diff --git a/guix/build-system/rebar.scm b/guix/build-system/rebar.scm index de1294ec3f..7c7cc5870f 100644 --- a/guix/build-system/rebar.scm +++ b/guix/build-system/rebar.scm @@ -56,7 +56,7 @@ and VERSION." (define %rebar-build-system-modules ;; Build-side modules imported by default. `((guix build rebar-build-system) - ,@%gnu-build-system-modules)) + ,@%default-gnu-imported-modules)) (define (default-rebar3) "Return the default Rebar3 package." diff --git a/guix/build-system/renpy.scm b/guix/build-system/renpy.scm index 3039e3c63b..015dd7c210 100644 --- a/guix/build-system/renpy.scm +++ b/guix/build-system/renpy.scm @@ -44,7 +44,7 @@ `((guix build renpy-build-system) (guix build json) (guix build python-build-system) - ,@%gnu-build-system-modules)) + ,@%default-gnu-imported-modules)) (define* (lower name #:key source inputs native-inputs outputs system target diff --git a/guix/build-system/ruby.scm b/guix/build-system/ruby.scm index a3793a9381..33aab5f719 100644 --- a/guix/build-system/ruby.scm +++ b/guix/build-system/ruby.scm @@ -39,7 +39,7 @@ NAME and VERSION." (define %ruby-build-system-modules ;; Build-side modules imported by default. `((guix build ruby-build-system) - ,@%gnu-build-system-modules)) + ,@%default-gnu-imported-modules)) (define (default-ruby) "Return the default Ruby package." diff --git a/guix/build-system/scons.scm b/guix/build-system/scons.scm index 046ddef740..e76c419b1e 100644 --- a/guix/build-system/scons.scm +++ b/guix/build-system/scons.scm @@ -39,7 +39,7 @@ (define %scons-build-system-modules ;; Build-side modules imported by default. `((guix build scons-build-system) - ,@%gnu-build-system-modules)) + ,@%default-gnu-imported-modules)) (define (default-scons) "Return the default SCons package." diff --git a/guix/build-system/texlive.scm b/guix/build-system/texlive.scm index 88372faa58..35587b50fc 100644 --- a/guix/build-system/texlive.scm +++ b/guix/build-system/texlive.scm @@ -29,12 +29,10 @@ #:use-module (guix build-system gnu) #:use-module (guix svn-download) #:export (%texlive-build-system-modules + %texlive-repository texlive-build texlive-build-system - texlive-ref - texlive-origin - %texlive-tag - %texlive-revision)) + texlive-packages-repository)) ;; Commentary: ;; @@ -42,43 +40,18 @@ ;; ;; Code: -;; These variables specify the SVN tag and the matching SVN revision. They -;; are taken from https://www.tug.org/svn/texlive/tags/ -(define %texlive-tag "texlive-2023.0") -(define %texlive-revision 66594) - -(define (texlive-origin name version locations hash) - "Return an <origin> object for a TeX Live package consisting of multiple -LOCATIONS with a provided HASH. Use NAME and VERSION to compute a prettier -name for the checkout directory." - (origin - (method svn-multi-fetch) - (uri (svn-multi-reference - (url (string-append "svn://www.tug.org/texlive/tags/" - %texlive-tag "/Master/texmf-dist/")) - (locations locations) - (revision %texlive-revision))) - (file-name (string-append name "-" version "-checkout")) - (sha256 hash))) - -(define* (texlive-ref component #:optional id) - "Return a <svn-reference> object for the package ID, which is part of the -given Texlive COMPONENT. If ID is not provided, COMPONENT is used as the top -level package ID." - (svn-reference - (url (string-append "svn://www.tug.org/texlive/tags/" - %texlive-tag "/Master/texmf-dist/" - "source/" component - (if id - (string-append "/" id) - ""))) - (revision %texlive-revision))) +(define %texlive-repository "svn://www.tug.org/texlive/") + +(define (texlive-packages-repository version) + "Return URL for packages location in TeX Live repository, at VERSION." + (string-append + %texlive-repository "tags/texlive-" version "/Master/texmf-dist")) (define %texlive-build-system-modules ;; Build-side modules imported by default. `((guix build texlive-build-system) (guix build union) - ,@%gnu-build-system-modules)) + ,@%default-gnu-imported-modules)) (define (default-texlive-bin) "Return the default texlive-bin package." diff --git a/guix/build-system/waf.scm b/guix/build-system/waf.scm index 91b3d0d100..5f24615514 100644 --- a/guix/build-system/waf.scm +++ b/guix/build-system/waf.scm @@ -42,7 +42,7 @@ (define %waf-build-system-modules ;; Build-side modules imported by default. `((guix build waf-build-system) - ,@%gnu-build-system-modules)) + ,@%default-gnu-imported-modules)) (define* (lower name #:key source inputs native-inputs outputs system target diff --git a/guix/build-system/zig.scm b/guix/build-system/zig.scm index 1fa4782a2e..ad8a96b607 100644 --- a/guix/build-system/zig.scm +++ b/guix/build-system/zig.scm @@ -39,7 +39,7 @@ (define %zig-build-system-modules ;; Build-side modules imported by default. `((guix build zig-build-system) - ,@%gnu-build-system-modules)) + ,@%default-gnu-imported-modules)) (define* (zig-build name inputs #:key diff --git a/guix/build/agda-build-system.scm b/guix/build/agda-build-system.scm index 49836d5dea..8770710b90 100644 --- a/guix/build/agda-build-system.scm +++ b/guix/build/agda-build-system.scm @@ -29,7 +29,8 @@ (define* (set-locpath #:key inputs native-inputs #:allow-other-keys) (let ((locales (assoc-ref (or native-inputs inputs) "locales"))) - (setenv "GUIX_LOCPATH" (string-append locales "/lib/locale")))) + (when locales + (setenv "GUIX_LOCPATH" (string-append locales "/lib/locale"))))) (define %agda-possible-extensions (cons diff --git a/guix/build/cargo-build-system.scm b/guix/build/cargo-build-system.scm index 70ddf063d2..8dcbd461a8 100644 --- a/guix/build/cargo-build-system.scm +++ b/guix/build/cargo-build-system.scm @@ -119,7 +119,7 @@ libraries or executables." (error "Possible pre-generated files found:" pregenerated-files)))) (define* (configure #:key inputs - target + target system (vendor-dir "guix-vendor") #:allow-other-keys) "Vendor Cargo.toml dependencies as guix inputs." @@ -179,6 +179,10 @@ libraries or executables." ;; Prevent targeting the build machine. (setenv "CRATE_CC_NO_DEFAULTS" "1")) + ;; Support 16k kernel page sizes on aarch64 with jemalloc. + (when (string-prefix? "aarch64" (or target system)) + (setenv "JEMALLOC_SYS_WITH_LG_PAGE" "14")) + ;; Configure cargo to actually use this new directory with all the crates. (setenv "CARGO_HOME" (string-append (getcwd) "/.cargo")) (mkdir-p ".cargo") @@ -219,6 +223,7 @@ directory = '" vendor-dir "'") port) (setenv "LIBGIT2_SYS_USE_PKG_CONFIG" "1") (setenv "LIBSSH2_SYS_USE_PKG_CONFIG" "1") + (setenv "ZSTD_SYS_USE_PKG_CONFIG" "1") (when (assoc-ref inputs "openssl") (setenv "OPENSSL_DIR" (assoc-ref inputs "openssl"))) (when (assoc-ref inputs "gettext") diff --git a/guix/build/chicken-build-system.scm b/guix/build/chicken-build-system.scm index 8f9f59cc25..fd5a33fd22 100644 --- a/guix/build/chicken-build-system.scm +++ b/guix/build/chicken-build-system.scm @@ -93,13 +93,14 @@ unpacking." (define* (build #:key egg-name #:allow-other-keys) "Build the Chicken egg named by EGG-NAME" - (invoke "chicken-install" "-cached" "-no-install" egg-name)) + (chdir egg-name) + (invoke "chicken-install" "-cached" "-no-install")) -(define* (install #:key egg-name #:allow-other-keys) +(define (install . _) "Install the already built egg named by EGG-NAME" - (invoke "chicken-install" "-cached" egg-name)) + (invoke "chicken-install" "-cached")) -(define* (check #:key egg-name tests? #:allow-other-keys) +(define* (check #:key tests? #:allow-other-keys) "Build and run tests for the Chicken egg EGG-NAME" ;; there is no "-test-only" option, but we've already run install ;; so this just runs tests. @@ -109,7 +110,7 @@ unpacking." ":" (getenv "CHICKEN_REPOSITORY_PATH"))) (when tests? - (invoke "chicken-install" "-cached" "-test" "-no-install" egg-name))) + (invoke "chicken-install" "-cached" "-test" "-no-install"))) (define* (stamp-egg-version #:key egg-name name #:allow-other-keys) "Check if EGG-NAME.egg contains version information and add some if not." diff --git a/guix/build/composer-build-system.scm b/guix/build/composer-build-system.scm index 8896384e0a..8d7d43236e 100644 --- a/guix/build/composer-build-system.scm +++ b/guix/build/composer-build-system.scm @@ -191,13 +191,11 @@ $loader->register(); (cons* (string-join (string-split key #\\) "\\\\") (append-map (lambda (v) (list vendor v)) vals))))) (_ (format #t ""))) - (delete-duplicates - (append - (composer-autoload-psr-4 autoload) - (if (and dev-dependencies? (not (null? autoload-dev))) - (composer-autoload-psr-4 autoload-dev) - '())) - '())) + (append + (composer-autoload-psr-4 autoload) + (if (and dev-dependencies? (not (null? autoload-dev))) + (composer-autoload-psr-4 autoload-dev) + '()))) (for-each (lambda (psr0) (match psr0 diff --git a/guix/build/copy-build-system.scm b/guix/build/copy-build-system.scm index fb2d1db056..25d3f4c57a 100644 --- a/guix/build/copy-build-system.scm +++ b/guix/build/copy-build-system.scm @@ -2,6 +2,7 @@ ;;; Copyright © 2019 Julien Lepiller <julien@lepiller.eu> ;;; Copyright © 2020 Pierre Neidhardt <mail@ambrevar.xyz> ;;; Copyright © 2021 Efraim Flashner <efraim@flashner.co.il> +;;; Copyright © 2023 Bruno Victal <mirai@makinata.eu> ;;; ;;; This file is part of GNU Guix. ;;; @@ -40,9 +41,9 @@ An install plan is a list of plans in the form: - (SOURCE TARGET [FILTERS]) + (SOURCE TARGET [FILTERS] [#:output OUTPUT]) -In the above, FILTERS are optional. +In the above, FILTERS and OUTPUT are optional. - When SOURCE matches a file or directory without trailing slash, install it to TARGET. @@ -63,6 +64,9 @@ In the above, FILTERS are optional. If both `#:include*` and `#:exclude*` are specified, the exclusion is done on the inclusion list. +- When a package has multiple outputs, the `#:output` argument can be used +to specify which output label the files should be installed to. + Examples: - `(\"foo/bar\" \"share/my-app/\")`: Install bar to \"share/my-app/bar\". @@ -72,7 +76,9 @@ Examples: - `(\"foo/\" \"share/my-app\" #:include (\"sub/file\"))`: Install only \"foo/sub/file\" to \"share/my-app/sub/file\". - `(\"foo/sub\" \"share/my-app\" #:include (\"file\"))`: Install \"foo/sub/file\" to -\"share/my-app/file\"." +\"share/my-app/file\". +- `(\"foo/doc\" \"share/my-app/doc\" #:output \"doc\")`: Install \"foo/doc\" to +\"share/my-app/doc\" within the \"doc\" output." (define (install-simple source target) "Install SOURCE to TARGET. TARGET must point to a store location. @@ -133,8 +139,10 @@ given, then the predicate always returns DEFAULT-VALUE." (string-append target "/"))) file-list)))) - (define* (install source target #:key include exclude include-regexp exclude-regexp) - (let ((final-target (string-append (assoc-ref outputs "out") "/" target)) + (define* (install source target + #:key include exclude include-regexp exclude-regexp + (output "out")) + (let ((final-target (string-append (assoc-ref outputs output) "/" target)) (filters? (or include exclude include-regexp exclude-regexp))) (when (and (not (file-is-directory? source)) filters?) diff --git a/guix/build/font-build-system.scm b/guix/build/font-build-system.scm index e4784bc17d..ad81d07b7b 100644 --- a/guix/build/font-build-system.scm +++ b/guix/build/font-build-system.scm @@ -1,6 +1,7 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2017, 2022 Arun Isaac <arunisaac@systemreboot.net> ;;; Copyright © 2017 Alex Griffin <a@ajgrf.com> +;;; Copyright © 2024 宋文武 <iyzsong@envs.net> ;;; ;;; This file is part of GNU Guix. ;;; @@ -23,6 +24,7 @@ #:use-module (srfi srfi-1) #:use-module (srfi srfi-26) #:export (%standard-phases + %license-file-regexp font-build)) ;; Commentary: @@ -48,13 +50,39 @@ archive, or a font file." "Install the package contents." (let* ((out (assoc-ref outputs "out")) (source (getcwd)) - (fonts (string-append out "/share/fonts"))) - (for-each (cut install-file <> (string-append fonts "/truetype")) + (truetype-dir (string-append (or (assoc-ref outputs "ttf") out) + "/share/fonts/truetype")) + (opentype-dir (string-append (or (assoc-ref outputs "otf") out) + "/share/fonts/opentype")) + (web-dir (string-append (or (assoc-ref outputs "woff") out) + "/share/fonts/web")) + (otb-dir (string-append (or (assoc-ref outputs "otb") out) + "/share/fonts/misc")) + (bdf-dir (string-append (or (assoc-ref outputs "bdf") out) + "/share/fonts/misc")) + (pcf-dir (string-append (or (assoc-ref outputs "pcf") out) + "/share/fonts/misc")) + (psf-dir (string-append (or (assoc-ref outputs "psf") out) + "/share/consolefonts"))) + (for-each (cut install-file <> truetype-dir) (find-files source "\\.(ttf|ttc)$")) - (for-each (cut install-file <> (string-append fonts "/opentype")) + (for-each (cut install-file <> opentype-dir) (find-files source "\\.(otf|otc)$")) - (for-each (cut install-file <> (string-append fonts "/web")) - (find-files source "\\.(woff|woff2)$")))) + (for-each (cut install-file <> web-dir) + (find-files source "\\.(woff|woff2)$")) + (for-each (cut install-file <> otb-dir) + (find-files source "\\.otb$")) + (for-each (cut install-file <> bdf-dir) + (find-files source "\\.bdf$")) + (for-each (cut install-file <> pcf-dir) + (find-files source "\\.pcf$")) + (for-each (cut install-file <> psf-dir) + (find-files source "\\.psfu$")))) + +(define %license-file-regexp + ;; Regexp matching license files commonly found in font packages. + "^((COPY(ING|RIGHT)|LICEN[CS]E).*\ +|(([Cc]opy[Rr]ight|[Ll]icen[cs]es?|IPA_.*|OFL(-?1\\.?1)?)(\\.(txt|md)?))$)") (define %standard-phases (modify-phases gnu:%standard-phases diff --git a/guix/build/gnu-build-system.scm b/guix/build/gnu-build-system.scm index ef5873d793..0b94416a8d 100644 --- a/guix/build/gnu-build-system.scm +++ b/guix/build/gnu-build-system.scm @@ -2,7 +2,7 @@ ;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2018 Mark H Weaver <mhw@netris.org> ;;; Copyright © 2020 Brendan Tildesley <mail@brendan.scot> -;;; Copyright © 2021 Maxim Cournoyer <maxim.cournoyer@gmail.com> +;;; Copyright © 2021, 2022 Maxim Cournoyer <maxim.cournoyer@gmail.com> ;;; ;;; This file is part of GNU Guix. ;;; @@ -72,6 +72,42 @@ there are none." ((first . _) first) (_ #f))) +(define* (separate-from-pid1 #:key (separate-from-pid1? #t) + #:allow-other-keys) + "When running as PID 1 and SEPARATE-FROM-PID1? is true, run build phases as +a child process; PID 1 then becomes responsible for reaping child processes." + (if separate-from-pid1? + (if (= 1 (getpid)) + (dynamic-wind + (const #t) + (lambda () + (match (primitive-fork) + (0 #t) + (builder-pid + (format (current-error-port) + "build process now running as PID ~a~%" + builder-pid) + (let loop () + ;; Running as PID 1 so take responsibility for reaping + ;; child processes. + (match (waitpid WAIT_ANY) + ((pid . status) + (if (= pid builder-pid) + (if (zero? status) + (primitive-exit 0) + (begin + (format (current-error-port) + "build process ~a exited with status ~a~%" + pid status) + (primitive-exit 1))) + (loop)))))))) + (const #t)) + (format (current-error-port) "not running as PID 1 (PID: ~a)~%" + (getpid))) + (format (current-error-port) + "build process running as PID ~a; not forking~%" + (getpid)))) + (define* (set-paths #:key target inputs native-inputs (search-paths '()) (native-search-paths '()) #:allow-other-keys) @@ -123,7 +159,7 @@ there are none." native-search-paths))) (define* (install-locale #:key - (locale "en_US.utf8") + (locale "C.UTF-8") (locale-category LC_ALL) #:allow-other-keys) "Try to install LOCALE; emit a warning if that fails. The main goal is to @@ -608,21 +644,36 @@ and 'man/'. This phase moves directories to the right place if needed." (((names . directories) ...) (for-each process-directory directories)))) -(define* (compress-documentation #:key outputs +(define* (compress-documentation #:key + outputs (compress-documentation? #t) - (documentation-compressor "gzip") - (documentation-compressor-flags + (info-compressor "gzip") + (info-compressor-flags '("--best" "--no-name")) - (compressed-documentation-extension ".gz") + (info-compressor-file-extension ".gz") + (man-compressor (if (which "zstd") + "zstd" + info-compressor)) + (man-compressor-flags + (if (which "zstd") + (list "-19" "--rm" + "--threads" (number->string + (parallel-job-count))) + info-compressor-flags)) + (man-compressor-file-extension + (if (which "zstd") + ".zst" + info-compressor-file-extension)) #:allow-other-keys) - "When COMPRESS-DOCUMENTATION? is true, compress man pages and Info files -found in OUTPUTS using DOCUMENTATION-COMPRESSOR, called with -DOCUMENTATION-COMPRESSOR-FLAGS." - (define (retarget-symlink link) + "When COMPRESS-INFO-MANUALS? is true, compress Info files found in OUTPUTS +using INFO-COMPRESSOR, called with INFO-COMPRESSOR-FLAGS. Similarly, when +COMPRESS-MAN-PAGES? is true, compress man pages files found in OUTPUTS using +MAN-COMPRESSOR, using MAN-COMPRESSOR-FLAGS." + (define (retarget-symlink link extension) (let ((target (readlink link))) (delete-file link) - (symlink (string-append target compressed-documentation-extension) - (string-append link compressed-documentation-extension)))) + (symlink (string-append target extension) + (string-append link extension)))) (define (has-links? file) ;; Return #t if FILE has hard links. @@ -640,23 +691,23 @@ DOCUMENTATION-COMPRESSOR-FLAGS." (symbolic-link? target-absolute)) (lambda args (if (= ENOENT (system-error-errno args)) - (begin - (format (current-error-port) - "The symbolic link '~a' target is missing: '~a'\n" - symlink target-absolute) - #f) + (format (current-error-port) + "The symbolic link '~a' target is missing: '~a'\n" + symlink target-absolute) (apply throw args)))))) - (define (maybe-compress-directory directory regexp) + (define (maybe-compress-directory directory regexp + compressor + compressor-flags + compressor-extension) (when (directory-exists? directory) (match (find-files directory regexp) - (() ;nothing to compress + (() ;nothing to compress #t) - ((files ...) ;one or more files + ((files ...) ;one or more files (format #t "compressing documentation in '~a' with ~s and flags ~s~%" - directory documentation-compressor - documentation-compressor-flags) + directory compressor compressor-flags) (call-with-values (lambda () (partition symbolic-link? files)) @@ -666,20 +717,26 @@ DOCUMENTATION-COMPRESSOR-FLAGS." ;; unchanged ('gzip' would refuse to compress them anyway.) ;; Also, do not retarget symbolic links pointing to other ;; symbolic links, since these are not compressed. - (for-each retarget-symlink + (for-each (cut retarget-symlink <> compressor-extension) (filter (lambda (symlink) (and (not (points-to-symlink? symlink)) (string-match regexp symlink))) symlinks)) - (apply invoke documentation-compressor - (append documentation-compressor-flags + (apply invoke compressor + (append compressor-flags (remove has-links? regular-files))))))))) (define (maybe-compress output) (maybe-compress-directory (string-append output "/share/man") - "\\.[0-9]+$") + "\\.[0-9]+[:alpha:]*$" + man-compressor + man-compressor-flags + man-compressor-file-extension) (maybe-compress-directory (string-append output "/share/info") - "\\.info(-[0-9]+)?$")) + "\\.info(-[0-9]+)?$" + info-compressor + info-compressor-flags + info-compressor-file-extension)) (if compress-documentation? (match outputs @@ -872,7 +929,8 @@ that traversing all the RUNPATH entries entails." ;; Standard build phases, as a list of symbol/procedure pairs. (let-syntax ((phases (syntax-rules () ((_ p ...) `((p . ,p) ...))))) - (phases set-SOURCE-DATE-EPOCH set-paths install-locale unpack + (phases separate-from-pid1 + set-SOURCE-DATE-EPOCH set-paths install-locale unpack bootstrap patch-usr-bin-file patch-source-shebangs configure patch-generated-file-shebangs diff --git a/guix/build/go-build-system.scm b/guix/build/go-build-system.scm index 7f25e05d0d..e53d8cb53c 100644 --- a/guix/build/go-build-system.scm +++ b/guix/build/go-build-system.scm @@ -4,8 +4,12 @@ ;;; Copyright © 2019 Maxim Cournoyer <maxim.cournoyer@gmail.com> ;;; Copyright © 2020 Jack Hill <jackhill@jackhill.us> ;;; Copyright © 2020 Jakub Kądziołka <kuba@kadziolka.net> -;;; Copyright © 2020, 2021 Efraim Flashner <efraim@flashner.co.il> +;;; Copyright © 2020, 2021, 2023, 2024 Efraim Flashner <efraim@flashner.co.il> ;;; Copyright © 2021 Sarah Morgensen <iskarian@mgsn.dev> +;;; Copyright © 2024 Ekaitz Zarraga <ekaitz@elenq.tech> +;;; Copyright © 2024 Picnoir <picnoir@alternativebit.fr> +;;; Copyright © 2024 Troy Figiel <troy@troyfigiel.com> +;;; Copyright © 2024 Sharlatan Hellseher <sharlatanus@gmail.com> ;;; ;;; This file is part of GNU Guix. ;;; @@ -26,8 +30,9 @@ #:use-module ((guix build gnu-build-system) #:prefix gnu:) #:use-module (guix build union) #:use-module (guix build utils) - #:use-module (ice-9 match) + #:use-module (ice-9 format) #:use-module (ice-9 ftw) + #:use-module (ice-9 match) #:use-module (srfi srfi-1) #:use-module (rnrs io ports) #:use-module (rnrs bytevectors) @@ -90,7 +95,6 @@ ;; * Use Go modules [4] ;; * Re-use compiled packages [5] ;; * Avoid the go-inputs hack -;; * Stop needing remove-go-references (-trimpath ? ) ;; * Remove module packages, only offering the full Git repos? This is ;; more idiomatic, I think, because Go downloads Git repos, not modules. ;; What are the trade-offs? @@ -200,6 +204,30 @@ dependencies, so it should be self-contained." (delete-file-recursively tmpdir)) #t) +(define* (fix-embed-files #:key embed-files #:allow-other-keys) + "Golang cannot determine the valid directory of the module of an embed file +which is symlinked during setup environment phase, but easily resolved after +copying the file from the store to the build directory of the current package. +Take a list of files or regexps matching files from EMBED-FILES parameter, +fail over to 'editions_defaults.binpb' which is a part of +<github.com/golang/protobuf>." + ;; For the details, consult the Golang source: + ;; + ;; - URL: <https://raw.githubusercontent.com/golang/go/> + ;; - commit: 82c14346d89ec0eeca114f9ca0e88516b2cda454 + ;; - file: src/cmd/go/internal/load/pkg.go + ;; - line: 2059 + (let ((embed-files (format #f "^(~{~a|~}~a)$" + embed-files + "editions_defaults.binpb"))) + (for-each (lambda (file) + (when (eq? (stat:type (lstat file)) + 'symlink) + (let ((file-store-path (readlink file))) + (delete-file file) + (copy-recursively file-store-path file)))) + (find-files "src" embed-files)))) + (define* (unpack #:key source import-path unpack-path #:allow-other-keys) "Relative to $GOPATH, unpack SOURCE in UNPACK-PATH, or IMPORT-PATH when UNPACK-PATH is unset. If the SOURCE archive has a single top level directory, @@ -227,9 +255,10 @@ unpacking." (when (string-null? import-path) (display "WARNING: The Go import path is unset.\n")) - (when (string-null? unpack-path) - (set! unpack-path import-path)) - (let ((dest (string-append (getenv "GOPATH") "/src/" unpack-path))) + (let ((dest (string-append (getenv "GOPATH") "/src/" + (if (string-null? unpack-path) + import-path + unpack-path)))) (mkdir-p dest) (if (file-is-directory? source) (copy-recursively source dest #:keep-mtime? #t) @@ -254,8 +283,12 @@ unpacking." (_ #f)) inputs)))) -(define* (build #:key import-path build-flags #:allow-other-keys) +(define* (build #:key import-path build-flags (parallel-build? #t) + #:allow-other-keys) "Build the package named by IMPORT-PATH." + (let* ((njobs (if parallel-build? (parallel-job-count) 1))) + (setenv "GOMAXPROCS" (number->string njobs))) + (with-throw-handler #t (lambda _ @@ -265,17 +298,20 @@ unpacking." ;; Respectively, strip the symbol table and debug ;; information, and the DWARF symbol table. "-ldflags=-s -w" + "-trimpath" `(,@build-flags ,import-path))) (lambda (key . args) (display (string-append "Building '" import-path "' failed.\n" "Here are the results of `go env`:\n")) (invoke "go" "env")))) -;; Can this also install commands??? -(define* (check #:key tests? import-path #:allow-other-keys) +(define* (check #:key tests? import-path test-flags (parallel-tests? #t) + #:allow-other-keys) "Run the tests for the package named by IMPORT-PATH." (when tests? - (invoke "go" "test" import-path)) + (let* ((njobs (if parallel-tests? (parallel-job-count) 1))) + (setenv "GOMAXPROCS" (number->string njobs))) + (apply invoke "go" "test" `(,import-path ,@test-flags))) #t) (define* (install #:key install-source? outputs import-path unpack-path #:allow-other-keys) @@ -304,58 +340,6 @@ the standard install-license-files phase to first enter the correct directory." unpack-path)) (apply (assoc-ref gnu:%standard-phases 'install-license-files) args))) -(define* (remove-store-reference file file-name - #:optional (store (%store-directory))) - "Remove from FILE occurrences of FILE-NAME in STORE; return #t when FILE-NAME -is encountered in FILE, #f otherwise. This implementation reads FILE one byte at -a time, which is slow. Instead, we should use the Boyer-Moore string search -algorithm; there is an example in (guix build grafts)." - (define pattern - (string-take file-name - (+ 34 (string-length (%store-directory))))) - - (with-fluids ((%default-port-encoding #f)) - (with-atomic-file-replacement file - (lambda (in out) - ;; We cannot use `regexp-exec' here because it cannot deal with - ;; strings containing NUL characters. - (format #t "removing references to `~a' from `~a'...~%" file-name file) - (setvbuf in 'block 65536) - (setvbuf out 'block 65536) - (fold-port-matches (lambda (match result) - (put-bytevector out (string->utf8 store)) - (put-u8 out (char->integer #\/)) - (put-bytevector out - (string->utf8 - "eeeeeeeeeeeeeeeeeeeeeeeeeeeeeeee-")) - #t) - #f - pattern - in - (lambda (char result) - (put-u8 out (char->integer char)) - result)))))) - -(define* (remove-go-references #:key allow-go-reference? - inputs outputs #:allow-other-keys) - "Remove any references to the Go compiler from the compiled Go executable -files in OUTPUTS." -;; We remove this spurious reference to save bandwidth when installing Go -;; executables. It would be better to not embed the reference in the first -;; place, but I'm not sure how to do that. The subject was discussed at: -;; <https://lists.gnu.org/archive/html/guix-devel/2017-10/msg00207.html> - (if allow-go-reference? - #t - (let ((go (assoc-ref inputs "go")) - (bin "/bin")) - (for-each (lambda (output) - (when (file-exists? (string-append (cdr output) - bin)) - (for-each (lambda (file) - (remove-store-reference file go)) - (find-files (string-append (cdr output) bin))))) - outputs) - #t))) (define %standard-phases (modify-phases gnu:%standard-phases @@ -364,11 +348,11 @@ files in OUTPUTS." (delete 'patch-generated-file-shebangs) (add-before 'unpack 'setup-go-environment setup-go-environment) (replace 'unpack unpack) + (add-after 'unpack 'fix-embed-files fix-embed-files) (replace 'build build) (replace 'check check) (replace 'install install) - (replace 'install-license-files install-license-files) - (add-after 'install 'remove-go-references remove-go-references))) + (replace 'install-license-files install-license-files))) (define* (go-build #:key inputs (phases %standard-phases) #:allow-other-keys #:rest args) diff --git a/guix/build/graft.scm b/guix/build/graft.scm index 281dbaba6f..49fabfea17 100644 --- a/guix/build/graft.scm +++ b/guix/build/graft.scm @@ -299,46 +299,6 @@ a list of store file name pairs." (string-append (dirname file) "/" target)))) matches))) -(define (exit-on-exception proc) - "Return a procedure that wraps PROC so that 'primitive-exit' is called when -an exception is caught." - (lambda (arg) - (catch #t - (lambda () - (proc arg)) - (lambda (key . args) - ;; Since ports are not thread-safe as of Guile 2.0, reopen stderr. - (let ((port (fdopen 2 "w0"))) - (print-exception port #f key args) - (primitive-exit 1)))))) - -;; We need this as long as we support Guile < 2.0.13. -(define* (mkdir-p* dir #:optional (mode #o755)) - "This is a variant of 'mkdir-p' that works around -<http://bugs.gnu.org/24659> by passing MODE explicitly in each 'mkdir' call." - (define absolute? - (string-prefix? "/" dir)) - - (define not-slash - (char-set-complement (char-set #\/))) - - (let loop ((components (string-tokenize dir not-slash)) - (root (if absolute? - "" - "."))) - (match components - ((head tail ...) - (let ((path (string-append root "/" head))) - (catch 'system-error - (lambda () - (mkdir path mode) - (loop tail path)) - (lambda args - (if (= EEXIST (system-error-errno args)) - (loop tail path) - (apply throw args)))))) - (() #t)))) - (define* (rewrite-directory directory output mapping #:optional (store (%store-directory))) "Copy DIRECTORY to OUTPUT, replacing strings according to MAPPING, a list of @@ -387,7 +347,8 @@ file name pairs." (define (rewrite-leaf file) (let ((stat (lstat file)) (dest (destination file))) - (mkdir-p* (dirname dest)) + (unless (file-exists? (dirname dest)) + (mkdir-p (dirname dest))) (case (stat:type stat) ((symlink) (let ((target (readlink file))) @@ -406,17 +367,14 @@ file name pairs." store) (chmod output (stat:perms stat))))))) ((directory) - (mkdir-p* dest)) + (mkdir-p dest)) (else (error "unsupported file type" stat))))) - ;; Use 'exit-on-exception' to force an exit upon I/O errors, given that - ;; 'n-par-for-each' silently swallows exceptions. - ;; See <http://bugs.gnu.org/23581>. - (n-par-for-each (parallel-job-count) - (exit-on-exception rewrite-leaf) - (find-files directory (const #t) - #:directories? #t)) + ;; n-par-for-each can lead to segfaults in the grafting code? + (for-each rewrite-leaf + (find-files directory (const #t) + #:directories? #t)) (rename-matching-files output mapping)) (define %graft-hooks diff --git a/guix/build/make-bootstrap.scm b/guix/build/make-bootstrap.scm index 0d29338ce3..287e4db2c7 100644 --- a/guix/build/make-bootstrap.scm +++ b/guix/build/make-bootstrap.scm @@ -1,6 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2015, 2017 Manolis Fragkiskos Ragkousis <manolis837@gmail.com> -;;; Copyright © 2015, 2019 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2015, 2019, 2024 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2018 Jan (janneke) Nieuwenhuizen <janneke@gnu.org> ;;; ;;; This file is part of GNU Guix. @@ -84,21 +84,37 @@ bootstrap libc." when producing a bootstrap libc." (define (copy-mach-headers output kernel-headers) - (let* ((incdir (string-append output "/include"))) + (let ((mach-headers (readlink + (string-append kernel-headers "/include/mach"))) + (incdir (string-append output "/include"))) (copy-recursively (string-append libc "/include") incdir) - (copy-recursively (string-append kernel-headers "/include/mach") - (string-append incdir "/mach")) - #t)) - + ;; As of glibc 2.39, essential Mach headers get installed by glibc + ;; itself in its own includedir, except for most of mach/machine/*.h. + ;; Copy anything that's missing from MACH-HEADERS. + (copy-recursively mach-headers + (string-append incdir "/mach") + #:select? + (let ((prefix (string-length mach-headers)) + (target (string-append incdir "/mach"))) + (lambda (file stat) + ;; Select everything but files and symlinks that + ;; already exist under TARGET. + (or (eq? 'directory (stat:type stat)) + (let ((suffix (string-drop file prefix))) + (not (file-exists? + (in-vicinity target suffix)))))))))) + (define (copy-libc+linux-headers output kernel-headers) (let* ((incdir (string-append output "/include"))) (copy-recursively (string-append libc "/include") incdir) (copy-linux-headers output kernel-headers))) + ;; Include *.so, *.so.*, but also empty ar archives provided for backward + ;; compatibility as of libc 2.39: libdl.a and libutil.a. (define %libc-object-files-rx "^(crt.*|ld.*|lib(c|m|dl|rt|pthread|nsl|\ util).*\\.so(\\..*)?|lib(machuser|hurduser).so.*|(libc(rt|)|libpthread)\ -_nonshared\\.a)$") +_nonshared\\.a|lib(dl|util)\\.a)$") (setvbuf (current-output-port) 'line) (let* ((libdir (string-append output "/lib"))) diff --git a/guix/build/minetest-build-system.scm b/guix/build/minetest-build-system.scm index 3bf083e004..305e9dc1ba 100644 --- a/guix/build/minetest-build-system.scm +++ b/guix/build/minetest-build-system.scm @@ -1,3 +1,4 @@ +;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2021 Maxime Devos <maximedevos@telenet.be> ;;; ;;; This file is part of GNU Guix. diff --git a/guix/build/mix-build-system.scm b/guix/build/mix-build-system.scm index fe2e36d184..6b7541cf56 100644 --- a/guix/build/mix-build-system.scm +++ b/guix/build/mix-build-system.scm @@ -1,5 +1,7 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2023 Pierre-Henry Fröhring <contact@phfrohring.com> +;;; Copyright © 2024 Igor Goryachev <igor@goryachev.org> +;;; Copyright © 2024 Giacomo Leidi <goodoldpaul@autistici.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -38,6 +40,9 @@ ;; minor version number of the Elixir used in the build. (define %elixir-version (make-parameter "X.Y")) +(define %git-version-rx + (make-regexp "^(.*)-[0-9]+(\\.[0-9]+)?(\\.[0-9]+)?-[0-9]+\\..+$")) + (define* (elixir-libdir path #:optional (version (%elixir-version))) "Return the path where all libraries under PATH for a specified Elixir VERSION are installed." @@ -91,7 +96,15 @@ See: https://hexdocs.pm/mix/1.15.7/Mix.html#module-environment-variables" (setenv "MIX_EXS" mix-exs) (setenv "MIX_HOME" (getcwd)) (setenv "MIX_PATH" (or mix-path "")) - (setenv "MIX_REBAR3" (string-append (assoc-ref inputs "rebar3") "/bin/rebar3"))) + (setenv "MIX_REBAR3" (string-append (assoc-ref inputs "rebar3") "/bin/rebar3")) + ;; Add Erlang dependencies in Elixir's load path. + (setenv "ERL_LIBS" + (string-join (search-path-as-list + `("lib/erlang/lib") + (map (match-lambda + ((label . package) package)) + inputs)) + ":"))) (define* (set-elixir-version #:key inputs #:allow-other-keys) "Store the version number of the Elixir input in a parameter." @@ -102,13 +115,17 @@ See: https://hexdocs.pm/mix/1.15.7/Mix.html#module-environment-variables" "Builds the Mix project." (for-each (lambda (mix-env) (setenv "MIX_ENV" mix-env) - (invoke "mix" "compile" "--no-deps-check")) + (invoke "mix" "compile" "--no-deps-check" + "--no-prune-code-paths")) mix-environments)) (define* (check #:key (tests? #t) #:allow-other-keys) "Test the Mix project." (if tests? - (invoke "mix" "test" "--no-deps-check") + (begin + (setenv "MIX_ENV" "test") + (invoke "mix" "do" "compile" "--no-deps-check" "--no-prune-code-paths" "+" + "test" "--no-deps-check")) (format #t "tests? = ~a~%" tests?))) (define* (remove-mix-dirs . _) @@ -119,10 +136,12 @@ We do not want to copy them to the installation directory." (define (package-name->elixir-name name+ver) "Convert the Guix package NAME-VER to the corresponding Elixir name-version -format. Example: elixir-a-pkg-1.2.3 -> a_pkg" +format. Example: elixir-a-pkg-1.2.3 -> a_pkg or elixir-a-pkg-0.0.0-0.e51e36e +-> a_pkg" + (define git-version? (regexp-exec %git-version-rx name+ver)) ((compose (cute string-join <> "_") - (cute drop-right <> 1) + (cute drop-right <> (if git-version? 2 1)) (cute string-split <> #\-)) (strip-prefix name+ver))) diff --git a/guix/build/pyproject-build-system.scm b/guix/build/pyproject-build-system.scm index c69ccc9d64..947d240114 100644 --- a/guix/build/pyproject-build-system.scm +++ b/guix/build/pyproject-build-system.scm @@ -21,6 +21,7 @@ #:use-module ((guix build python-build-system) #:prefix python:) #:use-module (guix build utils) #:use-module (guix build json) + #:use-module (guix build toml) #:use-module (ice-9 match) #:use-module (ice-9 ftw) #:use-module (ice-9 format) @@ -60,8 +61,8 @@ ;;; 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. +;;; This module also supports in-tree build backends, which can be +;;; overridden by #:backend-path. ;;; ;;; Code: ;;; @@ -86,23 +87,23 @@ ;; 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) +(define* (build #:key outputs build-backend backend-path 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")) + (pyproject.toml (if (file-exists? "pyproject.toml") + (parse-toml-file "pyproject.toml") + '())) + ;; backend-path is prepended to sys.path, so in-tree backends can be + ;; found. We assume toml is json-compatible and do not encode the resulting + ;; JSON list expression. + (auto-backend-path (recursive-assoc-ref + pyproject.toml + '("build-system" "backend-path"))) + (use-backend-path (call-with-output-string + (cut write-json + (or backend-path auto-backend-path '()) <>))) ;; 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. @@ -111,10 +112,9 @@ ;; 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)) + (auto-build-backend (recursive-assoc-ref + pyproject.toml + '("build-system" "build-backend"))) ;; 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. @@ -122,15 +122,22 @@ 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) + (string-append + "Using '~a' to build wheels, auto-detected '~a', override '~a'.~%" + "Prepending '~a' to sys.path, auto-detected '~a', override '~a'.~%") + use-build-backend auto-build-backend build-backend + use-backend-path auto-backend-path backend-path) (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)" +backend_path = json.loads (sys.argv[1]) or [] +backend_path.extend (sys.path) +sys.path = backend_path +config_settings = json.loads (sys.argv[4]) +builder = importlib.import_module(sys.argv[2]) +builder.build_wheel(sys.argv[3], config_settings=config_settings)" + use-backend-path use-build-backend wheel-dir config-settings))) diff --git a/guix/build/python-build-system.scm b/guix/build/python-build-system.scm index aa04664b25..8e18d6d0df 100644 --- a/guix/build/python-build-system.scm +++ b/guix/build/python-build-system.scm @@ -37,6 +37,7 @@ #:use-module (srfi srfi-26) #:export (%standard-phases add-installed-pythonpath + ensure-no-mtimes-pre-1980 site-packages python-version python-build)) @@ -270,7 +271,8 @@ installed with setuptools." ;; timestamps before 1980. (let ((early-1980 315619200)) ; 1980-01-02 UTC (ftw "." (lambda (file stat flag) - (unless (<= early-1980 (stat:mtime stat)) + (unless (or (<= early-1980 (stat:mtime stat)) + (eq? (stat:type stat) 'symlink)) (utime file early-1980 early-1980)) #t)))) diff --git a/guix/build/r-build-system.scm b/guix/build/r-build-system.scm index 2c0b322da9..01ce5b9d49 100644 --- a/guix/build/r-build-system.scm +++ b/guix/build/r-build-system.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2015, 2017, 2018 Ricardo Wurmus <rekado@elephly.net> +;;; Copyright © 2015, 2017, 2018, 2024 Ricardo Wurmus <rekado@elephly.net> ;;; ;;; This file is part of GNU Guix. ;;; @@ -20,10 +20,12 @@ #:use-module ((guix build gnu-build-system) #:prefix gnu:) #:use-module (guix build utils) #:use-module (ice-9 match) + #:use-module (ice-9 format) #:use-module (ice-9 ftw) #:use-module (ice-9 popen) #:use-module (srfi srfi-1) #:use-module (srfi srfi-26) + #:use-module (srfi srfi-34) #:use-module (srfi srfi-35) #:export (%standard-phases r-build)) @@ -40,14 +42,15 @@ (define (pipe-to-r command params) (let ((port (apply open-pipe* OPEN_WRITE "R" params))) (display command port) - (let ((code (status:exit-val (close-pipe port)))) + (let* ((closed (close-pipe port)) + (code (status:exit-val closed))) (unless (zero? code) (raise (condition ((@@ (guix build utils) &invoke-error) (program "R") (arguments (cons command params)) - (exit-status (status:exit-val code)) - (term-signal (status:term-sig code)) - (stop-signal (status:stop-sig code))))))))) + (exit-status code) + (term-signal (status:term-sig closed)) + (stop-signal (status:stop-sig closed))))))))) (define (generate-site-path inputs) (string-join (map (match-lambda @@ -60,7 +63,7 @@ inputs)) ":")) -(define* (check #:key test-target inputs outputs tests? #:allow-other-keys) +(define* (check #:key test-target test-types inputs outputs tests? #:allow-other-keys) "Run the test suite of a given R package." (let* ((libdir (string-append (assoc-ref outputs "out") "/site-library/")) @@ -77,11 +80,25 @@ (testdir (string-append libdir pkg-name "/" test-target)) (site-path (string-append libdir ":" (generate-site-path inputs)))) (when (and tests? (file-exists? testdir)) + ;; Skip tests that should be skipped on CI systems. + (setenv "CI" "1") + (setenv "NOT_CRAN" "skip") + (setenv "IS_BIOC_BUILD_MACHINE" "true") (setenv "R_LIBS_SITE" site-path) - (pipe-to-r (string-append "tools::testInstalledPackage(\"" pkg-name "\", " - "lib.loc = \"" libdir "\")") - '("--no-save" "--slave"))) - #t)) + (guard (c ((invoke-error? c) + ;; Dump the test suite log to facilitate debugging. + (display "\nTests failed, dumping logs.\n" + (current-error-port)) + (gnu:dump-file-contents "." ".*\\.Rout\\.fail$") + (raise c))) + (pipe-to-r (string-append "quit(status=tools::testInstalledPackage(\"" pkg-name "\", " + "lib.loc = \"" libdir "\", " + "errorsAreFatal=TRUE, " + (if test-types + (format #false "types=c(~{\"~a\"~^,~})" test-types) + "types=c(\"tests\", \"vignettes\")") + "))") + '("--no-save" "--slave")))))) (define* (install #:key outputs inputs (configure-flags '()) #:allow-other-keys) diff --git a/guix/build/svn.scm b/guix/build/svn.scm index 875d3c50ca..ea01e7ee65 100644 --- a/guix/build/svn.scm +++ b/guix/build/svn.scm @@ -46,7 +46,8 @@ valid Subversion revision. Return #t on success, #f otherwise." ;; Trust the server certificate. This is OK as we ;; verify the checksum later. This can be removed when ;; ca-certificates package is added. - "--trust-server-cert" "-r" (number->string revision) + "--trust-server-cert-failures=unknown-ca,cn-mismatch,expired,not-yet-valid,other" + "-r" (number->string revision) ;; Disable keyword substitutions (keywords are CVS-like strings ;; like "$Date$", "$Id$", and so on) for two reasons: (1) some diff --git a/guix/build/syscalls.scm b/guix/build/syscalls.scm index 39bcffd516..2c20edf058 100644 --- a/guix/build/syscalls.scm +++ b/guix/build/syscalls.scm @@ -1398,14 +1398,18 @@ exception if it's already taken." ;; Presumably we got EAGAIN or so. (throw 'flock-error err)))))) -(define* (lock-file file #:key (wait? #t)) - "Wait and acquire an exclusive lock on FILE. Return an open port." - (let ((port (open-file file "w0"))) - (fcntl-flock port 'write-lock #:wait? wait?) +(define* (lock-file file #:optional (mode "w0") + #:key (wait? #t)) + "Wait and acquire an exclusive lock on FILE. Return an open port according +to MODE." + (let ((port (open-file file mode))) + (fcntl-flock port + (if (output-port? port) 'write-lock 'read-lock) + #:wait? wait?) port)) (define (unlock-file port) - "Unlock PORT, a port returned by 'lock-file'." + "Unlock PORT, a port returned by 'lock-file', and close it." (fcntl-flock port 'unlock) (close-port port) #t) diff --git a/guix/build/texlive-build-system.scm b/guix/build/texlive-build-system.scm index a9fe9c80cc..4a1afc709b 100644 --- a/guix/build/texlive-build-system.scm +++ b/guix/build/texlive-build-system.scm @@ -2,7 +2,7 @@ ;;; Copyright © 2017 Ricardo Wurmus <rekado@elephly.net> ;;; Copyright © 2021 Maxim Cournoyer <maxim.cournoyer@gmail.com> ;;; Copyright © 2021 Thiago Jung Bauermann <bauermann@kolabnow.com> -;;; Copyright © 2023 Nicolas Goaziou <mail@nicolasgoaziou.fr> +;;; Copyright © 2023, 2024 Nicolas Goaziou <mail@nicolasgoaziou.fr> ;;; ;;; This file is part of GNU Guix. ;;; @@ -91,6 +91,12 @@ runfile to replace. If a file has no matching runfile, it is ignored." ((command-regexp _ command) (which command)))))) +(define* (set-texmfvar #:rest _) + "Set TEXMFVAR to a writable location." + ;; Default value is relative to $HOME, which is not set during build. This + ;; location is used for generating font metrics or building documentation. + (setenv "TEXMFVAR" (string-append (getcwd) "/texmf-var"))) + (define* (delete-drv-files #:rest _) "Delete pre-generated \".drv\" files in order to prevent build failures." (when (file-exists? "source") @@ -289,6 +295,7 @@ runfile to replace. If a file has no matching runfile, it is ignored." (delete 'bootstrap) (delete 'configure) (add-after 'unpack 'patch-shell-scripts patch-shell-scripts) + (add-before 'build 'set-texmfvar set-texmfvar) (add-before 'build 'delete-drv-files delete-drv-files) (add-after 'delete-drv-files 'generate-font-metrics generate-font-metrics) (replace 'build build) diff --git a/guix/build/toml.scm b/guix/build/toml.scm new file mode 100644 index 0000000000..81b54fa5b7 --- /dev/null +++ b/guix/build/toml.scm @@ -0,0 +1,481 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2023 Lars-Dominik Braun <lars@6xq.net> +;;; +;;; 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/>. + +;; This is a TOML parser adapted from the ABNF for v1.0.0 from +;; https://github.com/toml-lang/toml/blob/1.0.0/toml.abnf +;; The PEG grammar tries to follow the ABNF as closely as possible with +;; few deviations commented. +;; +;; The semantics are defined in https://toml.io/en/v1.0.0 +;; Currently unimplemented: +;; - Array of Tables + +(define-module (guix build toml) + #:use-module (ice-9 match) + #:use-module (ice-9 peg) + #:use-module (ice-9 textual-ports) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-19) + #:use-module (srfi srfi-35) + #:export (parse-toml parse-toml-file recursive-assoc-ref &file-not-consumed &already-defined)) + +(define-condition-type &toml-error &error toml-error?) +(define-condition-type &file-not-consumed &toml-error file-not-consumed?) +(define-condition-type &already-defined &toml-error already-defined?) + +;; Overall Structure +(define-peg-pattern toml-file body (and expression + (* (and ignore-newline expression)))) +(define-peg-pattern expression body (or + (and ws keyval ws (? comment)) + (and ws table ws (? comment)) + (and ws (? comment)))) + +;; Whitespace +(define-peg-pattern ws none (* wschar)) +(define-peg-pattern wschar body (or " " "\t")) + +;; Newline +(define-peg-pattern newline body (or "\n" "\r\n")) +;; This newline’s content is ignored, so we don’t need a bunch of (ignore newline). +(define-peg-pattern ignore-newline none newline) + +;; Comment +(define-peg-pattern non-ascii body (or (range #\x80 #\xd7ff) + (range #\xe000 #\x10ffff))) +(define-peg-pattern non-eol body (or "\t" (range #\x20 #\x7f) non-ascii)) + +(define-peg-pattern comment none (and "#" (* non-eol))) + +;; Key-Value pairs +(define-peg-pattern keyval all (and key keyval-sep val)) + +(define-peg-pattern key body (or dotted-key + simple-key)) +(define-peg-pattern simple-key all (or quoted-key + unquoted-key)) +(define-peg-pattern unquoted-key body (+ (or (range #\A #\Z) + (range #\a #\z) + (range #\0 #\9) + "-" + "_"))) +(define-peg-pattern quoted-key all (or basic-string + literal-string)) +(define-peg-pattern dotted-key body (and simple-key + (+ (and dot-sep simple-key)))) +(define-peg-pattern dot-sep none (and ws "." ws)) +(define-peg-pattern keyval-sep none (and ws "=" ws)) + +(define-peg-pattern val body (or string + boolean + array + inline-table + date-time + float + integer)) + +;; String +(define-peg-pattern string all (or ml-basic-string + basic-string + ml-literal-string + literal-string)) + +;; Basic String +(define-peg-pattern basic-string body (and (ignore "\"") + (or (+ basic-char) "") + (ignore "\""))) +(define-peg-pattern basic-char body (or basic-unescaped escaped)) +(define-peg-pattern basic-unescaped body (or wschar + "\x21" + (range #\x23 #\x5B) + (range #\x5D #\x7E) + non-ascii)) +(define-peg-pattern escaped all (and + (ignore "\\") + (or "\"" "\\" "b" "f" "n" "r" "t" + (and (ignore "u") + HEXDIG HEXDIG HEXDIG HEXDIG) + (and (ignore "U") + HEXDIG HEXDIG HEXDIG HEXDIG + HEXDIG HEXDIG HEXDIG HEXDIG)))) + +;; Multiline Basic String +(define-peg-pattern ml-basic-string body (and + ml-basic-string-delim + (? ignore-newline) + ;; Force the result of the empty string + ;; to be a string, not no token. + (and ml-basic-body "") + ml-basic-string-delim)) +(define-peg-pattern ml-basic-string-delim none "\"\"\"") +(define-peg-pattern ml-basic-body body (and + (* mlb-content) + (* (and mlb-quotes (+ mlb-content))) + (? mlb-quotes-final))) + +(define-peg-pattern mlb-content body (or mlb-char newline mlb-escaped-nl)) +(define-peg-pattern mlb-char body (or mlb-unescaped escaped)) +(define-peg-pattern mlb-quotes body (or "\"\"" "\"")) +;; We need to convince the parser to backtrack here, thus the additional followed-by rule. +(define-peg-pattern mlb-quotes-final body (or (and "\"\"" (followed-by + ml-basic-string-delim)) + (and "\"" (followed-by + ml-basic-string-delim)))) +(define-peg-pattern mlb-unescaped body (or wschar + "\x21" + (range #\x23 #\x5B) + (range #\x5D #\x7E) + non-ascii)) +;; Escaped newlines and following whitespace are removed from the output. +(define-peg-pattern mlb-escaped-nl none (and "\\" ws newline + (* (or wschar newline)))) + +;; Literal String +(define-peg-pattern literal-string body (and (ignore "'") + (or (+ literal-char) "") + (ignore "'"))) +(define-peg-pattern literal-char body (or "\x09" + (range #\x20 #\x26) + (range #\x28 #\x7E) + non-ascii)) + +;; Multiline Literal String +(define-peg-pattern ml-literal-string body (and + ml-literal-string-delim + (? ignore-newline) + ;; Force the result of the empty string + ;; to be a string, not no token. + (and ml-literal-body "") + ml-literal-string-delim)) +(define-peg-pattern ml-literal-string-delim none "'''") +(define-peg-pattern ml-literal-body body (and + (* mll-content) + (* (and mll-quotes (+ mll-content))) + (? mll-quotes-final))) + +(define-peg-pattern mll-content body (or mll-char newline)) +(define-peg-pattern mll-char body (or "\x09" + (range #\x20 #\x26) + (range #\x28 #\x7E) + non-ascii)) +(define-peg-pattern mll-quotes body (or "''" "'")) +;; We need to convince the parser to backtrack here, thus the additional followed-by rule. +(define-peg-pattern mll-quotes-final body (or (and "''" (followed-by + ml-literal-string-delim)) + (and "'" (followed-by + ml-literal-string-delim)))) + +;; Integer +(define-peg-pattern integer all (or hex-int oct-int bin-int dec-int)) + +(define-peg-pattern digit1-9 body (range #\1 #\9)) +(define-peg-pattern digit0-7 body (range #\0 #\7)) +(define-peg-pattern digit0-1 body (range #\0 #\1)) +(define-peg-pattern DIGIT body (range #\0 #\9)) +(define-peg-pattern HEXDIG body (or DIGIT + (range #\a #\f) + (range #\A #\F))) + +(define-peg-pattern dec-int all (and (? (or "-" "+")) unsigned-dec-int)) +(define-peg-pattern unsigned-dec-int body (or (and digit1-9 (+ (or DIGIT (and (ignore "_") DIGIT)))) + DIGIT)) + +(define-peg-pattern hex-int all (and (ignore "0x") + HEXDIG + (* (or HEXDIG (and (ignore "_") HEXDIG))))) +(define-peg-pattern oct-int all (and (ignore "0o") + digit0-7 + (* (or digit0-7 (and (ignore "_") digit0-7))))) +(define-peg-pattern bin-int all (and (ignore "0b") + digit0-1 + (* (or digit0-1 (and (ignore "_") digit0-1))))) + +;; Float +(define-peg-pattern float all (or + (and float-int-part (or exp (and frac (? exp)))) + special-float)) +(define-peg-pattern float-int-part body dec-int) +(define-peg-pattern frac body (and "." zero-prefixable-int)) +(define-peg-pattern zero-prefixable-int body (and DIGIT (* (or DIGIT (and (ignore "_") DIGIT))))) + +(define-peg-pattern exp body (and (or "e" "E") float-exp-part)) +(define-peg-pattern float-exp-part body (and (? (or "-" "+")) zero-prefixable-int)) +(define-peg-pattern special-float body (and (? (or "-" "+")) (or "inf" "nan"))) + +;; Boolean +(define-peg-pattern boolean all (or "true" "false")) + +;; Date and Time (as defined in RFC 3339) + +(define-peg-pattern date-time body (or offset-date-time + local-date-time + local-date + local-time)) + +(define-peg-pattern date-fullyear all (and DIGIT DIGIT DIGIT DIGIT)) +(define-peg-pattern date-month all (and DIGIT DIGIT)) ; 01-12 +(define-peg-pattern date-mday all (and DIGIT DIGIT)) ; 01-28, 01-29, 01-30, 01-31 based on month/year +(define-peg-pattern time-delim none (or "T" "t" " ")) ; T, t, or space +(define-peg-pattern time-hour all (and DIGIT DIGIT)) ; 00-23 +(define-peg-pattern time-minute all (and DIGIT DIGIT)) ; 00-59 +(define-peg-pattern time-second all (and DIGIT DIGIT)) ; 00-58, 00-59, 00-60 based on leap second rules +(define-peg-pattern time-secfrac all (and (ignore ".") (+ DIGIT))) +(define-peg-pattern time-numoffset body (and (or "+" "-") + time-hour + (ignore ":") + time-minute)) +(define-peg-pattern time-offset all (or "Z" time-numoffset)) + +(define-peg-pattern partial-time body (and time-hour + (ignore ":") + time-minute + (ignore ":") + time-second + (? time-secfrac))) +(define-peg-pattern full-date body (and date-fullyear + (ignore "-") + date-month + (ignore "-") + date-mday)) +(define-peg-pattern full-time body (and partial-time time-offset)) + +;; Offset Date-Time +(define-peg-pattern offset-date-time all (and full-date time-delim full-time)) + +;; Local Date-Time +(define-peg-pattern local-date-time all (and full-date time-delim partial-time)) + +;; Local Date +(define-peg-pattern local-date all full-date) + +;; Local Time +(define-peg-pattern local-time all partial-time) + +;; Array +(define-peg-pattern array all (and (ignore "[") + (? array-values) + (ignore ws-comment-newline) + (ignore "]"))) + +(define-peg-pattern array-values body (or + (and ws-comment-newline + val + ws-comment-newline + (ignore ",") + array-values) + (and ws-comment-newline + val + ws-comment-newline + (ignore (? ","))))) + +(define-peg-pattern ws-comment-newline none (* (or wschar (and (? comment) ignore-newline)))) + +;; Table +(define-peg-pattern table all (or array-table + std-table)) + +;; Standard Table +(define-peg-pattern std-table all (and (ignore "[") ws key ws (ignore "]"))) +(define-peg-pattern array-table all (and (ignore "[[") ws key ws (ignore "]]"))) + +;; Inline Table +(define-peg-pattern inline-table all (and (ignore "{") + (* ws) + (? inline-table-keyvals) + (* ws) + (ignore "}"))) +(define-peg-pattern inline-table-sep none (and ws "," ws)) +(define-peg-pattern inline-table-keyvals body (and keyval + (? (and inline-table-sep inline-table-keyvals)))) + + +;; Parsing + +(define (recursive-acons key value alist) + "Add a VALUE to ALIST of alists descending into keys according to the +list in KEY. For instance of KEY is (a b) this would create +alist[a][b] = value." + (match key + (((? string? key)) + (if (assoc-ref alist key) + (raise (condition (&already-defined))) + (alist-cons key value alist))) + ((elem rest ...) (match (assoc-ref alist elem) + (#f + (acons elem (recursive-acons rest value '()) alist)) + (old-value + (acons elem (recursive-acons rest value old-value) (alist-delete elem alist))))) + (() alist))) + +(define (recursive-assoc-ref alist key) + "Retrieve a value from ALIST of alists, descending into each value of +the list KEY. For instance a KEY (a b) would retrieve alist[a][b]." + (match key + (((? string? key)) (assoc-ref alist key)) + ((elem rest ...) (recursive-assoc-ref (assoc-ref alist elem) rest)))) + +(define (eval-toml-file parse-tree) + "Convert toml parse tree to alist." + + (define (assoc-ref->number alist key) + (and=> (and=> (assq-ref alist key) car) string->number)) + + (define (eval-date rest) + (let ((args (keyword-flatten '(date-fullyear + date-month + date-mday + time-hour + time-minute + time-second + time-secfrac + time-offset) + rest))) + (make-date + (assoc-ref->number args 'time-secfrac) + (assoc-ref->number args 'time-second) + (assoc-ref->number args 'time-minute) + (assoc-ref->number args 'time-hour) + (assoc-ref->number args 'date-mday) + (assoc-ref->number args 'date-month) + (assoc-ref->number args 'date-fullyear) + (match (assq-ref args 'time-offset) + (("Z") 0) + ((sign ('time-hour hour) ('time-minute minute)) + (* (+ + (* (string->number (string-append sign hour)) 60) + (string->number minute)) 60)) + (#f #f))))) + + (define (eval-value value) + "Evaluate right-hand-side of 'keyval token (i.e., a value)." + (match value + (('boolean "true") + #t) + (('boolean "false") + #f) + (('integer ('dec-int int)) + (string->number int 10)) + (('integer ('hex-int int)) + (string->number int 16)) + (('integer ('oct-int int)) + (string->number int 8)) + (('integer ('bin-int int)) + (string->number int 2)) + (('float ('dec-int int) b) + (string->number (string-append int b) 10)) + (('float other) + (match other + ("inf" +inf.0) + ("+inf" +inf.0) + ("-inf" -inf.0) + ("nan" +nan.0) + ("+nan" +nan.0) + ("-nan" -nan.0))) + (('offset-date-time rest ...) + (eval-date rest)) + (('local-date-time rest ...) + (eval-date rest)) + (('local-date rest ...) + (eval-date rest)) + (('local-time rest ...) + (eval-date rest)) + (('string str ...) + (apply string-append + (map (match-lambda + (('escaped "\"") "\"") + (('escaped "\\") "\\") + (('escaped "b") "\b") + (('escaped "t") "\t") + (('escaped "n") "\n") + (('escaped (? (lambda (x) (>= (string-length x) 4)) u)) + (list->string (list (integer->char (string->number u 16))))) + ((? string? s) s)) + (keyword-flatten '(escaped) str)))) + ('string "") + (('array tails ...) + (map eval-value (keyword-flatten '(boolean integer float string array + inline-table offset-date-time + local-date-time local-date + local-time) + tails))) + ('array (list)) + (('inline-table tails ...) + (eval (keyword-flatten '(keyval) tails) '() '())))) + + (define (ensure-list value) + (if (list? value) + value + (list value))) + + (define (simple-key->list keys) + (map + (match-lambda + (('simple-key 'quoted-key) "") + (('simple-key ('quoted-key k)) k) + (('simple-key (? string? k)) k) + (other (raise-exception `(invalid-simple-key ,other)))) + (keyword-flatten '(simple-key) keys))) + + (define (skip-keyval tails) + "Skip key-value pairs in tails until the next table." + (match tails + ((('keyval key val) tails ...) + (skip-keyval tails)) + (('keyval keyval) + '()) + (other other))) + + (define (eval parse-tree current-table result) + "Evaluate toml file body." + + (match parse-tree + ((('table ('std-table names ...)) tails ...) + (eval tails (simple-key->list names) result)) + ((('table ('array-table names ...)) tails ...) + ;; Not implemented. + (eval (skip-keyval tails) '() result)) + ((('keyval key val) tails ...) + (recursive-acons + (append current-table (ensure-list (simple-key->list key))) + (eval-value val) + (eval tails current-table result))) + (('keyval key val) + (recursive-acons + (append current-table (ensure-list (simple-key->list key))) + (eval-value val) + result)) + (() + '()))) + + (eval parse-tree '() '())) + +(define (parse-toml str) + "Parse and evaluate toml document from string STR." + + (let* ((match (match-pattern toml-file str)) + (end (peg:end match)) + (tree (peg:tree match)) + (flat-tree (keyword-flatten '(table keyval) tree))) + (if (eq? end (string-length str)) + (eval-toml-file flat-tree) + (raise (condition (&file-not-consumed)))))) + +(define (parse-toml-file file) + "Parse and evaluate toml document from file FILE." + + (parse-toml (call-with-input-file file get-string-all))) diff --git a/guix/build/utils.scm b/guix/build/utils.scm index 2352a627e9..94714bf397 100644 --- a/guix/build/utils.scm +++ b/guix/build/utils.scm @@ -9,6 +9,7 @@ ;;; Copyright © 2020, 2021 Maxim Cournoyer <maxim.cournoyer@gmail.com> ;;; Copyright © 2021, 2022 Maxime Devos <maximedevos@telenet.be> ;;; Copyright © 2021 Brendan Tildesley <mail@brendan.scot> +;;; Copyright © 2023 Carlo Zancanaro <carlo@zancanaro.id.au> ;;; ;;; This file is part of GNU Guix. ;;; @@ -176,6 +177,7 @@ decompress FILE-NAME, based on its file extension, else false." ((string-suffix? "lz" file-name) "lzip") ((string-suffix? "zip" file-name) "unzip") ((string-suffix? "xz" file-name) "xz") + ((string-suffix? "zst" file-name) "zstd") (else #f))) ;no compression used/unknown file extension (define (tarball? file-name) @@ -185,7 +187,7 @@ decompress FILE-NAME, based on its file extension, else false." (define (%xz-parallel-args) "The xz arguments required to enable bit-reproducible, multi-threaded compression." - (list "--memlimit=50%" + (list "--memlimit=20%" (format #f "--threads=~a" (max 2 (parallel-job-count))))) @@ -430,32 +432,38 @@ name." (log (current-output-port)) (follow-symlinks? #f) (copy-file copy-file) - keep-mtime? keep-permissions?) - "Copy SOURCE directory to DESTINATION. Follow symlinks if FOLLOW-SYMLINKS? -is true; otherwise, just preserve them. Call COPY-FILE to copy regular files. -When KEEP-MTIME? is true, keep the modification time of the files in SOURCE on -those of DESTINATION. When KEEP-PERMISSIONS? is true, preserve file -permissions. Write verbose output to the LOG port." + keep-mtime? keep-permissions? + (select? (const #t))) + "Copy SOURCE directory to DESTINATION. Follow symlinks if FOLLOW-SYMLINKS? is +true; otherwise, just preserve them. Call COPY-FILE to copy regular files. When +KEEP-MTIME? is true, keep the modification time of the files in SOURCE on those of +DESTINATION. When KEEP-PERMISSIONS? is true, preserve file permissions. Write +verbose output to the LOG port. Call (SELECT? FILE STAT) for each entry in source, +where FILE is the entry's absolute file name and STAT is the result of 'lstat' (or +'stat' if FOLLOW-SYMLINKS? is true); exclude entries for which SELECT? does not +return true." (define strip-source (let ((len (string-length source))) (lambda (file) (substring file len)))) - (file-system-fold (const #t) ; enter? + (file-system-fold (lambda (file stat result) ; enter? + (select? file stat)) (lambda (file stat result) ; leaf (let ((dest (string-append destination (strip-source file)))) - (format log "`~a' -> `~a'~%" file dest) - (case (stat:type stat) - ((symlink) - (let ((target (readlink file))) - (symlink target dest))) - (else - (copy-file file dest) - (when keep-permissions? - (chmod dest (stat:perms stat))))) - (when keep-mtime? - (set-file-time dest stat)))) + (when (select? file stat) + (format log "`~a' -> `~a'~%" file dest) + (case (stat:type stat) + ((symlink) + (let ((target (readlink file))) + (symlink target dest))) + (else + (copy-file file dest) + (when keep-permissions? + (chmod dest (stat:perms stat))))) + (when keep-mtime? + (set-file-time dest stat))))) (lambda (dir stat result) ; down (let ((target (string-append destination (strip-source dir)))) @@ -729,18 +737,22 @@ effects, such as displaying warnings or error messages." (define* (alist-cons-before reference key value alist #:optional (key=? equal?)) "Insert the KEY/VALUE pair before the first occurrence of a pair whose key -is REFERENCE in ALIST. Use KEY=? to compare keys." +is REFERENCE in ALIST. Use KEY=? to compare keys. An error is raised when no +such pair exists." (let-values (((before after) (break (match-lambda ((k . _) (key=? k reference))) alist))) - (append before (alist-cons key value after)))) + (match after + ((_ _ ...) + (append before (alist-cons key value after)))))) (define* (alist-cons-after reference key value alist #:optional (key=? equal?)) "Insert the KEY/VALUE pair after the first occurrence of a pair whose key -is REFERENCE in ALIST. Use KEY=? to compare keys." +is REFERENCE in ALIST. Use KEY=? to compare keys. An error is raised when +no such pair exists." (let-values (((before after) (break (match-lambda ((k . _) @@ -748,9 +760,7 @@ is REFERENCE in ALIST. Use KEY=? to compare keys." alist))) (match after ((reference after ...) - (append before (cons* reference `(,key . ,value) after))) - (() - (append before `((,key . ,value))))))) + (append before (cons* reference `(,key . ,value) after)))))) (define* (alist-replace key value alist #:optional (key=? equal?)) "Replace the first pair in ALIST whose car is KEY with the KEY/VALUE pair. diff --git a/guix/cache.scm b/guix/cache.scm index 6a91c7d3ef..8b12312c77 100644 --- a/guix/cache.scm +++ b/guix/cache.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2013-2017, 2020-2021, 2023 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2013-2017, 2020-2021, 2023-2024 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2022 Simon Tournier <zimon.toutoune@gmail.com> ;;; ;;; This file is part of GNU Guix. @@ -19,6 +19,7 @@ (define-module (guix cache) #:use-module ((guix utils) #:select (with-atomic-file-output)) + #:autoload (guix build syscalls) (lock-file unlock-file) #:use-module (srfi srfi-19) #:use-module (srfi srfi-26) #:use-module (ice-9 match) @@ -93,13 +94,19 @@ CLEANUP-PERIOD denotes the minimum time between two cache cleanups." (define expiry-file (string-append cache "/last-expiry-cleanup")) + (define expiry-port + ;; Get exclusive access to EXPIRY-FILE to avoid "cleanup storms" where + ;; several processes would concurrently decide that time has come to clean + ;; up the same cache. 'lock-file' might throw to 'system-error' or to + ;; 'flock-error'; in either case, assume that we lost the race. + (false-if-exception + (lock-file expiry-file "a+0" #:wait? #f))) + (define last-expiry-date - (catch 'system-error - (lambda () - (or (string->number - (call-with-input-file expiry-file get-string-all)) - 0)) - (const 0))) + (if expiry-port + (or (string->number (get-string-all expiry-port)) + 0) + +inf.0)) (when (obsolete? last-expiry-date now cleanup-period) (remove-expired-cache-entries (cache-entries cache) @@ -108,8 +115,10 @@ CLEANUP-PERIOD denotes the minimum time between two cache cleanups." #:delete-entry delete-entry) (catch 'system-error (lambda () - (with-atomic-file-output expiry-file - (cute write (time-second now) <>))) + (seek expiry-port 0 SEEK_SET) + (truncate-file expiry-port 0) + (write (time-second now) expiry-port) + (unlock-file expiry-port)) (lambda args ;; ENOENT means CACHE does not exist. (unless (= ENOENT (system-error-errno args)) diff --git a/guix/channels.scm b/guix/channels.scm index 0d7bc541cc..34f63eb833 100644 --- a/guix/channels.scm +++ b/guix/channels.scm @@ -704,11 +704,15 @@ that unconditionally resumes the continuation." store)))) (define* (build-from-source instance - #:key core verbose? (dependencies '()) system) + #:key core verbose? (dependencies '()) system + built-in-builders) "Return a derivation to build Guix from INSTANCE, using the self-build script contained therein. When CORE is true, build package modules under SOURCE using CORE, an instance of Guix. By default, build for the current -system, or SYSTEM if specified." +system, or SYSTEM if specified. If BUILT-IN-BUILDERS is +provided, it should be a list of strings and this will be used instead of the +builtin builders provided by the build daemon for store connections used +during this process." (define name (symbol->string (channel-name (channel-instance-channel instance)))) @@ -750,20 +754,28 @@ system, or SYSTEM if specified." #:verbose? verbose? #:version commit #:system system #:channel-metadata (channel-instance->sexp instance) - #:pull-version %pull-version)))) + #:pull-version %pull-version + #:built-in-builders + built-in-builders)))) ;; Build a set of modules that extend Guix using the standard method. (standard-module-derivation name source core dependencies))) (define* (build-channel-instance instance system - #:optional core (dependencies '())) + #:optional core (dependencies '()) + #:key built-in-builders) "Return, as a monadic value, the derivation for INSTANCE, a channel instance, for SYSTEM. DEPENDENCIES is a list of extensions providing Guile -modules that INSTANCE depends on." +modules that INSTANCE depends on. If BUILT-IN-BUILDERS is +provided, it should be a list of strings and this will be used instead of the +builtin builders provided by the build daemon for store connections used +during this process." (build-from-source instance #:core core #:dependencies dependencies - #:system system)) + #:system system + #:built-in-builders + built-in-builders)) (define (resolve-dependencies instances) "Return a procedure that, given one of the elements of INSTANCES, returns @@ -793,9 +805,13 @@ list of instances it depends on." (lambda (instance) (vhash-foldq* cons '() instance edges))) -(define* (channel-instance-derivations instances #:key system) +(define* (channel-instance-derivations instances #:key system + built-in-builders) "Return the list of derivations to build INSTANCES, in the same order as -INSTANCES. Build for the current system by default, or SYSTEM if specified." +INSTANCES. Build for the current system by default, or SYSTEM if specified. +If BUILT-IN-BUILDERS is provided, it should be a list of +strings and this will be used instead of the builtin builders provided by the +build daemon for store connections used during this process." (define core-instance ;; The 'guix' channel is treated specially: it's an implicit dependency of ;; all the other channels. @@ -809,11 +825,15 @@ INSTANCES. Build for the current system by default, or SYSTEM if specified." (define (instance->derivation instance) (mlet %store-monad ((system (if system (return system) (current-system)))) (mcached (if (eq? instance core-instance) - (build-channel-instance instance system) + (build-channel-instance instance system + #:built-in-builders + built-in-builders) (mlet %store-monad ((core (instance->derivation core-instance)) (deps (mapm %store-monad instance->derivation (edges instance)))) - (build-channel-instance instance system core deps))) + (build-channel-instance instance system core deps + #:built-in-builders + built-in-builders))) instance system))) @@ -915,10 +935,13 @@ derivation." intro)))))) '())))) -(define* (channel-instances->manifest instances #:key system) +(define* (channel-instances->manifest instances #:key system + built-in-builders) "Return a profile manifest with entries for all of INSTANCES, a list of channel instances. By default, build for the current system, or SYSTEM if -specified." +specified. If BUILT-IN-BUILDERS is provided, it should be a +list of strings and this will be used instead of the builtin builders provided +by the build daemon for store connections used during this process." (define (instance->entry instance drv) (let ((commit (channel-instance-commit instance)) (channel (channel-instance-channel instance))) @@ -934,8 +957,11 @@ specified." (properties `((source ,(channel-instance->sexp instance))))))) - (mlet* %store-monad ((derivations (channel-instance-derivations instances - #:system system)) + (mlet* %store-monad ((derivations (channel-instance-derivations + instances + #:system system + #:built-in-builders + built-in-builders)) (entries -> (map instance->entry instances derivations))) (return (manifest entries)))) @@ -990,10 +1016,17 @@ be used as a profile hook." ;; The default channel profile hooks. (cons package-cache-file %default-profile-hooks)) -(define (channel-instances->derivation instances) +(define* (channel-instances->derivation instances + #:key built-in-builders) "Return the derivation of the profile containing INSTANCES, a list of -channel instances." - (mlet %store-monad ((manifest (channel-instances->manifest instances))) +channel instances. If BUILT-IN-BUILDERS is provided, it +should be a list of strings and this will be used instead of the builtin +builders provided by the build daemon for store connections used during this +process." + (mlet %store-monad ((manifest (channel-instances->manifest + instances + #:built-in-builders + built-in-builders))) ;; Emit a profile in format version so that, if INSTANCES denotes an old ;; Guix, it can still read that profile, for instance for the purposes of ;; 'guix describe'. diff --git a/guix/ci.scm b/guix/ci.scm index 5d16ee69d0..b2077448b0 100644 --- a/guix/ci.scm +++ b/guix/ci.scm @@ -336,10 +336,13 @@ URL. The current system is taken into account. If no commit with available substitutes were found, the commit field is set to false and a warning message is printed." - (let ((commit (find-latest-commit-with-substitutes url))) - (unless commit - (warning (G_ "could not find available substitutes at ~a~%") - url)) + (let ((commit (catch #t + (lambda () + (find-latest-commit-with-substitutes url)) + (lambda _ + (warning (G_ "could not find available substitutes at ~a~%") + url) + #false)))) (channel (inherit chan) (commit commit)))) diff --git a/guix/cpu.scm b/guix/cpu.scm index 840215cff0..ef5c3dce2a 100644 --- a/guix/cpu.scm +++ b/guix/cpu.scm @@ -167,7 +167,8 @@ corresponds to CPU, a record as returned by 'current-cpu'." ("lm" "sse3" => "k8-sse3") ("longmode" => "k8") ("lm" => "k8"))) - (if-flags ("avx512f" => "znver4") + (if-flags ("avx512vp2intersect" => "znver5") + ("avx512f" => "znver4") ("vaes" => "znver3") ("clwb" => "znver2") ("clzero" => "znver1") @@ -312,7 +313,7 @@ CPUs for compilers which don't allow for more focused optimizing." ((or "graniterapids-d" "graniterapids" "tigerlake" "sapphirerapids" "cooperlake" "icelake-server" "icelake-client" "cannonlake" "knm" "knl" "skylake-avx512" - "znver4") + "znver5" "znver4") "x86-64-v4") ((or "pantherlake" "clearwaterforest" "arrowlake-s" "sierraforest" "alderlake" "skylake" "broadwell" "haswell" diff --git a/guix/derivations.scm b/guix/derivations.scm index a91c1ae984..bef98cd26a 100644 --- a/guix/derivations.scm +++ b/guix/derivations.scm @@ -401,8 +401,8 @@ of SUBSTITUTABLES." (substitution-oracle store inputs #:mode mode))) "Given INPUTS, a list of derivation-inputs, return two values: the list of -derivations to build, and the list of substitutable items that, together, -allow INPUTS to be realized. +derivations to build, in topological order, and the list of substitutable +items that, together, allow INPUTS to be realized. SUBSTITUTABLE-INFO must be a one-argument procedure similar to that returned by 'substitution-oracle'." @@ -422,36 +422,48 @@ by 'substitution-oracle'." (and (= (length info) (length items)) info)))) - (let loop ((inputs inputs) ;list of <derivation-input> - (build '()) ;list of <derivation> - (substitute '()) ;list of <substitutable> - (visited (set))) ;set of <derivation-input> - (match inputs - (() - (values build substitute)) - ((input rest ...) - (let ((key (derivation-input-key input)) - (deps (derivation-inputs - (derivation-input-derivation input)))) - (cond ((set-contains? visited key) - (loop rest build substitute visited)) - ((input-built? input) - (loop rest build substitute - (set-insert key visited))) - ((input-substitutable-info input) - => - (lambda (substitutables) - (loop (append (dependencies-of-substitutables substitutables + (define (traverse) + ;; Perform a depth-first traversal. + (let loop ((inputs inputs) ;list of <derivation-input> + (build '()) ;list of <derivation> + (substitute '()) ;list of <substitutable> + (visited (set))) ;set of <derivation-input> + (match inputs + (() + (values visited build substitute)) + ((input rest ...) + (let ((key (derivation-input-key input)) + (deps (derivation-inputs + (derivation-input-derivation input)))) + (cond ((set-contains? visited key) + (loop rest build substitute visited)) + ((input-built? input) + (loop rest build substitute (set-insert key visited))) + ((input-substitutable-info input) + => + (lambda (substitutables) + (call-with-values + (lambda () + (loop (dependencies-of-substitutables substitutables deps) - rest) - build - (append substitutables substitute) - (set-insert key visited)))) - (else - (loop (append deps rest) - (cons (derivation-input-derivation input) build) - substitute - (set-insert key visited))))))))) + build + (append substitutables substitute) + (set-insert key visited))) + (lambda (visited build substitute) + (loop rest build substitute visited))))) + (else + (call-with-values + (lambda () + (loop deps build substitute (set-insert key visited))) + (lambda (visited build substitute) + (loop rest + (cons (derivation-input-derivation input) build) + substitute + visited)))))))))) + + (call-with-values traverse + (lambda (_ build substitute) + (values (reverse! build) substitute)))) (define-deprecated (derivation-prerequisites-to-build store drv #:rest rest) derivation-build-plan diff --git a/guix/download.scm b/guix/download.scm index b251e1f6c0..d88ad0ee44 100644 --- a/guix/download.scm +++ b/guix/download.scm @@ -74,24 +74,11 @@ "ftp://gcc.gnu.org/pub/gcc/" ,@(map (cut string-append <> "/gcc") gnu-mirrors)) (gnupg - "http://artfiles.org/gnupg.org" - "http://www.crysys.hu/" "https://gnupg.org/ftp/gcrypt/" "ftp://mirrors.dotsrc.org/gcrypt/" - "ftp://mirror.cict.fr/gnupg/" - "ftp://ftp.franken.de/pub/crypt/mirror/ftp.gnupg.org/gcrypt/" - "ftp://ftp.freenet.de/pub/ftp.gnupg.org/gcrypt/" - "ftp://ftp.hi.is/pub/mirrors/gnupg/" "ftp://ftp.heanet.ie/mirrors/ftp.gnupg.org/gcrypt/" - "ftp://ftp.bit.nl/mirror/gnupg/" - "ftp://ftp.surfnet.nl/pub/security/gnupg/" - "ftp://ftp.iasi.roedu.net/pub/mirrors/ftp.gnupg.org/" - "ftp://ftp.sunet.se/pub/security/gnupg/" - "ftp://mirror.switch.ch/mirror/gnupg/" - "ftp://mirror.tje.me.uk/pub/mirrors/ftp.gnupg.org/" "ftp://ftp.mirrorservice.org/sites/ftp.gnupg.org/gcrypt/" - "ftp://ftp.ring.gr.jp/pub/net/gnupg/" - "ftp://ftp.gnupg.org/gcrypt/") + "ftp://ftp.ring.gr.jp/pub/net/gnupg/") (gnome "https://download.gnome.org/" "http://ftp.gnome.org/pub/GNOME/") diff --git a/guix/gexp.scm b/guix/gexp.scm index 74b4c49f90..e44aea6420 100644 --- a/guix/gexp.scm +++ b/guix/gexp.scm @@ -52,6 +52,7 @@ gexp-input-native? assume-valid-file-name + assume-source-relative-file-name local-file local-file? local-file-file @@ -485,6 +486,12 @@ the given file name is valid, even if it's not a string literal, and thus not warn about it." file) +(define-syntax-rule (assume-source-relative-file-name file) + "This is a syntactic keyword to tell 'local-file' that it can assume that +the given file is relative to the source directory, even if it's not a string +literal." + file) + (define-syntax local-file (lambda (s) "Return an object representing local file FILE to add to the store; this @@ -503,13 +510,19 @@ where FILE is the entry's absolute file name and STAT is the result of This is the declarative counterpart of the 'interned-file' monadic procedure. It is implemented as a macro to capture the current source directory where it appears." - (syntax-case s (assume-valid-file-name) + (syntax-case s (assume-valid-file-name assume-source-relative-file-name) ((_ file rest ...) (string? (syntax->datum #'file)) ;; FILE is a literal, so resolve it relative to the source directory. #'(%local-file file (delay (absolute-file-name file (current-source-directory))) rest ...)) + ((_ (assume-source-relative-file-name file) rest ...) + ;; FILE is not a literal, but the user requested we look it up + ;; relative to the current source directory. + #'(%local-file file + (delay (absolute-file-name file (current-source-directory))) + rest ...)) ((_ (assume-valid-file-name file) rest ...) ;; FILE is not a literal, so resolve it relative to the current ;; directory. Since the user declared FILE is valid, do not pass @@ -1616,7 +1629,7 @@ as returned by 'local-file' for example." (_ #f)) files) (imported-files/derivation files #:name name - #:symlink? derivation? + #:symlink? #f ;like 'interned-file-tree' #:system system #:guile guile) (interned-file-tree `(,name directory ,@(file-mapping->tree files))))) diff --git a/guix/git-download.scm b/guix/git-download.scm index d26a814e07..ae2073ea06 100644 --- a/guix/git-download.scm +++ b/guix/git-download.scm @@ -48,6 +48,7 @@ #:use-module (srfi srfi-1) #:use-module (srfi srfi-34) #:use-module (srfi srfi-35) + #:use-module (rnrs bytevectors) #:export (git-reference git-reference? git-reference-url @@ -86,20 +87,13 @@ (let ((distro (resolve-interface '(gnu packages version-control)))) (module-ref distro 'git-lfs))) -(define* (git-fetch/in-band* ref hash-algo hash - #:optional name - #:key (system (%current-system)) - (guile (default-guile)) - (git (git-package)) - git-lfs) - "Shared implementation code for git-fetch/in-band & friends. Refer to their -respective documentation." +(define (git-fetch-builder git git-lfs git-ref-recursive? hash-algo) (define inputs `(,(or git (git-package)) ,@(if git-lfs (list git-lfs) '()) - ,@(if (git-reference-recursive? ref) + ,@(if git-ref-recursive? ;; TODO: remove (standard-packages) after ;; 48e528a26f9c019eeaccf5e3de3126aa02c98d3b is merged into master; ;; currently when doing 'git clone --recursive', we need sed, grep, @@ -121,70 +115,85 @@ respective documentation." (define gnutls (module-ref (resolve-interface '(gnu packages tls)) 'guile-gnutls)) - (define glibc-locales - ;; Note: pick the '-final' variant to avoid circular dependency on - ;; i586-gnu, where 'glibc-utf8-locales' indirectly depends on Git. - (module-ref (resolve-interface '(gnu packages commencement)) - 'glibc-utf8-locales-final)) - (define modules (delete '(guix config) (source-module-closure '((guix build git) (guix build utils))))) - (define build - (with-imported-modules modules - (with-extensions (list guile-json gnutls ;for (guix swh) - guile-lzlib) - #~(begin - (use-modules (guix build git) - ((guix build utils) - #:select (set-path-environment-variable)) - (ice-9 match)) - - (define lfs? - (call-with-input-string (getenv "git lfs?") read)) - - (define recursive? - (call-with-input-string (getenv "git recursive?") read)) - - ;; Let Guile interpret file names as UTF-8, otherwise - ;; 'delete-file-recursively' might fail to delete all of - ;; '.git'--see <https://issues.guix.gnu.org/54893>. - (setenv "GUIX_LOCPATH" - #+(file-append glibc-locales "/lib/locale")) - (setlocale LC_ALL "en_US.utf8") - - ;; The 'git submodule' commands expects Coreutils, sed, grep, - ;; etc. to be in $PATH. This also ensures that git extensions are - ;; found. - (set-path-environment-variable "PATH" '("bin") '#+inputs) - - (setvbuf (current-output-port) 'line) - (setvbuf (current-error-port) 'line) - - (git-fetch-with-fallback (getenv "git url") (getenv "git commit") - #$output - #:hash #$hash - #:hash-algorithm '#$hash-algo - #:lfs? lfs? - #:recursive? recursive? - #:git-command "git"))))) + (with-imported-modules modules + (with-extensions (list guile-json gnutls ;for (guix swh) + guile-lzlib) + #~(begin + (use-modules (guix build git) + ((guix build utils) + #:select (set-path-environment-variable)) + (ice-9 match) + (rnrs bytevectors)) + + (define lfs? + (call-with-input-string (getenv "git lfs?") read)) + + (define recursive? + (call-with-input-string (getenv "git recursive?") read)) + + ;; Let Guile interpret file names as UTF-8, otherwise + ;; 'delete-file-recursively' might fail to delete all of + ;; '.git'--see <https://issues.guix.gnu.org/54893>. + (setlocale LC_ALL "C.UTF-8") + + ;; The 'git submodule' commands expects Coreutils, sed, grep, + ;; etc. to be in $PATH. This also ensures that git extensions are + ;; found. + (set-path-environment-variable "PATH" '("bin") '#+inputs) + + (setvbuf (current-output-port) 'line) + (setvbuf (current-error-port) 'line) + + (git-fetch-with-fallback (getenv "git url") (getenv "git commit") + #$output + #:hash (u8-list->bytevector + (map + string->number + (string-split (getenv "hash") #\,))) + #:hash-algorithm '#$hash-algo + #:lfs? lfs? + #:recursive? recursive? + #:git-command "git"))))) +(define* (git-fetch/in-band* ref hash-algo hash + #:optional name + #:key (system (%current-system)) + (guile (default-guile)) + (git (git-package)) + git-lfs) + "Shared implementation code for git-fetch/in-band & friends. Refer to their +respective documentation." (mlet %store-monad ((guile (package->derivation (or guile (default-guile)) system))) - (gexp->derivation (or name "git-checkout") build - - ;; Use environment variables and a fixed script name so - ;; there's only one script in store for all the - ;; downloads. + (gexp->derivation (or name "git-checkout") + ;; Avoid the builder differing for every single use as + ;; having less builder is more efficient for computing + ;; derivations. + ;; + ;; Don't pass package specific data in to the following + ;; procedure, use #:env-vars below instead. + (git-fetch-builder git git-lfs + (git-reference-recursive? ref) + hash-algo) #:script-name "git-download" #:env-vars `(("git url" . ,(git-reference-url ref)) ("git commit" . ,(git-reference-commit ref)) ("git recursive?" . ,(object->string (git-reference-recursive? ref))) - ("git lfs?" . ,(if git-lfs "#t" "#f"))) + ("git lfs?" . ,(if git-lfs "#t" "#f")) + ;; To avoid pulling in (guix base32) in the builder + ;; script, use bytevector->u8-list from (rnrs + ;; bytevectors) + ("hash" . ,(string-join + (map number->string + (bytevector->u8-list hash)) + ","))) #:leaked-env-vars '("http_proxy" "https_proxy" "LC_ALL" "LC_MESSAGES" "LANG" "COLUMNS") diff --git a/guix/git.scm b/guix/git.scm index d75a301f98..410cd4c153 100644 --- a/guix/git.scm +++ b/guix/git.scm @@ -206,6 +206,19 @@ the 'SSL_CERT_FILE' and 'SSL_CERT_DIR' environment variables." (module-ref errors 'GITERR_HTTP) 34))) +(define (set-git-timeouts connection-timeout read-timeout) + "Instruct Guile-Git to honor the given CONNECTION-TIMEOUT and READ-TIMEOUT +when talking to remote Git servers. + +If one of them is #f, the corresponding default setting is kept unchanged." + ;; 'set-server-timeout!' & co. were added in Guile-Git 0.9.0. + (when (and (defined? 'set-server-connection-timeout!) + connection-timeout) + (set-server-connection-timeout! connection-timeout)) + (when (and (defined? 'set-server-timeout!) + read-timeout) + (set-server-timeout! read-timeout))) + (define (clone* url directory) "Clone git repository at URL into DIRECTORY. Upon failure, make sure no empty directory is left behind." @@ -298,6 +311,25 @@ corresponding Git object." (('tag . tag) (tag->commit repository tag))))) +(define (delete-untracked-files repository) + "Delete untracked files from the work directory of REPOSITORY." + (let ((workdir (repository-working-directory repository)) + (status (status-list-new repository + (make-status-options + STATUS-SHOW-WORKDIR-ONLY + (logior + STATUS-FLAG-INCLUDE-UNTRACKED + STATUS-FLAG-INCLUDE-IGNORED))))) + (for-each (lambda (entry) + (let ((status (status-entry-status entry))) + (when (or (memq 'wt-new status) + (memq 'ignored status)) + (let* ((diff (status-entry-index-to-workdir entry)) + (new (diff-delta-new-file diff))) + (delete-file-recursively + (in-vicinity workdir (diff-file-path new))))))) + (status-list->status-entries status)))) + (define (switch-to-ref repository ref) "Switch to REPOSITORY's branch, commit or tag specified by REF. Return the OID (roughly the commit hash) corresponding to REF." @@ -305,6 +337,11 @@ OID (roughly the commit hash) corresponding to REF." (resolve-reference repository ref)) (reset repository obj RESET_HARD) + + ;; There might still be untracked files in REPOSITORY due to an interrupted + ;; checkout for example; delete them. + (delete-untracked-files repository) + (object-id obj)) (define (call-with-repository directory proc) @@ -488,6 +525,8 @@ could not be fetched from Software Heritage~%") (define* (update-cached-checkout url #:key + (connection-timeout 30000) + (read-timeout 45000) (ref '()) recursive? (check-out? #t) @@ -509,7 +548,12 @@ If REF is the empty list, the remote HEAD is used. When RECURSIVE? is true, check out submodules as well, if any. When CHECK-OUT? is true, reset the cached working tree to REF; otherwise leave -it unchanged." +it unchanged. + +Wait for up to CONNECTION-TIMEOUT milliseconds when establishing connection to +the remote server, and for up to READ-TIMEOUT milliseconds when reading from +it. When zero, use the system defaults for these timeouts; when false, leave +current settings unchanged." (define (cache-entries directory) (filter-map (match-lambda ((or "." "..") @@ -531,6 +575,7 @@ it unchanged." (_ ref))) (with-libgit2 + (set-git-timeouts connection-timeout read-timeout) (let* ((cache-exists? (openable-repository? cache-directory)) (repository (if cache-exists? (repository-open cache-directory) diff --git a/guix/gnu-maintenance.scm b/guix/gnu-maintenance.scm index 881e941fbf..ee4882326f 100644 --- a/guix/gnu-maintenance.scm +++ b/guix/gnu-maintenance.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2010-2023 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2010-2024 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> @@ -30,6 +30,7 @@ #:use-module (srfi srfi-2) #:use-module (srfi srfi-11) #:use-module (srfi srfi-26) + #:use-module (srfi srfi-34) #:use-module (rnrs io ports) #:use-module ((guix http-client) #:hide (open-socket-for-uri)) ;; not required in many cases, so autoloaded to reduce start-up costs. @@ -38,6 +39,7 @@ #:use-module (guix utils) #:use-module (guix diagnostics) #:use-module (guix i18n) + #:autoload (guix combinators) (fold2) #:use-module (guix memoization) #:use-module (guix records) #:use-module (guix upstream) @@ -468,10 +470,12 @@ 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 (import-release (package-upstream-name package) - #:version version - #:server server - #:directory directory)))) + (false-if-networking-error + (false-if-ftp-error + (import-release (package-upstream-name package) + #:version version + #:server server + #:directory directory))))) ;;; @@ -480,27 +484,46 @@ hosted on ftp.gnu.org, or not under that name (this is the case for (define (html-links sxml) "Return the list of links found in SXML, the SXML tree of an HTML page." - (let loop ((sxml sxml) - (links '())) - (match sxml - (('a ('@ attributes ...) body ...) - (match (assq 'href attributes) - (#f (fold loop links body)) - (('href url) (fold loop (cons url links) body)))) - ((tag ('@ _ ...) body ...) - (fold loop links body)) - ((tag body ...) - (fold loop links body)) - (_ - links)))) + (define-values (links base) + (let loop ((sxml sxml) + (links '()) + (base #f)) + (match sxml + (('a ('@ attributes ...) body ...) + (match (assq 'href attributes) + (#f (fold2 loop links base body)) + (('href url) (fold2 loop (cons url links) base body)))) + (('base ('@ ('href new-base))) + ;; The base against which relative URL paths must be resolved. + (values links new-base)) + ((tag ('@ _ ...) body ...) + (fold2 loop links base body)) + ((tag body ...) + (fold2 loop links base body)) + (_ + (values links base))))) + + (if base + (map (lambda (link) + (let ((uri (string->uri link))) + (if (or uri (string-prefix? "/" link)) + link + (in-vicinity base link)))) + links) + links)) (define (url->links url) "Return the unique links on the HTML page accessible at URL." - (let* ((uri (string->uri url)) - (port (http-fetch/cached uri #:ttl 3600)) - (sxml (html->sxml port))) - (close-port port) - (delete-duplicates (html-links sxml)))) + (guard (c ((http-get-error? c) + (warning (G_ "failed to download '~a': ~a (~a)~%") + url (http-get-error-code c) + (http-get-error-reason c)) + '())) + (let* ((uri (string->uri url)) + (port (http-fetch/cached uri #:ttl 3600)) + (sxml (html->sxml port))) + (close-port port) + (delete-duplicates (html-links sxml))))) (define (canonicalize-url url base-url) "Make relative URL absolute, by appending URL to BASE-URL as required. If @@ -907,13 +930,14 @@ to fetch a specific version." "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 - (import-ftp-release - (package-name package) - #:version version - #:server "ftp.freedesktop.org" - #:directory - (string-append "/pub/xorg/" (dirname (uri-path uri))))))) + (false-if-networking-error + (false-if-ftp-error + (import-ftp-release + (package-name package) + #:version version + #:server "ftp.freedesktop.org" + #:directory + (string-append "/pub/xorg/" (dirname (uri-path uri)))))))) (define* (import-kernel.org-release package #:key (version #f)) "Return the latest release of PACKAGE, a Linux kernel package. @@ -1016,15 +1040,19 @@ VERSION string to fetch a specific version." (false-if-networking-error (gnu-hosted? package)))) (import import-gnu-release))) +(define gnupg-hosted? + (url-prefix-predicate "mirror://gnupg/")) + (define %gnu-ftp-updater ;; This is for GNU packages taken from alternate locations, such as - ;; alpha.gnu.org, ftp.gnupg.org, etc. It is obsolescent. + ;; alpha.gnu.org (ftp.gnupg.org is no longer available). It is obsolescent. (upstream-updater (name 'gnu-ftp) (description "Updater for GNU packages only available via FTP") (pred (lambda (package) (false-if-networking-error (and (not (gnu-hosted? package)) + (not (gnupg-hosted? package)) (pure-gnu-package? package))))) (import import-release*))) diff --git a/guix/grafts.scm b/guix/grafts.scm index f4df513daf..d97e112ba4 100644 --- a/guix/grafts.scm +++ b/guix/grafts.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2014-2023 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2014-2024 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -96,12 +96,6 @@ "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." - (define glibc-locales - (module-ref (resolve-interface '(gnu packages commencement)) - (if (target-hurd? system) - 'glibc-utf8-locales-final/hurd - 'glibc-utf8-locales-final))) - (define mapping ;; List of store item pairs. (map (lambda (graft) @@ -114,11 +108,8 @@ are not recursively applied to dependencies of DRV." (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")))) + ;; Let Guile interpret file names as UTF-8. + #~(setlocale LC_ALL "C.UTF-8"))) (define build diff --git a/guix/hash.scm b/guix/hash.scm index 3cb68e5c44..81f35d63df 100644 --- a/guix/hash.scm +++ b/guix/hash.scm @@ -1,6 +1,7 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2021 Sarah Morgensen <iskarian@mgsn.dev> ;;; Copyright © 2022 Maxime Devos <maximedevos@telenet.be> +;;; Copyright © 2023 Simon Tournier <zimon.toutoune@gmail.com> ;;; ;;; This file is part of GNU Guix. ;;; @@ -23,23 +24,45 @@ #:use-module (srfi srfi-1) #:use-module (srfi srfi-11) #:export (vcs-file? + vcs-file-predicate file-hash*)) -(define (vcs-file? file stat) - "Returns true if FILE is a version control system file." +(define %vcs-directories + ;; Directory used for determining the kind of VCS. + (list ".bzr" ".git" ".hg" ".svn" "CVS")) + +(define* (vcs-file? file stat + #:optional + (vcs-directories %vcs-directories)) + "Return true if FILE matches a version control system from the list +VCSES-DIRECTORIES." (case (stat:type stat) ((directory) - (member (basename file) '(".bzr" ".git" ".hg" ".svn" "CVS"))) + (member (basename file) vcs-directories)) ((regular) - ;; Git sub-modules have a '.git' file that is a regular text file. - (string=? (basename file) ".git")) + (if (member ".git" vcs-directories) + ;; Git sub-modules have a '.git' file that is a regular text file. + (string=? (basename file) ".git") + #f)) (else #f))) +(define (vcs-file-predicate directory) + "Return a two-argument procedure that returns true when version-control +metadata directories such as '.git' is found in DIRECTORY." + (define vcs-directories + (filter (lambda (vcs) + (file-exists? (in-vicinity directory vcs))) + %vcs-directories)) + + (lambda (file stat) + (vcs-file? file stat vcs-directories))) + (define* (file-hash* file #:key (algorithm (hash-algorithm sha256)) (recursive? 'auto) - (select? (negate vcs-file?))) + (select? (negate (lambda (file stat) + (vcs-file? file stat))))) "Compute the hash of FILE with ALGORITHM. Symbolic links are only dereferenced if RECURSIVE? is false. diff --git a/guix/hg-download.scm b/guix/hg-download.scm index 55d908817f..df48ed6eb7 100644 --- a/guix/hg-download.scm +++ b/guix/hg-download.scm @@ -30,6 +30,7 @@ #:use-module (ice-9 match) #:use-module (ice-9 popen) #:use-module (ice-9 rdelim) + #:use-module (rnrs bytevectors) #:export (hg-reference hg-reference? hg-reference-url @@ -58,13 +59,7 @@ (let ((distro (resolve-interface '(gnu packages version-control)))) (module-ref distro 'mercurial))) -(define* (hg-fetch ref hash-algo hash - #:optional name - #:key (system (%current-system)) (guile (default-guile)) - (hg (hg-package))) - "Return a fixed-output derivation that fetches REF, a <hg-reference> -object. The output is expected to have recursive hash HASH of type -HASH-ALGO (a symbol). Use NAME as the file name, or a generic name if #f." +(define (hg-fetch-builder hg hash-algo) (define inputs ;; The 'swh-download' procedure requires tar and gzip. `(("gzip" ,(module-ref (resolve-interface '(gnu packages compression)) @@ -88,56 +83,84 @@ HASH-ALGO (a symbol). Use NAME as the file name, or a generic name if #f." (guix build download-nar) (guix swh))))) - (define build - (with-imported-modules modules - (with-extensions (list guile-json gnutls ;for (guix swh) - guile-lzlib) - #~(begin - (use-modules (guix build hg) - (guix build utils) ;for `set-path-environment-variable' - ((guix build download) - #:select (download-method-enabled?)) - (guix build download-nar) - (guix swh) - (ice-9 match)) - - (set-path-environment-variable "PATH" '("bin") - (match '#+inputs - (((names dirs outputs ...) ...) - dirs))) - - (setvbuf (current-output-port) 'line) - (setvbuf (current-error-port) 'line) - - (or (and (download-method-enabled? 'upstream) - (hg-fetch '#$(hg-reference-url ref) - '#$(hg-reference-changeset ref) - #$output - #:hg-command (string-append #+hg "/bin/hg"))) - (and (download-method-enabled? 'nar) - (download-nar #$output)) - ;; As a last resort, attempt to download from Software Heritage. - ;; Disable X.509 certificate verification to avoid depending - ;; on nss-certs--we're authenticating the checkout anyway. - (and (download-method-enabled? 'swh) - (parameterize ((%verify-swh-certificate? #f)) - (format (current-error-port) - "Trying to download from Software Heritage...~%") - (or (swh-download-directory-by-nar-hash - #$hash '#$hash-algo #$output) - (swh-download #$(hg-reference-url ref) - #$(hg-reference-changeset ref) - #$output))))))))) + (with-imported-modules modules + (with-extensions (list guile-json gnutls ;for (guix swh) + guile-lzlib) + #~(begin + (use-modules (guix build hg) + (guix build utils) ;for `set-path-environment-variable' + ((guix build download) + #:select (download-method-enabled?)) + (guix build download-nar) + (guix swh) + (ice-9 match) + (rnrs bytevectors)) + + (set-path-environment-variable "PATH" '("bin") + (match '#+inputs + (((names dirs outputs ...) ...) + dirs))) + + (setvbuf (current-output-port) 'line) + (setvbuf (current-error-port) 'line) + + (or (and (download-method-enabled? 'upstream) + (hg-fetch (getenv "hg ref url") + (getenv "hg ref changeset") + #$output + #:hg-command (string-append #+hg "/bin/hg"))) + (and (download-method-enabled? 'nar) + (download-nar #$output)) + ;; As a last resort, attempt to download from Software Heritage. + ;; Disable X.509 certificate verification to avoid depending + ;; on nss-certs--we're authenticating the checkout anyway. + (and (download-method-enabled? 'swh) + (parameterize ((%verify-swh-certificate? #f)) + (format (current-error-port) + "Trying to download from Software Heritage...~%") + (or (swh-download-directory-by-nar-hash + (u8-list->bytevector + (map string->number + (string-split (getenv "hash") #\,))) + '#$hash-algo + #$output) + (swh-download (getenv "hg ref url") + (getenv "hg ref changeset") + #$output))))))))) +(define* (hg-fetch ref hash-algo hash + #:optional name + #:key (system (%current-system)) (guile (default-guile)) + (hg (hg-package))) + "Return a fixed-output derivation that fetches REF, a <hg-reference> +object. The output is expected to have recursive hash HASH of type +HASH-ALGO (a symbol). Use NAME as the file name, or a generic name if #f." (mlet %store-monad ((guile (package->derivation guile system))) - (gexp->derivation (or name "hg-checkout") build + (gexp->derivation (or name "hg-checkout") + ;; Avoid the builder differing for every single use as + ;; having less builder is more efficient for computing + ;; derivations. + ;; + ;; Don't pass package specific data in to the following + ;; procedure, use #:env-vars below instead. + (hg-fetch-builder hg hash-algo) #:leaked-env-vars '("http_proxy" "https_proxy" "LC_ALL" "LC_MESSAGES" "LANG" "COLUMNS") - #:env-vars (match (getenv "GUIX_DOWNLOAD_METHODS") - (#f '()) - (value - `(("GUIX_DOWNLOAD_METHODS" . ,value)))) + #:env-vars + `(("hg ref url" . ,(hg-reference-url ref)) + ("hg ref changeset" . ,(hg-reference-changeset ref)) + ;; To avoid pulling in (guix base32) in the builder + ;; script, use bytevector->u8-list from (rnrs + ;; bytevectors) + ("hash" . ,(string-join + (map number->string + (bytevector->u8-list hash)) + ",")) + ,@(match (getenv "GUIX_DOWNLOAD_METHODS") + (#f '()) + (value + `(("GUIX_DOWNLOAD_METHODS" . ,value))))) #:system system #:local-build? #t ;don't offload repo cloning #:hash-algo hash-algo diff --git a/guix/import/composer.scm b/guix/import/composer.scm index 1ad608964b..abc9023be4 100644 --- a/guix/import/composer.scm +++ b/guix/import/composer.scm @@ -19,12 +19,14 @@ (define-module (guix import composer) #:use-module (ice-9 match) #:use-module (json) - #:use-module (guix hash) #:use-module (guix base32) #:use-module (guix build git) #:use-module (guix build utils) #:use-module (guix build-system) #:use-module (guix build-system composer) + #:use-module ((guix diagnostics) #:select (warning)) + #:use-module (guix hash) + #:use-module (guix i18n) #:use-module (guix import json) #:use-module (guix import utils) #:use-module ((guix licenses) #:prefix license:) @@ -113,7 +115,7 @@ package NAME with optional VERSION, or #f on failure." (if version (assoc-ref packages version) (cdr - (reduce + (fold (lambda (new cur-max) (match new (((? valid-version? version) . tail) @@ -217,13 +219,8 @@ dependencies, or #f and the empty list on failure." (define (guix-package->composer-name package) "Given a Composer PACKAGE built from Packagist, return the name of the package in Packagist." - (let ((upstream-name (assoc-ref - (package-properties package) - 'upstream-name)) - (name (package-name package))) - (if upstream-name - upstream-name - (guix-name->composer-name name)))) + (or (assoc-ref (package-properties package) 'upstream-name) + (guix-name->composer-name (package-name package)))) (define (string->license str) "Convert the string STR into a license object." @@ -243,23 +240,37 @@ package in Packagist." (eq? (package-build-system package) composer-build-system) (string-prefix? "php-" (package-name package)))) -(define (latest-release package) - "Return an <upstream-source> for the latest release of PACKAGE." +(define (dependency->input dependency type) + (upstream-input + (name dependency) + (downstream-name (php-package-name dependency)) + (type type))) + +(define* (import-release package #:key (version #f)) + "Return an <upstream-source> for VERSION or the latest release of PACKAGE." (let* ((php-name (guix-package->composer-name package)) - (package (composer-fetch php-name)) - (version (composer-package-version package)) - (url (composer-source-url (composer-package-source package)))) - (upstream-source - (package (package-name package)) - (version version) - (urls (list url))))) + (composer-package (composer-fetch php-name #:version version))) + (if composer-package + (upstream-source + (package (composer-package-name composer-package)) + (version (composer-package-version composer-package)) + (urls (list (composer-source-url + (composer-package-source composer-package)))) + (inputs (append + (map (cut dependency->input <> 'regular) + (composer-package-require composer-package)) + (map (cut dependency->input <> 'native) + (composer-package-dev-require composer-package))))) + (begin + (warning (G_ "failed to parse ~a~%") php-name) + #f)))) (define %composer-updater (upstream-updater (name 'composer) (description "Updater for Composer packages") (pred php-package?) - (import latest-release))) + (import import-release))) (define* (composer-recursive-import package-name #:optional version) (recursive-import package-name diff --git a/guix/import/cpan.scm b/guix/import/cpan.scm index b87736eef6..85e5e69098 100644 --- a/guix/import/cpan.scm +++ b/guix/import/cpan.scm @@ -37,12 +37,14 @@ #:use-module (guix utils) #:use-module (guix base32) #:use-module ((guix download) #:select (download-to-store url-fetch)) - #:use-module ((guix import utils) #:select (factorize-uri)) + #:use-module ((guix import utils) + #:select (factorize-uri recursive-import)) #:use-module (guix import json) #:use-module (guix packages) #:use-module (guix upstream) #:use-module (guix derivations) #:export (cpan->guix-package + cpan-recursive-import metacpan-url->mirror-url %cpan-updater @@ -284,35 +286,39 @@ in RELEASE, a <cpan-release> record." upstream-input-downstream-name) inputs))))))) - (let ((tarball (with-store store + (let* ((tarball (with-store store (download-to-store store source-url))) - (inputs (cpan-module-inputs release))) - `(package - (name ,(cpan-name->downstream-name name)) - (version ,version) - (source (origin - (method url-fetch) - (uri (string-append ,@(factorize-uri source-url version))) - (sha256 - (base32 - ,(bytevector->nix-base32-string (file-sha256 tarball)))))) - (build-system perl-build-system) - ,@(maybe-inputs 'native-inputs - (filter (upstream-input-type-predicate 'native) - inputs)) - ,@(maybe-inputs 'propagated-inputs - (filter (upstream-input-type-predicate 'propagated) - inputs)) - (home-page ,(cpan-home name)) - (synopsis ,(cpan-release-abstract release)) - (description fill-in-yourself!) - (license ,(string->license (cpan-release-license release)))))) + (inputs (cpan-module-inputs release)) + (sexp + `(package + (name ,(cpan-name->downstream-name name)) + (version ,version) + (source (origin + (method url-fetch) + (uri (string-append ,@(factorize-uri source-url version))) + (sha256 + (base32 + ,(bytevector->nix-base32-string (file-sha256 tarball)))))) + (build-system perl-build-system) + ,@(maybe-inputs 'native-inputs + (filter (upstream-input-type-predicate 'native) + inputs)) + ,@(maybe-inputs 'propagated-inputs + (filter (upstream-input-type-predicate 'propagated) + inputs)) + (home-page ,(cpan-home name)) + (synopsis ,(cpan-release-abstract release)) + (description fill-in-yourself!) + (license ,(string->license (cpan-release-license release)))))) + (values sexp (map upstream-input-name inputs)))) -(define (cpan->guix-package module-name) +(define* (cpan->guix-package module-name #:key version #:allow-other-keys) "Fetch the metadata for PACKAGE-NAME from metacpan.org, and return the `package' s-expression corresponding to that package, or #f on failure." (let ((release (cpan-fetch (module->name module-name)))) - (and=> release cpan-module->sexp))) + (if release + (cpan-module->sexp release) + (values #f '())))) (define cpan-package? (let ((cpan-rx (make-regexp (string-append "(" @@ -357,6 +363,11 @@ in RELEASE, a <cpan-release> record." (urls (list url)) (inputs (cpan-module-inputs release))))))) +(define* (cpan-recursive-import package-name) + (recursive-import package-name + #:repo->guix-package cpan->guix-package + #:guix-name (compose cpan-name->downstream-name module->name))) + (define %cpan-updater (upstream-updater (name 'cpan) diff --git a/guix/import/cran.scm b/guix/import/cran.scm index 6ae00cae96..fe69cb87f7 100644 --- a/guix/import/cran.scm +++ b/guix/import/cran.scm @@ -23,6 +23,7 @@ ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. (define-module (guix import cran) + #:use-module (ice-9 ftw) #:use-module (ice-9 match) #:use-module (ice-9 regex) #:use-module (ice-9 popen) @@ -198,9 +199,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.19. Bioconductor packages should be +;; The latest Bioconductor release is 3.20. Bioconductor packages should be ;; updated together. -(define %bioconductor-version "3.19") +(define %bioconductor-version "3.20") (define* (bioconductor-packages-list-url #:optional type) (string-append "https://bioconductor.org/packages/" @@ -328,7 +329,7 @@ from ~a: ~a (~a)~%") (and (latest-bioconductor-package-version name 'experiment) 'experiment))) ;; TODO: Honor VERSION. (version (latest-bioconductor-package-version name type)) - (url (car (bioconductor-uri name version type))) + (url (bioconductor-uri name version type)) (meta (fetch-description-from-tarball url #:download (or replacement-download download)))) @@ -551,6 +552,106 @@ referenced in build system files." (set) (find-files dir "(Makevars(.in.*)?|configure.*)")))) +;; A pattern matching package imports. It detects uses of "library" or +;; "require", capturing the first argument; it also detects direct access of +;; namespaces via "::" or ":::", capturing the namespace. +(define import-pattern + (make-regexp + (string-append + ;; Ignore leading spaces, but don't capture commented expressions. + "(^ *" + ;; Quiet imports + "(suppressPackageStartupMessages\\()?" + ;; the actual import statement. + "(require|library)\\(\"?([^, \")]+)" + ;; Or perhaps... + "|" + ;; ...direct namespace access. + " *([A-Za-z0-9]+):::?" + ")"))) + +(define (needed-test-inputs-in-directory dir) + "Return a set of R package names that are found in library import +statements in files in the directory DIR." + (if (getenv "GUIX_CRAN_IGNORE_TEST_INPUTS") + (set) + (match (scandir dir (negate (cute member <> '("." "..")))) + ((package-directory-name . rest) + (let* ((test-directories + (filter file-exists? + (list (string-append dir "/" package-directory-name "/tests") + (string-append dir "/" package-directory-name "/Tests") + (string-append dir "/" package-directory-name "/inst/unitTests") + (string-append dir "/" package-directory-name "/inst/UnitTests")))) + (imported-packages + (fold (lambda (file packages) + (call-with-input-file file + (lambda (port) + (let loop ((packages packages)) + (let ((line (read-line port))) + (cond + ((eof-object? line) packages) + (else + (loop + (fold (lambda (match acc) + (let ((imported (or (match:substring match 4) + (match:substring match 5)))) + (if (or (not imported) + (string=? imported package-directory-name) + (member imported default-r-packages)) + acc + (set-insert imported acc)))) + packages + (list-matches import-pattern line)))))))))) + (set) + (append-map (lambda (directory) + (find-files directory "\\.(R|Rmd)")) + test-directories)))) + + ;; Special case for BiocGenerics + RUnit. + (if (any (lambda (directory) + (files-match-pattern? directory "BiocGenerics:::testPackage" + "\\.R")) + test-directories) + (set-insert "RUnit" + (set-insert "BiocGenerics" imported-packages)) + imported-packages))) + (_ (set))))) + +(define (needed-vignettes-inputs-in-directory dir) + "Return a set of R package names that are found in library import statements +in vignette files in the directory DIR." + (if (getenv "GUIX_CRAN_IGNORE_VIGNETTE_INPUTS") + (set) + (match (scandir dir (negate (cute member <> '("." "..")))) + ((package-directory-name . rest) + (let ((vignettes-directories + (filter file-exists? + (list (string-append dir "/" package-directory-name "/vignettes"))))) + (fold (lambda (file packages) + (call-with-input-file file + (lambda (port) + (let loop ((packages packages)) + (let ((line (read-line port))) + (cond + ((eof-object? line) packages) + (else + (loop + (fold (lambda (match acc) + (let ((imported (match:substring match 4))) + (if (or (not imported) + (string=? imported package-directory-name) + (member imported default-r-packages)) + acc + (set-insert imported acc)))) + packages + (list-matches import-pattern line)))))))))) + (set) + (append-map (lambda (directory) + (find-files directory "\\.Rnw")) + vignettes-directories)))) + (_ (set))))) + (define (directory-needs-pkg-config? dir) "Return #T if any of the Makevars files in the src directory DIR reference the pkg-config tool." @@ -572,6 +673,14 @@ in DIR." (name name) (downstream-name name))) (needed-libraries-in-directory dir)) + (map (lambda (name) + (upstream-input + (name name) + (downstream-name (cran-guix-name name)) + (type 'native))) + (set->list + (set-union (needed-test-inputs-in-directory dir) + (needed-vignettes-inputs-in-directory dir)))) (if (directory-needs-esbuild? dir) (list (native "esbuild")) '()) @@ -647,31 +756,46 @@ META." of META, a package in REPOSITORY." (let* ((url (cran-package-source-url meta repository)) (name (assoc-ref meta "Package")) - (source (download-source url - #:method - (cond ((assoc-ref meta 'git) 'git) - ((assoc-ref meta 'hg) 'hg) - (else #f)))) + (source (apply download-source url + (cond + ((assoc-ref meta 'git) '(#:method git)) + ((assoc-ref meta 'hg) '(#:method hg)) + (else '())))) (tarball? (not (or (assoc-ref meta 'git) - (assoc-ref meta 'hg))))) + (assoc-ref meta 'hg)))) + (compare-upstream-inputs + (lambda (input1 input2) + (string<? (upstream-input-downstream-name input1) + (upstream-input-downstream-name input2)))) + (upstream-inputs-equal? + (lambda (input1 input2) + (string=? (upstream-input-downstream-name input1) + (upstream-input-downstream-name input2)))) + (r-inputs + (append (cran-package-propagated-inputs meta) + (vignette-builders meta))) + (source-derived-inputs + ;; Only keep new inputs + (lset-difference upstream-inputs-equal? + (source->dependencies source tarball?) + r-inputs)) + (system-inputs + (filter-map (lambda (name) + (and (not (member name invalid-packages)) + (upstream-input + (name name) + (downstream-name + (transform-sysname name))))) + (map string-downcase + (listify meta "SystemRequirements"))))) (sort (filter ;; Prevent tight cycles. (lambda (input) ((negate string=?) name (upstream-input-name input))) - (append (source->dependencies source tarball?) - (filter-map (lambda (name) - (and (not (member name invalid-packages)) - (upstream-input - (name name) - (downstream-name - (transform-sysname name))))) - (map string-downcase - (listify meta "SystemRequirements"))) - (cran-package-propagated-inputs meta) - (vignette-builders meta))) - (lambda (input1 input2) - (string<? (upstream-input-downstream-name input1) - (upstream-input-downstream-name input2)))))) + (append source-derived-inputs + system-inputs + r-inputs)) + compare-upstream-inputs))) (define (phases-for-inputs input-names) "Generate a list of build phases based on the provided INPUT-NAMES, a list @@ -679,7 +803,11 @@ of package names for all input packages." (let ((rules (list (lambda () (and (any (lambda (name) - (member name '("styler" "ExperimentHub"))) + (member name + '("styler" + "ExperimentHub" + "R.cache" + "R.rsp"))) input-names) '(add-after 'unpack 'set-HOME (lambda _ (setenv "HOME" "/tmp"))))) @@ -737,7 +865,8 @@ 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->licenses (assoc-ref meta "License") license-prefix)) + (license (and=> (assoc-ref meta "License") + (cut string->licenses <> license-prefix))) ;; Some packages have multiple home pages. Some have none. (home-page (case repository ((git) (assoc-ref meta 'git)) @@ -748,10 +877,11 @@ from the alist META, which was derived from the R package's DESCRIPTION file." (source-url (cran-package-source-url meta repository)) (git? (if (assoc-ref meta 'git) #true #false)) (hg? (if (assoc-ref meta 'hg) #true #false)) - (source (download-source source-url #:method (cond - (git? 'git) - (hg? 'hg) - (else #f)))) + (source (apply download-source source-url + (cond + (git? '(#:method git)) + (hg? '(#:method hg)) + (else '())))) (uri-helper (uri-helper repository)) (inputs (cran-package-inputs meta repository #:download-source download-source)) @@ -831,7 +961,8 @@ from the alist META, which was derived from the R package's DESCRIPTION file." ,package)) (else package)) (filter-map (lambda (input) - (and (eq? 'propagated (upstream-input-type input)) + (and (string-prefix? "r-" + (upstream-input-downstream-name input)) (upstream-input-name input))) inputs)))) diff --git a/guix/import/crate.scm b/guix/import/crate.scm index 7a25b2243c..5996571cda 100644 --- a/guix/import/crate.scm +++ b/guix/import/crate.scm @@ -109,7 +109,7 @@ '(semver ranges) '(string->semver-range semver-range-contains?)) (define (lookup-crate name) - "Look up NAME on https://crates.io and return the corresopnding <crate> + "Look up NAME on https://crates.io and return the corresponding <crate> record or #f if it was not found." (let ((json (json-fetch (string-append (%crate-base-url) "/api/v1/crates/" name)))) @@ -141,6 +141,23 @@ record or #f if it was not found." ;;; Converting crates to Guix packages. ;;; +(define* (package-names->package-inputs names #:optional (output #f)) + "Given a list of PACKAGE-NAMES or (PACKAGE-NAME VERSION) pairs, and an +optional OUTPUT, tries to generate a quoted list of inputs, as suitable to +use in an 'inputs' field of a package definition." + (define (make-input input version) + (cons* input (list 'unquote (string->symbol + (if version + (string-append input "-" version) + input))) + (or (and output (list output)) + '()))) + + (map (match-lambda + ((input version) (make-input input version)) + (input (make-input input #f))) + names)) + (define (maybe-cargo-inputs package-names) (match (package-names->package-inputs package-names) (() @@ -187,6 +204,7 @@ and LICENSE." (guix-name (crate-name->package-name name)) (cargo-inputs (format-inputs cargo-inputs)) (cargo-development-inputs (format-inputs cargo-development-inputs)) + (description (beautify-description description)) (pkg `(package (name ,guix-name) (version ,version) @@ -211,8 +229,11 @@ and LICENSE." (maybe-cargo-development-inputs cargo-development-inputs))) (home-page ,home-page) - (synopsis ,synopsis) - (description ,(beautify-description description)) + (synopsis ,(beautify-synopsis synopsis)) + (description ,(if (string-prefix? "This" description) + description + (string-append "This package provides " + description))) (license ,(match license (() #f) (#f #f) diff --git a/guix/import/egg.scm b/guix/import/egg.scm index e3bc158475..a87de1453e 100644 --- a/guix/import/egg.scm +++ b/guix/import/egg.scm @@ -3,6 +3,7 @@ ;;; Copyright © 2021 Tobias Geerinckx-Rice <me@tobias.gr> ;;; Copyright © 2021 Sarah Morgensen <iskarian@mgsn.dev> ;;; Copyright © 2022 Hartmut Goebel <h.goebel@crazy-compilers.com> +;;; Copyright © 2024 Ekaitz Zarraga <ekaitz@elenq.tech> ;;; ;;; This file is part of GNU Guix. ;;; @@ -239,7 +240,7 @@ not work." (if system? (prettify-system-dependency name) (maybe-symbol->string name))) - + (let ((name (prettify-name (extract-name name)))) ;; Dependencies are sometimes specified as symbols and sometimes ;; as strings @@ -322,8 +323,9 @@ not work." (define* (egg-recursive-import package-name #:optional version) (recursive-import package-name #:version version - #:repo->guix-package (lambda* (name #:key version repo) - (egg->guix-package/m name version)) + #:repo->guix-package + (lambda* (name #:key version repo #:allow-other-keys) + (egg->guix-package/m name version)) #:guix-name egg-name->guix-name)) diff --git a/guix/import/elpa.scm b/guix/import/elpa.scm index d1855b3698..46b6dc98a2 100644 --- a/guix/import/elpa.scm +++ b/guix/import/elpa.scm @@ -250,6 +250,7 @@ RECIPE." (uri (git-reference (url ,url) (commit ,commit))) + (file-name (git-file-name name version)) (sha256 (base32 ,(bytevector->nix-base32-string diff --git a/guix/import/github.scm b/guix/import/github.scm index c5556d78ee..7be29ca151 100644 --- a/guix/import/github.scm +++ b/guix/import/github.scm @@ -327,7 +327,7 @@ Optionally include a VERSION string to fetch a specific version." (let* ((original-uri (origin-uri (package-source pkg))) (source-uri (github-uri original-uri)) - (name (package-name pkg)) + (name (package-upstream-name pkg)) (newest-version version-tag (latest-released-version source-uri name #:version version))) diff --git a/guix/import/gnome.scm b/guix/import/gnome.scm index 054ae44f7a..3ba8ae02e5 100644 --- a/guix/import/gnome.scm +++ b/guix/import/gnome.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2017, 2019, 2021 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2017, 2019, 2021, 2024 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2022 Maxim Cournoyer <maxim.cournoyer@gmail.com> ;;; Copyright © 2022 Hartmut Goebel <h.goebel@crazy-compilers.com> ;;; @@ -23,6 +23,8 @@ #:use-module (guix utils) #:use-module (guix packages) #:use-module (guix http-client) + #:use-module (guix diagnostics) + #:use-module (guix i18n) #:use-module (json) #:use-module (srfi srfi-1) #:use-module (srfi srfi-34) @@ -111,9 +113,12 @@ https://discourse.gnome.org/t/new-gnome-versioning-scheme/4235" releases)) (guard (c ((http-get-error? c) - (if (= 404 (http-get-error-code c)) - #f - (raise c)))) + (unless (= 404 (http-get-error-code c)) + (warning (G_ "failed to download from '~a': ~a (~s)~%") + (uri->string (http-get-error-uri c)) + (http-get-error-code c) + (http-get-error-reason c))) + #f)) (let* ((port (http-fetch/cached (string->uri (string-append "https://ftp.gnome.org/pub/gnome/sources/" diff --git a/guix/import/go.scm b/guix/import/go.scm index dd9298808d..32cba25b33 100644 --- a/guix/import/go.scm +++ b/guix/import/go.scm @@ -8,6 +8,7 @@ ;;; Copyright © 2021 Sarah Morgensen <iskarian@mgsn.dev> ;;; Copyright © 2021 Simon Tournier <zimon.toutoune@gmail.com> ;;; Copyright © 2023 Efraim Flashner <efraim@flashner.co.il> +;;; Copyright © 2024 Christina O'Donnell <cdo@mutix.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -39,7 +40,9 @@ #:autoload (htmlprag) (html->sxml) ;from Guile-Lib #:autoload (guix base32) (bytevector->nix-base32-string) #:autoload (guix build utils) (mkdir-p) + #:autoload (guix ui) (warning) #:autoload (gcrypt hash) (hash-algorithm sha256) + #:autoload (git structs) (git-error-message) #:use-module (ice-9 format) #:use-module (ice-9 match) #:use-module (ice-9 peg) @@ -72,6 +75,10 @@ ;;; unit of source code interchange and versioning". Modules are generally ;;; hosted in a repository. ;;; +;;; Monorepo is a collection of modules within the same VCS source. Each +;;; module of monorepo may be released individually by assigning +;;; "<subdir>/v<semver>" tag (see: https://go.dev/ref/mod#modules-overview). +;;; ;;; At this point it should handle correctly modules which have only Go ;;; dependencies and are accessible from proxy.golang.org (or configured via ;;; GOPROXY). @@ -122,15 +129,14 @@ https://godoc.org/golang.org/x/mod/module#hdr-Escaped_Paths)." (define (go.pkg.dev-info name) (http-fetch* (string-append "https://pkg.go.dev/" name))) -(define* (go-module-version-string goproxy name #:key version) - "Fetch the version string of the latest version for NAME from the given +(define* (go-module-version-info goproxy name #:key version) + "Fetch a JSON object encoding about the lastest version for NAME from the given GOPROXY server, or for VERSION when specified." (let ((file (if version (string-append "@v/" version ".info") "@latest"))) - (assoc-ref (json-fetch* (format #f "~a/~a/~a" - goproxy (go-path-escape name) file)) - "Version"))) + (json-fetch* (format #f "~a/~a/~a" + goproxy (go-path-escape name) file)))) (define* (go-module-available-versions goproxy name) "Retrieve the available versions for a given module from the module proxy. @@ -140,8 +146,17 @@ styles for the same package." (body (http-fetch* url)) (versions (remove string-null? (string-split body #\newline)))) (if (null? versions) - (list (go-module-version-string goproxy name)) ;latest version - versions))) + (begin + (warning (G_ "Empty list of versions on proxy ~a for package '~a'. Using latest.~%") + goproxy name) + ;; If we haven't recieved any versions, look in the version-info json + ;; object and return a one-element list if found. + (or (and=> (assoc-ref (go-module-version-info goproxy name) "Version") + list) + (raise (make-compound-condition + (formatted-message (G_ "No versions available for '~a' on proxy ~a.") + name goproxy)))))) + versions)) (define (go-package-licenses name) "Retrieve the list of licenses that apply to NAME, a Go package or module @@ -431,7 +446,7 @@ DIRECTIVE." (/[A-Za-z0-9_.\\-]+)*$" 'git))) -(define (module-path->repository-root module-path) +(define (module-path->repository-root module-path version-info) "Infer the repository root from a module path. Go modules can be defined at any level of a repository tree, but querying for the meta tag usually can only be done from the web page at the root of the repository, @@ -452,8 +467,22 @@ hence the need to derive this information." (lambda (vcs) (match:substring (regexp-exec (vcs-root-regex vcs) module-path) 1))) + (and=> (assoc-ref version-info "Origin") + (lambda (origin) + (and=> (assoc-ref origin "Subdir") + (lambda (subdir) + ;; If version-info contains a 'subdir' and that is a suffix, + ;; then the repo-root can be found by stripping off the + ;; suffix. + (if (string-suffix? (string-append "/" subdir) module-path) + (string-drop-right module-path + (+ 1 (string-length subdir))) + #f))))) (vcs-qualified-module-path->root-repo-url module-path) - module-path)) + (begin + (warning (G_ "Unable to determine repository root of '~a'. Guessing '~a'.~%") + module-path module-path) + module-path))) (define* (go-module->guix-package-name module-path #:optional version) "Converts a module's path to the canonical Guix format for Go packages. @@ -498,14 +527,19 @@ build a package." (select (sxpath `(// (meta (@ (equal? (name "go-import")))) // content)))) (match (select (html->sxml meta-data #:strict? #t)) - (() #f) ;nothing selected + (() (raise (make-compound-condition + (formatted-message (G_ "no <meta/> element in result when accessing module path '~a' using go-get") + module-path)))) ((('content content-text) ..1) (or (find (lambda (meta) (string-prefix? (module-meta-import-prefix meta) module-path)) (map go-import->module-meta content-text)) ;; Fallback to the first meta if no import prefixes match. - (go-import->module-meta (first content-text))))))) + (go-import->module-meta (first content-text)) + (raise (make-compound-condition + (formatted-message (G_ "unable to parse <meta/> when accessing module path '~a' using go-get") + module-path)))))))) (define (module-meta-data-repo-url meta-data goproxy) "Return the URL where the fetcher which will be used can download the @@ -534,13 +568,21 @@ tag." `(tag-or-commit . ,reference))))) (file-hash* checkout #:algorithm algorithm #:recursive? #true))) -(define (vcs->origin vcs-type vcs-repo-url version) +(define (vcs->origin vcs-type vcs-repo-url version subdir) "Generate the `origin' block of a package depending on what type of source control system is being used." (case vcs-type ((git) - (let ((plain-version? (string=? version (go-version->git-ref version))) - (v-prefixed? (string-prefix? "v" version))) + (let* ((plain-version? (string=? version (go-version->git-ref version + #:subdir subdir))) + (v-prefixed? (string-prefix? "v" version)) + ;; This is done because the version field of the package, + ;; which the generated quoted expression refers to, has been + ;; stripped of any 'v' prefixed. + (version-expr (if (and plain-version? v-prefixed?) + '(string-append "v" version) + `(go-version->git-ref version + ,@(if subdir `(#:subdir ,subdir) '()))))) `(origin (method git-fetch) (uri (git-reference @@ -548,14 +590,13 @@ control system is being used." ;; This is done because the version field of the package, ;; which the generated quoted expression refers to, has been ;; stripped of any 'v' prefixed. - (commit ,(if (and plain-version? v-prefixed?) - '(string-append "v" version) - '(go-version->git-ref version))))) + (commit ,version-expr))) (file-name (git-file-name name version)) (sha256 (base32 ,(bytevector->nix-base32-string - (git-checkout-hash vcs-repo-url (go-version->git-ref version) + (git-checkout-hash vcs-repo-url (go-version->git-ref version + #:subdir subdir) (hash-algorithm sha256)))))))) ((hg) `(origin @@ -612,6 +653,12 @@ available versions:~{ ~a~}.") (map strip-v-prefix available-versions))))))))) +(define (path-diff parent child) + (if (and (string-prefix? parent child) (not (string=? parent child))) + (let ((parent-len (string-length parent))) + (string-trim (substring child parent-len) (char-set #\/))) + #f)) + (define* (go-module->guix-package module-path #:key (goproxy "https://proxy.golang.org") version @@ -623,9 +670,11 @@ When VERSION is unspecified, the latest version available is used." (let* ((available-versions (go-module-available-versions goproxy module-path)) (version* (validate-version (or (and version (ensure-v-prefix version)) - (go-module-version-string goproxy module-path)) ;latest + (assoc-ref (go-module-version-info goproxy module-path) + "Version")) ;latest available-versions module-path)) + (version-info (go-module-version-info goproxy module-path #:version version*)) (content (fetch-go.mod goproxy module-path version*)) (min-go-version (second (go.mod-go-version (parse-go.mod content)))) (dependencies+versions (go.mod-requirements (parse-go.mod content))) @@ -634,11 +683,13 @@ When VERSION is unspecified, the latest version available is used." (map car dependencies+versions))) (module-path-sans-suffix (match:prefix (string-match "([\\./]v[0-9]+)?$" module-path))) - (guix-name (go-module->guix-package-name module-path)) - (root-module-path (module-path->repository-root module-path)) + (guix-name (go-module->guix-package-name module-path-sans-suffix )) + (root-module-path (module-path->repository-root module-path-sans-suffix + version-info)) ;; The VCS type and URL are not included in goproxy information. For ;; this we need to fetch it from the official module page. (meta-data (fetch-module-meta-data root-module-path)) + (subdir (path-diff root-module-path module-path-sans-suffix)) (vcs-type (module-meta-vcs meta-data)) (vcs-repo-url (module-meta-data-repo-url meta-data goproxy)) (synopsis (go-package-synopsis module-path)) @@ -649,14 +700,14 @@ When VERSION is unspecified, the latest version available is used." (name ,guix-name) (version ,(strip-v-prefix version*)) (source - ,(vcs->origin vcs-type vcs-repo-url version*)) + ,(vcs->origin vcs-type vcs-repo-url version* subdir)) (build-system go-build-system) (arguments (list ,@(if (version>? min-go-version (package-version (go-package))) `(#:go ,(string->number min-go-version)) '()) #:import-path ,module-path - ,@(if (string=? module-path-sans-suffix root-module-path) + ,@(if (string=? module-path root-module-path) '() `(#:unpack-path ,root-module-path)))) ,@(maybe-propagated-inputs @@ -685,16 +736,35 @@ When VERSION is unspecified, the latest version available is used." ;; consistently. (setvbuf (current-error-port) 'none) (let ((package-name (match args ((name _ ...) name)))) - (guard (c ((http-get-error? c) - (warning (G_ "Failed to import package ~s. + (begin + (info (G_ "Importing package ~s...~%") package-name) + (guard (c ((http-get-error? c) + (warning (G_ "Failed to import package ~s. reason: ~s could not be fetched: HTTP error ~a (~s). This package and its dependencies won't be imported.~%") - package-name - (uri->string (http-get-error-uri c)) - (http-get-error-code c) - (http-get-error-reason c)) - (values #f '()))) - (apply go-module->guix-package args))))) + package-name + (uri->string (http-get-error-uri c)) + (http-get-error-code c) + (http-get-error-reason c)) + + (values #f '())) + ((formatted-message? c) + (warning (G_ "Failed to import package ~s. +reason: ~a +This package and its dependencies won't be imported.~%") + package-name + (apply format #f + (formatted-message-string c) + (formatted-message-arguments c))) + (values #f '())) + ((eq? (exception-kind c) 'git-error) + (warning (G_ "Failed to import package ~s. +reason: ~a +This package and its dependencies won't be imported.~%") + package-name + (git-error-message c)) + (values #f '()))) + (apply go-module->guix-package args)))))) (define* (go-module-recursive-import package-name #:key (goproxy "https://proxy.golang.org") diff --git a/guix/import/hackage.scm b/guix/import/hackage.scm index 79a51d3300..422887d435 100644 --- a/guix/import/hackage.scm +++ b/guix/import/hackage.scm @@ -9,6 +9,7 @@ ;;; Copyright © 2019 Simon Tournier <zimon.toutoune@gmail.com> ;;; Copyright © 2022 Hartmut Goebel <h.goebel@crazy-compilers.com> ;;; Copyright © 2023-2024 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2024 Nicolas Graves <ngraves@ngraves.fr> ;;; ;;; This file is part of GNU Guix. ;;; @@ -136,7 +137,7 @@ format as two values." (values (read-cabal (canonical-newline-port port)) (bytevector->nix-base32-string (get-hash))))) -(define (hackage-fetch-and-hash name-version) +(define (hackage-fetch-and-hash name version) "Fetch the latest Cabal revision for the package NAME-VERSION, and return two values: the parsed Cabal file and its hash in nix-base32 format. If the version part is omitted from the package name, then fetch the latest @@ -144,18 +145,19 @@ version. On failure, both return values will be #f." (guard (c ((and (http-get-error? c) (= 404 (http-get-error-code c))) (values #f #f))) ;"expected" if package is unknown - (let* ((name version (package-name->name+version name-version)) - (url (hackage-cabal-url name version)) - (port _ (http-fetch url)) - (cabal hash (read-cabal-and-hash port))) + (let* ((name new-version (package-name->name+version name)) + (version (or version new-version)) + (url (hackage-cabal-url name version)) + (port _ (http-fetch url)) + (cabal hash (read-cabal-and-hash port))) (close-port port) (values cabal hash)))) -(define (hackage-fetch name-version) +(define (hackage-fetch name version) "Return the Cabal file for the package NAME-VERSION, or #f on failure. If the version part is omitted from the package name, then return the latest version." - (let ((cabal hash (hackage-fetch-and-hash name-version))) + (let ((cabal hash (hackage-fetch-and-hash name version))) cabal)) (define string->license @@ -355,7 +357,7 @@ respectively." (let ((cabal-meta cabal-hash (if port (read-cabal-and-hash port) - (hackage-fetch-and-hash package-name)))) + (hackage-fetch-and-hash package-name #f)))) (if cabal-meta (hackage-module->sexp (eval-cabal cabal-meta cabal-environment) cabal-hash @@ -377,15 +379,10 @@ respectively." (let ((hackage-rx (make-regexp "(https?://hackage.haskell.org|mirror://hackage/)"))) (url-predicate (cut regexp-exec hackage-rx <>)))) -(define* (latest-release package #:key (version #f)) +(define* (import-release package #:key (version #f)) "Return an <upstream-source> for the latest release of PACKAGE." - (when version - (raise - (formatted-message - (G_ "~a updater doesn't support updating to a specific version, sorry.") - "hackage"))) (let* ((hackage-name (package-upstream-name* package)) - (cabal-meta (hackage-fetch hackage-name))) + (cabal-meta (hackage-fetch hackage-name version))) (match cabal-meta (#f (format (current-error-port) @@ -407,6 +404,6 @@ respectively." (name 'hackage) (description "Updater for Hackage packages") (pred hackage-package?) - (import latest-release))) + (import import-release))) ;;; cabal.scm ends here diff --git a/guix/import/npm-binary.scm b/guix/import/npm-binary.scm new file mode 100644 index 0000000000..6dfedc4910 --- /dev/null +++ b/guix/import/npm-binary.scm @@ -0,0 +1,279 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2019, 2020 Timothy Sample <samplet@ngyro.com> +;;; Copyright © 2021 Lars-Dominik Braun <lars@6xq.net> +;;; Copyright © 2020, 2023, 2024 Jelle Licht <jlicht@fsfe.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 npm-binary) + #:use-module ((gnu services configuration) #:select (alist?)) + #:use-module (gcrypt hash) + #:use-module (gnu packages) + #:use-module (guix base32) + #:use-module (guix http-client) + #:use-module (guix import json) + #:use-module (guix import utils) + #:use-module (guix memoization) + #:use-module (guix utils) + #:use-module (ice-9 match) + #:use-module (ice-9 receive) + #:use-module (ice-9 regex) + #:use-module (json) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-26) + #:use-module (srfi srfi-41) + #:use-module (srfi srfi-9) + #:use-module (web client) + #:use-module (web response) + #:use-module (web uri) + #:export (npm-binary-recursive-import + npm-binary->guix-package + %npm-registry + make-versioned-package + name+version->symbol)) + +;; Autoload Guile-Semver so we only have a soft dependency. +(module-autoload! (current-module) + '(semver) + '(string->semver semver? semver->string semver=? semver>?)) +(module-autoload! (current-module) + '(semver ranges) + '(*semver-range-any* string->semver-range semver-range-contains?)) + +;; Dist-tags +(define-json-mapping <dist-tags> make-dist-tags dist-tags? + json->dist-tags + (latest dist-tags-latest "latest" string->semver)) + +(define-record-type <versioned-package> + (make-versioned-package name version) + versioned-package? + (name versioned-package-name) ;string + (version versioned-package-version)) ;string + +(define (dependencies->versioned-packages entries) + (match entries + (((names . versions) ...) + (map make-versioned-package names versions)) + (_ '()))) + +(define (extract-license license-string) + (if (unspecified? license-string) + 'unspecified! + (spdx-string->license license-string))) + +(define-json-mapping <dist> make-dist dist? + json->dist + (tarball dist-tarball)) + +(define (empty-or-string s) + (if (string? s) s "")) + +(define-json-mapping <package-revision> make-package-revision package-revision? + json->package-revision + (name package-revision-name) + (version package-revision-version "version" ;semver + string->semver) + (home-page package-revision-home-page "homepage") ;string + (dependencies package-revision-dependencies ;list of versioned-package + "dependencies" + dependencies->versioned-packages) + (dev-dependencies package-revision-dev-dependencies ;list of versioned-package + "devDependencies" dependencies->versioned-packages) + (peer-dependencies package-revision-peer-dependencies ;list of versioned-package + "peerDependencies" dependencies->versioned-packages) + (license package-revision-license "license" ;license | #f + (match-lambda + ((? unspecified?) #f) + ((? string? str) (spdx-string->license str)) + ((? alist? alist) + (match (assoc "type" alist) + ((_ . (? string? type)) + (spdx-string->license type)) + (_ #f))))) + (description package-revision-description ;string + "description" empty-or-string) + (dist package-revision-dist "dist" json->dist)) ;dist + +(define (versions->package-revisions versions) + (match versions + (((version . package-spec) ...) + (map json->package-revision package-spec)) + (_ '()))) + +(define (versions->package-versions versions) + (match versions + (((version . package-spec) ...) + (map string->semver versions)) + (_ '()))) + +(define-json-mapping <meta-package> make-meta-package meta-package? + json->meta-package + (name meta-package-name) ;string + (description meta-package-description) ;string + (dist-tags meta-package-dist-tags "dist-tags" json->dist-tags) ;dist-tags + (revisions meta-package-revisions "versions" versions->package-revisions)) + +(define %npm-registry + (make-parameter "https://registry.npmjs.org")) +(define %default-page "https://www.npmjs.com/package") + +(define (lookup-meta-package name) + (let ((json (json-fetch (string-append (%npm-registry) "/" (uri-encode name))))) + (and=> json json->meta-package))) + +(define lookup-meta-package* (memoize lookup-meta-package)) + +(define (meta-package-versions meta) + (map package-revision-version + (meta-package-revisions meta))) + +(define (meta-package-latest meta) + (and=> (meta-package-dist-tags meta) dist-tags-latest)) + +(define* (meta-package-package meta #:optional + (version (meta-package-latest meta))) + (match version + ((? semver?) (find (lambda (revision) + (semver=? version (package-revision-version revision))) + (meta-package-revisions meta))) + ((? string?) (meta-package-package meta (string->semver version))) + (_ #f))) + +(define* (semver-latest svs #:optional (svr *semver-range-any*)) + (find (cut semver-range-contains? svr <>) + (sort svs semver>?))) + +(define* (resolve-package name #:optional (svr *semver-range-any*)) + (let ((meta (lookup-meta-package* name))) + (and meta + (let* ((version (semver-latest (or (meta-package-versions meta) '()) svr)) + (pkg (meta-package-package meta version))) + pkg)))) + + +;;; +;;; Converting packages +;;; + +(define (hash-url url) + "Downloads the resource at URL and computes the base32 hash for it." + (bytevector->nix-base32-string (port-sha256 (http-fetch url)))) + +(define (npm-name->name npm-name) + "Return a Guix package name for the npm package with name NPM-NAME." + (define (clean name) + (string-map (lambda (chr) (if (char=? chr #\/) #\- chr)) + (string-filter (negate (cut char=? <> #\@)) name))) + (guix-name "node-" (clean npm-name))) + +(define (name+version->symbol name version) + (string->symbol (string-append name "-" version))) + +(define (package-revision->symbol package) + (let* ((npm-name (package-revision-name package)) + (version (semver->string (package-revision-version package))) + (name (npm-name->name npm-name))) + (name+version->symbol name version))) + +(define (npm-package->package-sexp npm-package) + "Return the `package' s-expression for an NPM-PACKAGE." + (define resolve-spec + (match-lambda + (($ <versioned-package> name version) + (resolve-package name (string->semver-range version))))) + + (if (package-revision? npm-package) + (let ((name (package-revision-name npm-package)) + (version (package-revision-version npm-package)) + (home-page (package-revision-home-page npm-package)) + (dependencies (package-revision-dependencies npm-package)) + (dev-dependencies (package-revision-dev-dependencies npm-package)) + (peer-dependencies (package-revision-peer-dependencies npm-package)) + (license (package-revision-license npm-package)) + (description (package-revision-description npm-package)) + (dist (package-revision-dist npm-package))) + (let* ((name (npm-name->name name)) + (url (dist-tarball dist)) + (home-page (if (string? home-page) + home-page + (string-append %default-page "/" (uri-encode name)))) + (synopsis description) + (resolved-deps (map resolve-spec + (append dependencies peer-dependencies))) + (peer-names (map versioned-package-name peer-dependencies)) + ;; lset-difference for treating peer-dependencies as dependencies, + ;; which leads to dependency cycles. lset-union for treating them as + ;; (ignored) dev-dependencies, which leads to broken packages. + (dev-names + (lset-union string= + (map versioned-package-name dev-dependencies) + peer-names)) + (extra-phases + (match dev-names + (() '()) + ((dev-names ...) + `((add-after 'patch-dependencies 'delete-dev-dependencies + (lambda _ + (delete-dependencies '(,@(reverse dev-names)))))))))) + (values + `(package + (name ,name) + (version ,(semver->string (package-revision-version npm-package))) + (source (origin + (method url-fetch) + (uri ,url) + (sha256 (base32 ,(hash-url url))))) + (build-system node-build-system) + (arguments + (list + #:tests? #f + #:phases + #~(modify-phases %standard-phases + (delete 'build) + ,@extra-phases))) + ,@(match dependencies + (() '()) + ((dependencies ...) + `((inputs + (list ,@(map package-revision->symbol resolved-deps)))))) + (home-page ,home-page) + (synopsis ,synopsis) + (description ,description) + (license ,license)) + (map (match-lambda (($ <package-revision> name version) + (list name (semver->string version)))) + resolved-deps)))) + (values #f '()))) + + +;;; +;;; Interface +;;; + +(define npm-binary->guix-package + (lambda* (name #:key (version *semver-range-any*) #:allow-other-keys) + (let* ((svr (match version + ((? string?) (string->semver-range version)) + (_ version))) + (pkg (resolve-package name svr))) + (npm-package->package-sexp pkg)))) + +(define* (npm-binary-recursive-import package-name #:key version) + (recursive-import package-name + #:repo->guix-package (memoize npm-binary->guix-package) + #:version version + #:guix-name npm-name->name)) diff --git a/guix/import/pypi.scm b/guix/import/pypi.scm index 6719fde330..935ecd33d0 100644 --- a/guix/import/pypi.scm +++ b/guix/import/pypi.scm @@ -4,7 +4,7 @@ ;;; Copyright © 2015-2017, 2019-2024 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com> ;;; Copyright © 2018, 2023 Ricardo Wurmus <rekado@elephly.net> -;;; Copyright © 2019 Maxim Cournoyer <maxim.cournoyer@gmail.com> +;;; Copyright © 2019, 2024 Maxim Cournoyer <maxim.cournoyer@gmail.com> ;;; Copyright © 2020 Jakub Kądziołka <kuba@kadziolka.net> ;;; Copyright © 2020 Lars-Dominik Braun <ldb@leibniz-psychology.org> ;;; Copyright © 2020 Arun Isaac <arunisaac@systemreboot.net> @@ -57,6 +57,7 @@ #:use-module (guix import utils) #:use-module (guix import json) #:use-module (json) + #:use-module (guix build toml) #:use-module (guix packages) #:use-module (guix upstream) #:use-module ((guix licenses) #:prefix license:) @@ -282,12 +283,7 @@ satisfy." (let ((line (read-line port))) (cond ((eof-object? line) - ;; Duplicates can occur, since the same requirement can be - ;; listed multiple times with different conditional markers, e.g. - ;; pytest >= 3 ; python_version >= "3.3" - ;; pytest < 3 ; python_version < "3.3" - (map (compose reverse delete-duplicates) - (list required-deps test-deps))) + (list required-deps test-deps)) ((or (string-null? line) (comment? line)) (loop required-deps test-deps inside-test-section? optional?)) ((section-header? line) @@ -341,8 +337,7 @@ returned value." (let ((line (read-line port))) (cond ((eof-object? line) - (map (compose reverse delete-duplicates) - (list required-deps test-deps))) + (list required-deps test-deps)) ((and (requires-dist-header? line) (not (extra? line))) (loop (cons (specification->requirement-name (requires-dist-value line)) @@ -386,7 +381,42 @@ be extracted in a temporary directory." (if wheel-url (and (url-fetch wheel-url temp) (read-wheel-metadata temp)) - #f)))) + (list '() '()))))) + + (define (guess-requirements-from-pyproject.toml dir) + (let* ((pyproject.toml-files (find-files dir (lambda (abs-file-name _) + (string-match "/pyproject.toml$" + abs-file-name)))) + (pyproject.toml (match pyproject.toml-files + (() + (warning (G_ "Cannot guess requirements from \ +pyproject.toml file, because it does not exist.~%")) + '()) + (else (parse-toml-file (first pyproject.toml-files))))) + (pyproject-build-requirements + (or (recursive-assoc-ref pyproject.toml '("build-system" "requires")) '())) + (pyproject-dependencies + (or (recursive-assoc-ref pyproject.toml '("project" "dependencies")) '())) + ;; This is more of a convention, since optional-dependencies is a table of arbitrary values. + (pyproject-test-dependencies + (or (recursive-assoc-ref pyproject.toml '("project" "optional-dependencies" "test")) '()))) + (if (null? pyproject.toml) + #f + (list (map specification->requirement-name pyproject-dependencies) + (map specification->requirement-name + (append pyproject-build-requirements + pyproject-test-dependencies)))))) + + (define (guess-requirements-from-requires.txt dir) + (let ((requires.txt-files (find-files dir (lambda (abs-file-name _) + (string-match "\\.egg-info/requires.txt$" + abs-file-name))))) + (match requires.txt-files + (() + (warning (G_ "Cannot guess requirements from source archive: \ +no requires.txt file found.~%")) + #f) + (else (parse-requires.txt (first requires.txt-files)))))) (define (guess-requirements-from-source) ;; Return the package's requirements by guessing them from the source. @@ -398,27 +428,35 @@ be extracted in a temporary directory." (if (string=? "zip" (file-extension source-url)) (invoke "unzip" archive "-d" dir) (invoke "tar" "xf" archive "-C" dir))) - (let ((requires.txt-files - (find-files dir (lambda (abs-file-name _) - (string-match "\\.egg-info/requires.txt$" - abs-file-name))))) - (match requires.txt-files - (() - (warning (G_ "Cannot guess requirements from source archive:\ - no requires.txt file found.~%")) - (list '() '())) - (else (parse-requires.txt (first requires.txt-files))))))) + (list (guess-requirements-from-pyproject.toml dir) + (guess-requirements-from-requires.txt dir)))) (begin (warning (G_ "Unsupported archive format; \ cannot determine package dependencies from source archive: ~a~%") (basename source-url)) - (list '() '())))) - - ;; First, try to compute the requirements using the wheel, else, fallback to - ;; reading the "requires.txt" from the egg-info directory from the source - ;; archive. - (or (guess-requirements-from-wheel) - (guess-requirements-from-source))) + (list #f #f)))) + + (define (merge a b) + "Given lists A and B with two iteams each, combine A1 and B1, as well as A2 and B2." + (match (list a b) + (((first-propagated first-native) (second-propagated second-native)) + (list (append first-propagated second-propagated) (append first-native second-native))))) + + (define default-pyproject.toml-dependencies + ;; If there is no pyproject.toml, we assume it’s an old-style setuptools-based project. + '(() ("setuptools"))) + + ;; requires.txt and the metadata of a wheel contain redundant information, + ;; so fetch only one of them, preferring requires.txt from the source + ;; distribution, which we always fetch, since the source tarball also + ;; contains pyproject.toml. + (match (guess-requirements-from-source) + ((from-pyproject.toml #f) + (merge (or from-pyproject.toml default-pyproject.toml-dependencies) + (or (guess-requirements-from-wheel) '(() ())))) + ((from-pyproject.toml from-requires.txt) + (merge (or from-pyproject.toml default-pyproject.toml-dependencies) + from-requires.txt)))) (define (compute-inputs source-url wheel-url archive) "Given the SOURCE-URL and WHEEL-URL of an already downloaded ARCHIVE, return @@ -432,12 +470,20 @@ the corresponding list of <upstream-input> records." (type type)))) (sort deps string-ci<?))) + (define (add-missing-native-inputs inputs) + ;; setuptools cannot build wheels without the python-wheel. + (if (member "setuptools" inputs) + (cons "wheel" inputs) + inputs)) + ;; TODO: Record version number ranges in <upstream-input>. (let ((dependencies (guess-requirements source-url wheel-url archive))) (match dependencies ((propagated native) - (append (requirements->upstream-inputs propagated 'propagated) - (requirements->upstream-inputs native 'native)))))) + (append (requirements->upstream-inputs (delete-duplicates propagated) + 'propagated) + (requirements->upstream-inputs (delete-duplicates (add-missing-native-inputs native)) + 'native)))))) (define* (pypi-package-inputs pypi-package #:optional version) "Return the list of <upstream-input> for PYPI-PACKAGE. This procedure @@ -457,10 +503,13 @@ downloads the source and possibly the wheel of PYPI-PACKAGE." "Try different project name substitution until the result is found in pypi-uri. Downcase is required for \"uWSGI\", and underscores are required for flake8-array-spacing." + ;; XXX: Each tool producing wheels and sdists appear to have their own, + ;; distinct, naming scheme. (or (find (cut string-contains pypi-url <>) (list name (string-downcase name) - (string-replace-substring name "-" "_"))) + (string-replace-substring name "-" "_") + (string-replace-substring name "." "_"))) (begin (warning (G_ "project name ~a does not appear verbatim in the PyPI URI~%") @@ -544,8 +593,9 @@ name))) 'native-inputs) (home-page ,(project-info-home-page info)) (synopsis ,(project-info-summary info)) - (description ,(beautify-description - (project-info-summary info))) + (description ,(and=> (non-empty-string-or-false + (project-info-summary info)) + beautify-description)) (license ,(license->symbol (string->license (project-info-license info))))) diff --git a/guix/import/stackage.scm b/guix/import/stackage.scm index f801835b33..9554c3d7a4 100644 --- a/guix/import/stackage.scm +++ b/guix/import/stackage.scm @@ -50,7 +50,7 @@ (make-parameter "https://www.stackage.org")) ;; Latest LTS version compatible with current GHC. -(define %default-lts-version "20.5") +(define %default-lts-version "20.26") (define-json-mapping <stackage-lts> make-stackage-lts stackage-lts? @@ -151,9 +151,9 @@ PACKAGE or #f if the package is not included in the Stackage LTS release." (G_ "~a updater doesn't support updating to a specific version, sorry.") "stackage"))) (let* ((hackage-name (package-upstream-name* pkg)) - (version (lts-package-version (packages) hackage-name)) - (name-version (hackage-name-version hackage-name version))) - (match (and=> name-version hackage-fetch) + (version (lts-package-version (packages) hackage-name))) + (match (and hackage-name version + (hackage-fetch hackage-name version)) (#f (warning (G_ "failed to parse ~a~%") (hackage-cabal-url hackage-name)) @@ -164,7 +164,8 @@ PACKAGE or #f if the package is not included in the Stackage LTS release." (version version) (urls (list url)) (inputs - (let ((cabal (eval-cabal (hackage-fetch name-version) '()))) + (let ((cabal (eval-cabal (hackage-fetch hackage-name version) + '()))) (cabal-package-inputs cabal))))))))))) (define (stackage-lts-package? package) diff --git a/guix/import/texlive.scm b/guix/import/texlive.scm index 7e79c77884..6d04cc25ee 100644 --- a/guix/import/texlive.scm +++ b/guix/import/texlive.scm @@ -1,6 +1,7 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2017, 2021, 2022, 2023 Ricardo Wurmus <rekado@elephly.net> ;;; Copyright © 2021 Maxim Cournoyer <maxim.cournoyer@gmail.com> +;;; Copyright © 2024 Nicolas Goaziou <mail@nicolasgoaziou.fr> ;;; ;;; This file is part of GNU Guix. ;;; @@ -18,27 +19,35 @@ ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. (define-module (guix import texlive) + #:use-module (gcrypt hash) + #:use-module (guix base32) + #:use-module (guix build-system) + #:use-module (guix build-system texlive) + #:use-module (guix derivations) + #:use-module (guix diagnostics) + #:use-module (guix gexp) + #:use-module (guix i18n) + #:use-module (guix import utils) + #:use-module (guix memoization) + #:use-module (guix monads) + #:use-module (guix packages) + #:use-module ((guix serialization) #:select (write-file)) + #:use-module (guix store) + #:use-module (guix svn-download) + #:use-module (guix upstream) #:use-module (ice-9 ftw) #:use-module (ice-9 match) + #:use-module (ice-9 popen) #:use-module (ice-9 rdelim) + #:use-module (ice-9 regex) #:use-module (srfi srfi-1) #:use-module (srfi srfi-2) #:use-module (srfi srfi-11) + #:use-module (srfi srfi-19) #:use-module (srfi srfi-26) - #:use-module (gcrypt hash) - #:use-module (guix derivations) - #:use-module (guix memoization) - #:use-module (guix monads) - #:use-module (guix gexp) - #:use-module (guix store) - #:use-module (guix base32) - #:use-module (guix serialization) - #:use-module (guix svn-download) - #:use-module (guix import utils) - #:use-module (guix build-system texlive) - #:export (files-differ? - texlive->guix-package - texlive-recursive-import)) + #:export (texlive->guix-package + texlive-recursive-import + %texlive-updater)) ;;; Commentary: ;;; @@ -64,6 +73,205 @@ "tex/generic/hyphen/" "web2c/")) +;; The following packages do not have any auxiliary "-bin" package to +;; propagate, even if they do have a corresponding ".ARCH" entry in the TeX +;; Live package database. They fall into 3 categories: +;; +;; 1. Associated entries in NAME.ARCH are already provided by TEXLIVE-BIN. +;; +;; 2. Associated entries in NAME.ARCH are symlinks to binaries provided by +;; TEXLIVE-BIN. +;; +;; 3. They fool the (naive) algorithm for "-bin" propagation and generate +;; false positives. This generally happens when the package creates multiple +;; symlinks to a script it bundles. +(define no-bin-propagation-packages + (list + ;; Category 1. + "ctie" + "cweb" + "luahbtex" + "luatex" + "metafont" + "pdftex" + "pdftosrc" + "synctex" + "tex" + "tie" + "web" + ;; Category 2. + "amstex" + "csplain" + "eplain" + "jadetex" + "latex-bin" + "lollipop" + "mex" + "mltex" + "optex" + "platex" + "uplatex" + "texsis" + "xmltex" + ;; Category 3. + "biber" + "context" + "cluttex" + "esptopdf" + "pdfcrop" + "texdef")) + +;; Guix introduces two specific packages based on TEXLIVE-BUILD-SYSTEM. Add +;; an entry for them in the package database, so they can be imported, and +;; updated, like any other regular TeX Live package. +(define tlpdb-guix-packages + '(("hyphen-complete" + (docfiles "texmf-dist/doc/generic/dehyph-exptl/" + "texmf-dist/doc/generic/elhyphen/" + "texmf-dist/doc/generic/huhyphen/" + "texmf-dist/doc/generic/hyph-utf8/" + "texmf-dist/doc/luatex/hyph-utf8/" + "texmf-dist/doc/generic/ukrhyph/") + (runfiles "texmf-dist/tex/generic/config/" + "texmf-dist/tex/generic/dehyph/" + "texmf-dist/tex/generic/dehyph-exptl/" + "texmf-dist/tex/generic/hyph-utf8/" + "texmf-dist/tex/generic/hyphen/" + "texmf-dist/tex/generic/ruhyphen/" + "texmf-dist/tex/generic/ukrhyph/" + "texmf-dist/tex/luatex/hyph-utf8/") + (srcfiles "texmf-dist/source/generic/hyph-utf8/" + "texmf-dist/source/luatex/hyph-utf8/" + "texmf-dist/source/generic/ruhyphen/") + (shortdesc . "Hyphenation patterns expressed in UTF-8") + (longdesc . "Modern native UTF-8 engines such as XeTeX and LuaTeX +need hyphenation patterns in UTF-8 format, whereas older systems require +hyphenation patterns in the 8-bit encoding of the font in use (such encodings +are codified in the LaTeX scheme with names like OT1, T2A, TS1, OML, LY1, +etc). The present package offers a collection of conversions of existing +patterns to UTF-8 format, together with converters for use with 8-bit fonts in +older systems. + +This Guix-specific package provides hyphenation patterns for all languages +supported in TeX Live. It is a strict super-set of code{hyphen-base} package +and should be preferred to it whenever a package would otherwise depend on +@code{hyph-utf8}.")) + ("scripts" + (shortdesc . "TeX Live infrastructure programs") + (longdesc . "This package provides core TeX Live scripts such as updmap, +fmtutil, and tlmgr. It is automatically installed alongside texlive-bin.") + (docfiles "texmf-dist/doc/man/man1/fmtutil-sys.1" + "texmf-dist/doc/man/man1/fmtutil-sys.man1.pdf" + "texmf-dist/doc/man/man1/fmtutil-user.1" + "texmf-dist/doc/man/man1/fmtutil-user.man1.pdf" + "texmf-dist/doc/man/man1/fmtutil.1" + "texmf-dist/doc/man/man1/fmtutil.man1.pdf" + "texmf-dist/doc/man/man1/install-tl.1" + "texmf-dist/doc/man/man1/install-tl.man1.pdf" + "texmf-dist/doc/man/man1/mktexfmt.1" + "texmf-dist/doc/man/man1/mktexfmt.man1.pdf" + "texmf-dist/doc/man/man1/mktexlsr.1" + "texmf-dist/doc/man/man1/mktexlsr.man1.pdf" + "texmf-dist/doc/man/man1/mktexmf.1" + "texmf-dist/doc/man/man1/mktexmf.man1.pdf" + "texmf-dist/doc/man/man1/mktexpk.1" + "texmf-dist/doc/man/man1/mktexpk.man1.pdf" + "texmf-dist/doc/man/man1/mktextfm.1" + "texmf-dist/doc/man/man1/mktextfm.man1.pdf" + "texmf-dist/doc/man/man1/texhash.1" + "texmf-dist/doc/man/man1/texhash.man1.pdf" + "texmf-dist/doc/man/man1/tlmgr.1" + "texmf-dist/doc/man/man1/tlmgr.man1.pdf" + "texmf-dist/doc/man/man1/updmap-sys.1" + "texmf-dist/doc/man/man1/updmap-sys.man1.pdf" + "texmf-dist/doc/man/man1/updmap-user.1" + "texmf-dist/doc/man/man1/updmap-user.man1.pdf" + "texmf-dist/doc/man/man1/updmap.1" + "texmf-dist/doc/man/man1/updmap.man1.pdf" + "texmf-dist/doc/man/man5/fmtutil.cnf.5" + "texmf-dist/doc/man/man5/fmtutil.cnf.man5.pdf" + "texmf-dist/doc/man/man5/updmap.cfg.5" + "texmf-dist/doc/man/man5/updmap.cfg.man5.pdf") + (runfiles "texmf-dist/dvips/tetex/" + "texmf-dist/fonts/enc/dvips/tetex/" + "texmf-dist/fonts/map/dvips/tetex/" + "texmf-dist/scripts/texlive/fmtutil-sys.sh" + "texmf-dist/scripts/texlive/fmtutil-user.sh" + "texmf-dist/scripts/texlive/fmtutil.pl" + "texmf-dist/scripts/texlive/mktexlsr.pl" + "texmf-dist/scripts/texlive/mktexmf" + "texmf-dist/scripts/texlive/mktexpk" + "texmf-dist/scripts/texlive/mktextfm" + "texmf-dist/scripts/texlive/tlmgr.pl" + "texmf-dist/scripts/texlive/updmap-sys.sh" + "texmf-dist/scripts/texlive/updmap-user.sh" + "texmf-dist/scripts/texlive/updmap.pl" + "texmf-dist/web2c/fmtutil-hdr.cnf" + "texmf-dist/web2c/updmap-hdr.cfg" + "texmf-dist/web2c/updmap.cfg" + "tlpkg/gpg/" + "tlpkg/installer/config.guess" + "tlpkg/installer/curl/curl-ca-bundle.crt" + "tlpkg/TeXLive/" + "tlpkg/texlive.tlpdb")) + ("source" + (shortdesc . "Source code for all TeX Live programs") + (longdesc . "This package fetches the source for all TeX Live programs +provided by the TeX Live repository. It is meant to be used as a source-only +package; it should not be installed in a profile.") + (runfiles "./")))) + +(define (svn-command . args) + "Execute \"svn\" command with arguments ARGS, provided as strings, and +return its output as a string. Raise an error if the command execution did +not succeed." + (define subversion + ;; Resolve this variable lazily so that (gnu packages ...) does not end up + ;; in the closure of this module. + (module-ref (resolve-interface '(gnu packages version-control)) + 'subversion)) + (let* ((svn + (with-store store + (run-with-store store + (mlet* %store-monad + ((drv (lower-object subversion)) + (built (built-derivations (list drv)))) + (match (derivation->output-paths drv) + (((names . locations) ...) + (return (string-append (first locations) "/bin/svn")))))))) + (command (string-append svn (string-join args " " 'prefix))) + (pipe (open-input-pipe command)) + (output (read-string pipe))) + ;; Output from these commands is memoized. Raising an error prevent from + ;; storing bogus values in memory. + (unless (zero? (status:exit-val (close-pipe pipe))) + (report-error (G_ "failed to run command: '~a'") command)) + output)) + +(define version->revision + ;; Return revision, as a number, associated to string VERSION. + (lambda (version) + (let ((url (string-append %texlive-repository "tags/texlive-" version))) + (string->number + (svn-command + "info" url "--show-item 'last-changed-revision'" "--no-newline"))))) + +(define (current-day) + "Return number of days since Epoch." + (floor (/ (time-second (current-time)) (* 24 60 60)))) + +(define latest-texlive-tag + ;; Return the latest TeX Live tag in repository. The argument refers to + ;; current day, so memoization is only active a single day, as the + ;; repository may have been updated between two calls. + (memoize + (lambda* (#:key (day (current-day))) + (let ((output + (svn-command "ls" (string-append %texlive-repository "tags") "-v"))) + ;; E.g. "70951 karl april 15 18:11 texlive-2024.2/\n\n" + (and=> (string-match "texlive-([^/]+)/\n*$" output) + (cut match:substring <> 1)))))) + (define string->license (match-lambda ("artistic2" 'artistic2.0) @@ -135,12 +343,10 @@ (chr (char-downcase chr))) name))) -(define* (translate-depends depends #:optional texlive-only) - "Translate TeX Live packages DEPENDS into their equivalent Guix names -in `(gnu packages tex)' module, without \"texlive-\" prefix. The function -also removes packages not necessary in Guix. - -When TEXLIVE-ONLY is true, only TeX Live packages are returned." +(define* (filter-depends depends #:optional texlive-only) + "Filter upstream package names DEPENDS to include only their equivalent Guix +package names, without \"texlive-\" prefix. When TEXLIVE-ONLY is true, ignore +Guix-specific packages." (delete-duplicates (filter-map (match-lambda ;; Hyphenation. Every TeX Live package is replaced with @@ -169,100 +375,88 @@ When TEXLIVE-ONLY is true, only TeX Live packages are returned." (name name)) depends))) -(define (tlpdb-file) - (define texlive-scripts - ;; Resolve this variable lazily so that (gnu packages ...) does not end up - ;; in the closure of this module. - (module-ref (resolve-interface '(gnu packages tex)) - 'texlive-scripts)) - - (with-store store - (run-with-store store - (mlet* %store-monad - ((drv (lower-object texlive-scripts)) - (built (built-derivations (list drv)))) - (match (derivation->output-paths drv) - (((names . items) ...) - (return (string-append (second items) ;"out" - "/share/tlpkg/texlive.tlpdb")))))))) - -(define tlpdb - (memoize - (lambda () - (let ((file (tlpdb-file)) - (fields - '((name . string) - (shortdesc . string) - (longdesc . string) - (catalogue . string) - (catalogue-license . string) - (catalogue-ctan . string) - (srcfiles . list) - (runfiles . list) - (docfiles . list) - (binfiles . list) - (depend . simple-list) - (execute . simple-list))) - (record - (lambda* (key value alist #:optional (type 'string)) - (let ((new - (or (and=> (assoc-ref alist key) - (lambda (existing) - (cond - ((eq? type 'string) - (string-append existing " " value)) - ((or (eq? type 'list) (eq? type 'simple-list)) - (cons value existing))))) - (cond - ((eq? type 'string) - value) - ((or (eq? type 'list) (eq? type 'simple-list)) - (list value)))))) - (acons key new (alist-delete key alist)))))) - (call-with-input-file file - (lambda (port) - (let loop ((all (list)) - (current (list)) - (last-property #false)) - (let ((line (read-line port))) - (cond - ((eof-object? line) all) - - ;; End of record. - ((string-null? line) - (loop (cons (cons (assoc-ref current 'name) current) - all) - (list) #false)) - - ;; Continuation of a list - ((and (zero? (string-index line #\space)) last-property) - ;; Erase optional second part of list values like - ;; "details=Readme" for files - (let ((plain-value (first - (string-split - (string-trim-both line) #\space)))) - (loop all (record last-property - plain-value - current - 'list) - last-property))) - (else - (or (and-let* ((space (string-index line #\space)) - (key (string->symbol (string-take line space))) - (value (string-drop line (1+ space))) - (field-type (assoc-ref fields key))) - ;; Erase second part of list keys like "size=29" +(define (tlpdb version) + "Return the TeX Live database associated to VERSION repository tag. The +function fetches the requested \"texlive.tlpdb\" file and parses it as +association list." + (let* ((fields + '((name . string) + (shortdesc . string) + (longdesc . string) + (catalogue . string) + (catalogue-license . string) + (catalogue-ctan . string) + (srcfiles . list) + (runfiles . list) + (docfiles . list) + (binfiles . list) + (depend . simple-list) + (execute . simple-list))) + (record + (lambda* (key value alist #:optional (type 'string)) + (let ((new + (or (and=> (assoc-ref alist key) + (lambda (existing) + (cond + ((eq? type 'string) + (string-append existing " " value)) + ((or (eq? type 'list) (eq? type 'simple-list)) + (cons value existing))))) (cond - ((eq? field-type 'list) - (loop all current key)) - (else - (loop all (record key value current field-type) key)))) - (loop all current #false)))))))))))) - -;; Packages listed below are used to build "latex-bin" package, and therefore -;; cannot provide it automatically as a native input. Consequently, the -;; importer sets TEXLIVE-LATEX-BIN? argument to #F for all of them. + ((eq? type 'string) + value) + ((or (eq? type 'list) (eq? type 'simple-list)) + (list value)))))) + (acons key new (alist-delete key alist))))) + (database-url + (string-append %texlive-repository "tags/texlive-" version + "/Master/tlpkg/texlive.tlpdb"))) + (call-with-input-string (svn-command "cat" database-url) + (lambda (port) + (let loop + ;; Store the SVN revision of the packages database. + ((all (list (cons 'database-revision (version->revision version)))) + (current (list)) + (last-property #false)) + (let ((line (read-line port))) + (cond + ;; End of file. Don't forget to include Guix-specific package. + ((eof-object? line) (values (append tlpdb-guix-packages all))) + + ;; End of record. + ((string-null? line) + (loop (cons (cons (assoc-ref current 'name) current) + all) + (list) + #false)) + ;; Continuation of a list + ((and (zero? (string-index line #\space)) last-property) + ;; Erase optional second part of list values like + ;; "details=Readme" for files + (let ((plain-value (first (string-split (string-trim-both line) + #\space)))) + (loop all + (record last-property plain-value current 'list) + last-property))) + (else + (or (and-let* ((space (string-index line #\space)) + (key (string->symbol (string-take line space))) + (value (string-drop line (1+ space))) + (field-type (assoc-ref fields key))) + ;; Erase second part of list keys like "size=29" + (cond + ((eq? field-type 'list) + (loop all current key)) + (else + (loop all (record key value current field-type) key)))) + (loop all current #false)))))))))) + +(define tlpdb/cached (memoize tlpdb)) + (define latex-bin-dependency-tree + ;; Return a list of packages used to build "latex-bin" package. Those + ;; cannot provide it as a native input. Consequently, the importer sets + ;; TEXLIVE-LATEX-BIN? argument to #F for all of them. (memoize (lambda (package-database) ;; Start out with "latex-bin", but also provide native inputs, which do @@ -271,10 +465,10 @@ When TEXLIVE-ONLY is true, only TeX Live packages are returned." (list "latex-bin" "metafont" "modes" "tex")) (deps '())) (if (null? packages) - ;; `translate-depends' will always translate "hyphen-base" into + ;; `filter-depends' will always translate "hyphen-base" into ;; "hyphen-complete". Make sure plain hyphen-base appears in the ;; dependency tree. - (cons "hyphen-base" (translate-depends deps)) + (cons "hyphen-base" (filter-depends deps)) (loop (append-map (lambda (name) (let ((data (assoc-ref package-database name))) (or (assoc-ref data 'depend) @@ -282,7 +476,7 @@ When TEXLIVE-ONLY is true, only TeX Live packages are returned." packages) (append packages deps))))))) -(define (formats package-data) +(define (list-formats package-data) "Return a list of formats to build according to PACKAGE-DATA." (and=> (assoc-ref package-data 'execute) (lambda (actions) @@ -296,71 +490,115 @@ When TEXLIVE-ONLY is true, only TeX Live packages are returned." ;; Get the right (alphabetic) order. (reverse actions)))))) -(define (linked-scripts name package-database) +(define (list-binfiles name package-database) + "Return the list of \"binfiles\", i.e., files meant to be installed in +\"bin/\" directory, for package NAME according to PACKAGE-DATABASE." + (or (and-let* ((data (assoc-ref package-database name)) + (depend (assoc-ref data 'depend)) + ((member (string-append name ".ARCH") depend)) + (bin-data (assoc-ref package-database + ;; Any *nix-like architecture will do. + (string-append name ".x86_64-linux")))) + (map basename (assoc-ref bin-data 'binfiles))) + '())) + +(define (list-linked-scripts name package-database) "Return a list of script names to symlink from \"bin/\" directory for package NAME according to PACKAGE-DATABASE. Consider as scripts files with -\".lua\", \".pl\", \".py\", \".rb\", \".sh\", \".tcl\", \".texlua\", \".tlu\" -extensions, and files without extension." - (and-let* ((data (assoc-ref package-database name)) - ;; Check if binaries are associated to the package. - (depend (assoc-ref data 'depend)) - ((member (string-append name ".ARCH") depend)) - ;; List those binaries. - (bin-data (assoc-ref package-database - ;; Any *nix-like architecture will do. - (string-append name ".x86_64-linux"))) - (binaries (map basename (assoc-ref bin-data 'binfiles))) - ;; List scripts candidates. Bail out if there are none. - (runfiles (assoc-ref data 'runfiles)) - (scripts (filter (cut string-prefix? "texmf-dist/scripts/" <>) - runfiles)) - ((pair? scripts))) - (filter-map (lambda (script) - (and (any (lambda (ext) - (member (basename script ext) binaries)) - '(".lua" ".pl" ".py" ".rb" ".sh" ".tcl" ".texlua" - ".tlu")) - (basename script))) - ;; Get the right (alphabetic) order. - (reverse scripts)))) - -(define* (files-differ? directory package-name - #:key - (package-database tlpdb) - (type #false) - (direction 'missing)) - "Return a list of files in DIRECTORY that differ from the expected installed -files for PACKAGE-NAME according to the PACKAGE-DATABASE. By default all -files considered, but this can be restricted by setting TYPE to 'runfiles, -'docfiles, or 'srcfiles. The names of files that are missing from DIRECTORY -are returned; by setting DIRECTION to anything other than 'missing, the names -of those files are returned that are unexpectedly installed." - (define (strip-directory-prefix file-name) - (string-drop file-name (1+ (string-length directory)))) - (let* ((data (or (assoc-ref (package-database) package-name) - (error (format #false - "~a is not a valid package name in the TeX Live package database." - package-name)))) - (files (if type - (or (assoc-ref data type) (list)) - (append (or (assoc-ref data 'runfiles) (list)) - (or (assoc-ref data 'docfiles) (list)) - (or (assoc-ref data 'srcfiles) (list))))) - (existing (file-system-fold - (const #true) ;enter? - (lambda (path stat result) (cons path result)) ;leaf - (lambda (path stat result) result) ;down - (lambda (path stat result) result) ;up - (lambda (path stat result) result) ;skip - (lambda (path stat errno result) result) ;error - (list) - directory))) - (if (eq? direction 'missing) - (lset-difference string=? - files (map strip-directory-prefix existing)) - ;; List files that are installed but should not be. - (lset-difference string=? - (map strip-directory-prefix existing) files)))) +\".lua\", \".pl\", \".py\", \".rb\", \".sh\", \".sno\", \".tcl\", \".texlua\", +\".tlu\" extensions, and files without extension." + (or (and-let* ((data (assoc-ref package-database name)) + ;; List scripts candidates. Bail out if there are none. + (runfiles (assoc-ref data 'runfiles)) + (scripts (filter (cut string-prefix? "texmf-dist/scripts/" <>) + runfiles)) + ((pair? scripts)) + (binfiles (list-binfiles name package-database))) + (filter-map (lambda (script) + (and (any (lambda (ext) + (member (basename script ext) binfiles)) + '(".lua" ".pl" ".py" ".rb" ".sh" ".sno" ".tcl" + ".texlua" ".tlu")) + (basename script))) + ;; Get the right (alphabetic) order. + (reverse scripts))) + '())) + +(define (list-upstream-inputs upstream-name version database) + "Return the list of <upstream-input> corresponding to all the dependencies +of package with UPSTREAM-NAME in VERSION." + (let ((package-data (assoc-ref database upstream-name)) + (scripts (list-linked-scripts upstream-name database))) + (append + ;; Native inputs. + ;; + ;; Texlive build system generates font metrics whenever a font metrics + ;; file has the same base name as a Metafont file. In this case, provide + ;; TEXLIVE-METAFONT. + (or (and-let* ((runfiles (assoc-ref package-data 'runfiles)) + (metrics + (filter-map (lambda (f) + (and (string-suffix? ".tfm" f) + (basename f ".tfm"))) + runfiles)) + ((not (null? metrics))) + ((any (lambda (f) + (and (string-suffix? ".mf" f) + (member (basename f ".mf") metrics))) + runfiles))) + (list (upstream-input + (name "metafont") + (downstream-name "texlive-metafont") + (type 'native)))) + '()) + ;; Regular inputs. + ;; + ;; Those may be required by scripts associated to the package. + (match (append-map (lambda (s) + (cond ((string-suffix? ".pl" s) '("perl")) + ((string-suffix? ".py" s) '("python")) + ((string-suffix? ".rb" s) '("ruby")) + ((string-suffix? ".tcl" s) '("tcl" "tk")) + (else '()))) + scripts) + (() '()) + (inputs (map (lambda (input-name) + (upstream-input + (name input-name) + (downstream-name input-name) + (type 'regular))) + (delete-duplicates inputs string=)))) + ;; Propagated inputs. + ;; + ;; Return the "depend" references given in the TeX Live database. Also + ;; check if the package has associated binaries built from + ;; TEXLIVE-SOURCE. In that case, add a Guix-specific NAME-bin propagated + ;; input. + (let ((binfiles (list-binfiles upstream-name database))) + (map (lambda (input-name) + (upstream-input + (name input-name) + (downstream-name (guix-name input-name)) + (type 'propagated))) + (sort (append + (filter-depends (or (assoc-ref package-data 'depend) '())) + ;; Check if propagation of binaries is necessary. It + ;; happens when binfiles outnumber the scripts, if any. + (if (and (> (length binfiles) (length scripts)) + (not (member upstream-name + no-bin-propagation-packages))) + ;; LIBKPATHSEA contains the executables for KPATHSEA. + ;; There is no KPATHSEA-BIN. + (list (if (equal? upstream-name "kpathsea") + "libkpathsea" + (string-append upstream-name "-bin"))) + '())) + string<?)))))) + +(define (upstream-inputs->texlive-inputs upstream-inputs type) + (map (compose string->symbol upstream-input-downstream-name) + (filter (upstream-input-type-predicate type) + upstream-inputs))) (define (files->locations files) (define (trim-filename entry) @@ -381,65 +619,104 @@ of those files are returned that are unexpectedly installed." (delete-duplicates (sort (map trim-filename specific) string<) string-prefix?)))) -(define (tlpdb->package name version package-database) - (and-let* ((data (assoc-ref package-database name)) - (locs (files->locations - (filter-map (lambda (file) - ;; Ignore any file not starting with the - ;; expected prefix. Nothing good can come - ;; from this. - (and (string-prefix? "texmf-dist/" file) - (string-drop file (string-length "texmf-dist/")))) - (append (or (assoc-ref data 'docfiles) (list)) - (or (assoc-ref data 'runfiles) (list)) - (or (assoc-ref data 'srcfiles) (list)))))) - (texlive-name name) - (name (guix-name name)) - ;; TODO: we're ignoring the VERSION argument because that - ;; information is distributed across %texlive-tag and - ;; %texlive-revision. - (ref (svn-multi-reference - (url (string-append "svn://www.tug.org/texlive/tags/" - %texlive-tag "/Master/texmf-dist")) - (locations locs) - (revision %texlive-revision))) - ;; Ignore arch-dependent packages. - (depends (or (assoc-ref data 'depend) '())) +(define (texlive->svn-multi-reference upstream-name version database) + "Return <svn-multi-reference> object for TeX Live package with UPSTREAM-NAME +at VERSION." + (let* ((data (assoc-ref database upstream-name)) + (files (append (or (assoc-ref data 'docfiles) (list)) + (or (assoc-ref data 'runfiles) (list)) + (or (assoc-ref data 'srcfiles) (list)))) + (locations + ;; Drop "texmf-dist/" prefix from files. Special case + ;; TEXLIVE-SCRIPTS and TEXLIVE-SOURCE, where files are not always + ;; exported from "texmf-dist/". + (if (member upstream-name '("scripts" "source")) + files + (files->locations + ;; Ignore any file not starting with the expected prefix, such + ;; as tlpkg/tlpostcode/... Nothing good can come from this. + (filter-map + (lambda (file) + (and (string-prefix? "texmf-dist/" file) + (string-drop file (string-length "texmf-dist/")))) + files))))) + (svn-multi-reference + (url (match upstream-name + ("scripts" + (string-append + %texlive-repository "tags/texlive-" version "/Master")) + ("source" + (string-append %texlive-repository + "tags/texlive-" version "/Build/source")) + (_ + (texlive-packages-repository version)))) + (locations (sort locations string<)) + (revision (assoc-ref database 'database-revision))))) + +(define (tlpdb->package upstream-name version database) + (and-let* ((data (assoc-ref database upstream-name)) + (name (guix-name upstream-name)) + (reference + (texlive->svn-multi-reference upstream-name version database)) (source (with-store store (download-multi-svn-to-store - store ref (string-append name "-svn-multi-checkout"))))) - (let* ((scripts (linked-scripts texlive-name package-database)) - (tex-formats (formats data)) - (meta-package? (null? locs)) + store reference + (format #f "~a-~a-svn-multi-checkout" name version))))) + (let* ((scripts (list-linked-scripts upstream-name database)) + (upstream-inputs + (list-upstream-inputs upstream-name version database)) + (tex-formats (list-formats data)) + (meta-package? (null? (svn-multi-reference-locations reference))) (empty-package? (and meta-package? (not (pair? tex-formats))))) (values `(package (name ,name) - (version (number->string %texlive-revision)) - (source ,(and (not meta-package?) - `(texlive-origin - name version - (list ,@(sort locs string<)) - (base32 - ,(bytevector->nix-base32-string - (let-values (((port get-hash) (open-sha256-port))) - (write-file source port) - (force-output port) - (get-hash))))))) + (version ,(if empty-package? '%texlive-version version)) + (source + ,(and (not meta-package?) + `(origin + (method svn-multi-fetch) + (uri (svn-multi-reference + (url + ,(match upstream-name + ("scripts" + '(string-append + %texlive-repository "tags/texlive-" version + "/Master")) + ("source" + '(string-append + %texlive-repository "tags/texlive-" version + "/Build/source")) + (_ + '(texlive-packages-repository version)))) + (revision ,(svn-multi-reference-revision reference)) + (locations + (list ,@(svn-multi-reference-locations reference))))) + (file-name (git-file-name name version)) + (sha256 + (base32 + ,(bytevector->nix-base32-string + (let-values (((port get-hash) (open-sha256-port))) + (write-file source port) + (force-output port) + (get-hash)))))))) ,@(if (assoc-ref data 'docfiles) '((outputs '("out" "doc"))) '()) - ;; Set build-system. + ,@(if (string= upstream-name + (string-drop name (string-length "texlive-"))) + '() + `((properties '((upstream-name . ,upstream-name))))) + ;; Build system. ;; ;; Use trivial build system only when the package contains no files, ;; and no TeX format file is expected to be built. (build-system ,(if empty-package? 'trivial-build-system 'texlive-build-system)) - ;; Generate arguments field. + ;; Arguments. ,@(let* ((latex-bin-dependency? - (member texlive-name - (latex-bin-dependency-tree package-database))) + (member upstream-name (latex-bin-dependency-tree database))) (arguments (append (if empty-package? '(#:builder #~(mkdir #$output)) @@ -456,41 +733,17 @@ of those files are returned that are unexpectedly installed." (if (pair? arguments) `((arguments (list ,@arguments))) '())) - ;; Native inputs. - ;; - ;; Texlive build system generates font metrics whenever a font - ;; metrics file has the same base name as a Metafont file. In this - ;; case, provide `texlive-metafont'. - ,@(or (and-let* ((runfiles (assoc-ref data 'runfiles)) - (metrics - (filter-map (lambda (f) - (and (string-suffix? ".tfm" f) - (basename f ".tfm"))) - runfiles)) - ((not (null? metrics))) - ((any (lambda (f) - (and (string-suffix? ".mf" f) - (member (basename f ".mf") metrics))) - runfiles))) - '((native-inputs (list texlive-metafont)))) - '()) ;; Inputs. - ,@(match (append-map (lambda (s) - (cond ((string-suffix? ".pl" s) '(perl)) - ((string-suffix? ".py" s) '(python)) - ((string-suffix? ".rb" s) '(ruby)) - ((string-suffix? ".tcl" s) '(tcl tk)) - (else '()))) - (or scripts '())) + ,@(match (upstream-inputs->texlive-inputs upstream-inputs 'native) + (() '()) + (inputs `((native-inputs (list ,@inputs))))) + ,@(match (upstream-inputs->texlive-inputs upstream-inputs 'regular) (() '()) - (inputs `((inputs (list ,@(delete-duplicates inputs eq?)))))) - ;; Propagated inputs. - ,@(match (translate-depends depends) + (inputs `((inputs (list ,@inputs))))) + ,@(match (upstream-inputs->texlive-inputs upstream-inputs 'propagated) (() '()) - (inputs - `((propagated-inputs - (list ,@(map (compose string->symbol guix-name) - (sort inputs string<?))))))) + (inputs `((propagated-inputs (list ,@inputs))))) + ;; Home page, synopsis, description and license. (home-page ,(cond (meta-package? "https://www.tug.org/texlive/") @@ -505,17 +758,18 @@ of those files are returned that are unexpectedly installed." '(fsf-free "https://www.tug.org/texlive/copying.html")) ((assoc-ref data 'catalogue-license) => string->license) (else #f)))) - (translate-depends depends #t))))) + ;; List of pure TeX Live dependencies for recursive calls. + (filter-depends (or (assoc-ref data 'depend) '()) #t))))) (define texlive->guix-package - (memoize - (lambda* (name #:key - (version (number->string %texlive-revision)) - (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))))) + (lambda* (name #:key version database #:allow-other-keys) + "Find the metadata for NAME in the TeX Live database and return the +associated Guix package, or #f on failure. Fetch metadata for a specific +version whenever VERSION keyword is specified. Otherwise, grab package latest +release. When DATABASE is provided, fetch metadata from there, ignoring +VERSION." + (let ((version (or version (latest-texlive-tag)))) + (tlpdb->package name version (or database (tlpdb/cached version)))))) (define* (texlive-recursive-import name #:key repo version) (recursive-import name @@ -524,4 +778,40 @@ s-expression corresponding to that package, or #f on failure." #:repo->guix-package texlive->guix-package #:guix-name guix-name)) +;;; +;;; Updates. +;;; + +(define (package-from-texlive-repository? package) + (let ((name (package-name package))) + ;; TEXLIVE-SCRIPTS and TEXLIVE-SOURCE do not use TEXLIVE-BUILD-SYSTEM, but + ;; package's structure is sufficiently regular to benefit from + ;; auto-updates. + (or (member name '("texlive-scripts" "texlive-source")) + (and (string-prefix? "texlive-" (package-name package)) + (eq? 'texlive + (build-system-name (package-build-system package))))))) + +(define* (latest-release package #:key version) + "Return an <upstream-source> for the latest release of PACKAGE. Optionally +include a VERSION string to fetch a specific version." + (let* ((version (or version (latest-texlive-tag))) + (database (tlpdb/cached version)) + (upstream-name (package-upstream-name* package))) + (and (assoc-ref database upstream-name) + (upstream-source + (package upstream-name) + (version version) + (urls (texlive->svn-multi-reference upstream-name version database)) + (inputs (list-upstream-inputs upstream-name version database)))))) + +(define %texlive-updater + ;; The TeX Live updater. It is restricted to TeX Live releases (2023.0, + ;; 2024.2, ...); it doesn't include revision bumps for individual packages. + (upstream-updater + (name 'texlive) + (description "Updater for TeX Live packages") + (pred package-from-texlive-repository?) + (import latest-release))) + ;;; texlive.scm ends here diff --git a/guix/import/utils.scm b/guix/import/utils.scm index 09a01cf315..e45c8dfb20 100644 --- a/guix/import/utils.scm +++ b/guix/import/utils.scm @@ -2,7 +2,7 @@ ;;; 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, 2023 Ricardo Wurmus <rekado@elephly.net> +;;; Copyright © 2017, 2019, 2020, 2022, 2023, 2024 Ricardo Wurmus <rekado@elephly.net> ;;; Copyright © 2018 Oleg Pykhalov <go.wigust@gmail.com> ;;; Copyright © 2019 Robert Vollmert <rob@vllmrt.net> ;;; Copyright © 2020 Helio Machado <0x2b3bfa0+guix@googlemail.com> @@ -183,6 +183,7 @@ thrown." ("Apache-1.1" . license:asl1.1) ("Apache-2.0" . license:asl2.0) ("APSL-2.0" . license:apsl2) + ("BlueOak-1.0.0" . license:blue-oak1.0.0) ("BSL-1.0" . license:boost1.0) ("0BSD" . license:bsd-0) ("BSD-2-Clause" . license:bsd-2) @@ -316,9 +317,12 @@ object is bound to in the (guix licenses) module, such as 'license:gpl3+, or (assoc-ref licenses license)) (define (snake-case str) - "Return a downcased version of the string STR where underscores are replaced -with dashes." - (string-join (string-split (string-downcase str) #\_) "-")) + "Return a downcased version of the string STR where underscores and periods +are replaced with dashes." + (string-map (match-lambda + ((or #\_ #\.) #\-) + (chr chr)) + (string-downcase str))) (define* (beautify-description description #:optional (length 80)) "Improve the package DESCRIPTION by turning a beginning sentence fragment into @@ -337,15 +341,21 @@ LENGTH characters." ;; Escape single @ to prevent it from being understood as ;; invalid Texinfo syntax. (cut regexp-substitute/global #f "@" <> 'pre "@@" 'post) - ;; Wrap camelCase or PascalCase words in @code{...}. + ;; Wrap camelCase or PascalCase words or text followed + ;; immediately by "()" in @code{...}. (lambda (word) - (let ((pattern (make-regexp "([A-Z][a-z]+[A-Z]|[a-z]+[A-Z])"))) + (let ((pattern + (make-regexp + "([A-Z][a-z]+[A-Z]|[a-z]+[A-Z]|.+\\(\\))"))) (match (list-matches pattern word) (() word) ((m . rest) - ;; Do not include leading or trailing punctuation. - (let* ((last-text (or (and=> (string-skip-right word char-set:punctuation) 1+) - (string-length word))) + ;; Do not include leading or trailing punctuation, + ;; unless its "()". + (let* ((last-text (if (string-suffix? "()" (match:substring m 1)) + (string-length (match:substring m 1)) + (or (and=> (string-skip-right word char-set:punctuation) 1+) + (string-length word)))) (inner (substring word (match:start m) last-text)) (pre (string-take word (match:start m))) (post (substring word last-text (string-length word)))) @@ -370,6 +380,15 @@ LENGTH characters." (cons* "This" "package" (string-downcase first) rest)) (_ words))) + (new-words + (match new-words + ((rest ... last) + (reverse (cons (if (or (string-suffix? "." last) + (string-suffix? "!" last) + (string-suffix? "?" last)) + last + (string-append last ".")) + (reverse rest)))))) (cleaned (string-join (map fix-word new-words)))) ;; Use double spacing between sentences @@ -409,12 +428,10 @@ LENGTH characters." optional OUTPUT, tries to generate a quoted list of inputs, as suitable to use in an 'inputs' field of a package definition." (define (make-input input version) - (cons* input (list 'unquote (string->symbol - (if version - (string-append input "-" version) - input))) - (or (and output (list output)) - '()))) + (let ((name (if version (string-append input "-" version) input))) + (if output + (list (string->symbol name) output) + (string->symbol name)))) (map (match-lambda ((input version) (make-input input version)) @@ -435,7 +452,7 @@ snippet generated is for regular inputs." (() '()) ((package-inputs ...) - `((,field-name (,'quasiquote ,package-inputs))))))) + `((,field-name (list ,@package-inputs))))))) (define* (maybe-native-inputs package-names #:optional (output #f)) "Same as MAYBE-INPUTS, but for native inputs." diff --git a/guix/inferior.scm b/guix/inferior.scm index 190ba01b3c..b60bf1ab01 100644 --- a/guix/inferior.scm +++ b/guix/inferior.scm @@ -253,7 +253,8 @@ inferior." result) (inferior-eval '(begin (define %store-table (make-hash-table)) - (define (cached-store-connection store-id version) + (define (cached-store-connection store-id version + built-in-builders) ;; Cache connections to store ID. This ensures that ;; the caches within <store-connection> (in ;; particular the object cache) are reused across @@ -268,9 +269,19 @@ inferior." ;; risk of talking to the wrong daemon or having ;; our build result reclaimed (XXX). (let ((store (if (defined? 'port->connection) - (port->connection %bridge-socket - #:version - version) + ;; #:built-in-builders was + ;; added in 2024 + (catch 'keyword-argument-error + (lambda () + (port->connection %bridge-socket + #:version + version + #:built-in-builders + built-in-builders)) + (lambda _ + (port->connection %bridge-socket + #:version + version))) (open-connection)))) (hashv-set! %store-table store-id store) store)))) @@ -690,11 +701,13 @@ thus be the code of a one-argument procedure that accepts a store." ;; The address of STORE itself is not a good identifier because it ;; keeps changing through the use of "functional caches". The ;; address of its socket port makes more sense. - (store-id (object-address (store-connection-socket store)))) + (store-id (object-address (store-connection-socket store))) + (store-built-in-builders (built-in-builders store))) (ensure-store-bridge! inferior) (send-inferior-request `(let ((proc ,code) - (store (cached-store-connection ,store-id ,proto))) + (store (cached-store-connection ,store-id ,proto + ',store-built-in-builders))) ;; Serialize '&store-protocol-error' conditions. The exception ;; serialization mechanism that 'read-repl-response' expects is ;; unsuitable for SRFI-35 error conditions, hence this special case. diff --git a/guix/licenses.scm b/guix/licenses.scm index d200614d91..8fd4f36392 100644 --- a/guix/licenses.scm +++ b/guix/licenses.scm @@ -44,6 +44,7 @@ apsl2 arphic-1999 asl1.1 asl2.0 + blue-oak1.0.0 boost1.0 bsd-0 bsd-1 bsd-2 bsd-3 bsd-4 non-copyleft @@ -216,6 +217,11 @@ cases, reduces to #t at macro-expansion time." "http://directory.fsf.org/wiki/License:Apache2.0" "https://www.gnu.org/licenses/license-list#apache2")) +(define blue-oak1.0.0 + (license "BlueOak-1.0.0" + "https://blueoakcouncil.org/license/1.0.0" + "https://opensource.org/license/blue-oak-model-license")) + (define boost1.0 (license "Boost 1.0" "http://directory.fsf.org/wiki/License:Boost1.0" diff --git a/guix/lint.scm b/guix/lint.scm index 68d532968d..059ee6894d 100644 --- a/guix/lint.scm +++ b/guix/lint.scm @@ -7,13 +7,14 @@ ;;; Copyright © 2016 Hartmut Goebel <h.goebel@crazy-compilers.com> ;;; Copyright © 2017 Alex Kost <alezost@gmail.com> ;;; Copyright © 2017, 2021 Tobias Geerinckx-Rice <me@tobias.gr> -;;; Copyright © 2017, 2018, 2020 Efraim Flashner <efraim@flashner.co.il> +;;; Copyright © 2017, 2018, 2020, 2024 Efraim Flashner <efraim@flashner.co.il> ;;; Copyright © 2018, 2019 Arun Isaac <arunisaac@systemreboot.net> ;;; Copyright © 2020 Chris Marusich <cmmarusich@gmail.com> ;;; Copyright © 2020 Timothy Sample <samplet@ngyro.com> ;;; Copyright © 2021 Xinglu Chen <public@yoctocell.xyz> ;;; Copyright © 2021-2023 Maxime Devos <maximedevos@telenet.be> ;;; Copyright © 2021 Brice Waegeneire <brice@waegenei.re> +;;; Copyright © 2024 Gabriel Wicki <gabriel@erlikon.ch> ;;; ;;; This file is part of GNU Guix. ;;; @@ -96,6 +97,7 @@ #:export (check-description-style check-inputs-should-be-native check-inputs-should-not-be-an-input-at-all + check-inputs-should-use-a-minimal-variant check-input-labels check-wrapper-inputs check-patch-file-names @@ -368,6 +370,12 @@ superfluous when building natively and incorrect when cross-compiling." (define (properly-starts-sentence? s) (string-match "^[(\"'`[:upper:][:digit:]]" s)) +(define %starts-with-texinfo-markup-rx + (make-regexp "^@(acronym|dfn|code|command|emph|file|quotation|samp|uref|url)\\{.*?\\}")) + +(define (starts-with-texinfo-markup? s) + (regexp-exec %starts-with-texinfo-markup-rx s)) + (define (starts-with-abbreviation? s) "Return #t if S starts with what looks like an abbreviation or acronym." (string-match "^[A-Z][A-Z0-9]+\\>" s)) @@ -436,15 +444,24 @@ trademark sign '~a' at ~d") '())) (define (check-proper-start description) - (if (or (string-null? description) - (properly-starts-sentence? description) - (string-prefix-ci? (package-name package) description)) - '() - (list - (make-warning - package - (G_ "description should start with an upper-case letter or digit") - #:field 'description)))) + (let* ((initial + (string-take description + (or (string-index description #\space) + 0))) + (first-word + (regexp-substitute/global #f "_" initial + 'pre "-" 'post))) + (if (or (string-null? description) + (properly-starts-sentence? description) + (starts-with-texinfo-markup? description) + (string-prefix-ci? first-word (package-name package)) + (string-suffix-ci? first-word (package-name package))) + '() + (list + (make-warning + package + (G_ "description should start with an upper-case letter or digit") + #:field 'description))))) (define (check-end-of-sentence-space description) "Check that an end-of-sentence period is followed by two spaces." @@ -452,11 +469,16 @@ trademark sign '~a' at ~d") (reverse (fold-matches "\\. [A-Z]" description '() (lambda (m r) - ;; Filter out matches of common abbreviations. - (if (find (lambda (s) - (string-suffix-ci? s (match:prefix m))) - '("i.e" "e.g" "a.k.a" "resp")) - r (cons (match:start m) r))))))) + ;; Filter out matches of common abbreviations and + ;; initials. + (let ((pre (match:prefix m))) + (if (or + (string-match "[A-Z]$" pre) ;; Initial found + (find (lambda (s) + (string-suffix-ci? s pre)) + '("i.e" "e.g" "a.k.a" "resp" "cf" "al"))) + r + (cons (match:start m) r)))))))) (if (null? infractions) '() (list @@ -493,8 +515,8 @@ by two spaces; possible infraction~p at ~{~a~^, ~}") (check-trademarks description) (check-description-typo description '(("This packages" . "This package") ("This modules" . "This module") - ("allows to" . #f) - ("permits to" . #f))) + ("allows to " . #f) + ("permits to " . #f))) ;; Use raw description for this because Texinfo rendering ;; automatically fixes end of sentence space. (check-end-of-sentence-space description) @@ -503,7 +525,9 @@ by two spaces; possible infraction~p at ~{~a~^, ~}") (match (check-texinfo-markup description) ((and warning (? lint-warning?)) (list warning)) (plain-description - (check-proper-start plain-description)))) + (if (string-prefix? "@" description) + '() + (check-proper-start plain-description))))) (list (make-warning package (G_ "invalid description: ~s") @@ -598,6 +622,21 @@ of a package, and INPUT-NAMES, a list of package specifications such as (package-input-intersection (package-direct-inputs package) input-names)))) +(define (check-inputs-should-use-a-minimal-variant package) + ;; Emit a warning if some inputs of PACKAGE should likely be replaced + ;; with their minimal variant. + (let ((input-names '("bash" + "cmake" + "gettext"))) + (map (lambda (input) + (make-warning + package + (G_ "'~a' should probably switched for its minimal variant") + (list input) + #:field 'inputs)) + (package-input-intersection (package-direct-inputs package) + input-names)))) + (define (check-input-labels package) "Emit a warning for labels that differ from the corresponding package name." (define (check input-kind package-inputs) @@ -712,7 +751,8 @@ the synopsis") '())) (define (check-proper-start synopsis) - (if (properly-starts-sentence? synopsis) + (if (or (properly-starts-sentence? synopsis) + (starts-with-texinfo-markup? synopsis)) '() (list (make-warning package @@ -721,7 +761,7 @@ the synopsis") (define (check-start-with-package-name synopsis) (if (and (regexp-exec (package-name-regexp package) synopsis) - (not (starts-with-abbreviation? synopsis))) + (not (starts-with-abbreviation? synopsis))) (list (make-warning package (G_ "synopsis should not start with the package name") @@ -1971,10 +2011,6 @@ them for PACKAGE." (description "Validate package descriptions") (check check-description-style)) (lint-checker - (name 'synopsis) - (description "Validate package synopses") - (check check-synopsis-style)) - (lint-checker (name 'inputs-should-be-native) (description "Identify inputs that should be native inputs") (check check-inputs-should-be-native)) @@ -1983,6 +2019,10 @@ them for PACKAGE." (description "Identify inputs that shouldn't be inputs at all") (check check-inputs-should-not-be-an-input-at-all)) (lint-checker + (name 'inputs-should-be-minimal) + (description "Identify inputs that should use their minimal variant") + (check check-inputs-should-use-a-minimal-variant)) + (lint-checker (name 'input-labels) (description "Identify input labels that do not match package names") (check check-input-labels)) @@ -2038,7 +2078,10 @@ or a list thereof") (define %network-dependent-checkers (list - + (lint-checker + (name 'synopsis) + (description "Validate package synopses") + (check check-synopsis-style)) (lint-checker (name 'gnu-description) (description "Validate synopsis & description of GNU packages") diff --git a/guix/man-db.scm b/guix/man-db.scm index 7d9707a592..bba90ed473 100644 --- a/guix/man-db.scm +++ b/guix/man-db.scm @@ -1,5 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2017, 2018 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2022, 2024 Maxim Cournoyer <maxim.cournoyer@gmail.com> ;;; ;;; This file is part of GNU Guix. ;;; @@ -17,7 +18,8 @@ ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. (define-module (guix man-db) - #:use-module (zlib) + #:autoload (zlib) (call-with-gzip-input-port) + #:autoload (zstd) (call-with-zstd-input-port) #:use-module ((guix build utils) #:select (find-files)) #:use-module (gdbm) ;gdbm-ffi #:use-module (srfi srfi-9) @@ -48,7 +50,7 @@ (define-record-type <mandb-entry> (mandb-entry file-name name section synopsis kind) mandb-entry? - (file-name mandb-entry-file-name) ;e.g., "../abiword.1.gz" + (file-name mandb-entry-file-name) ;e.g., "../abiword.1.zst" (name mandb-entry-name) ;e.g., "ABIWORD" (section mandb-entry-section) ;number (synopsis mandb-entry-synopsis) ;string @@ -63,7 +65,7 @@ (string<? (basename file1) (basename file2)))))))) (define abbreviate-file-name - (let ((man-file-rx (make-regexp "(.+)\\.[0-9][a-z]?(\\.gz)?$"))) + (let ((man-file-rx (make-regexp "(.+)\\.[0-9][a-z]?(\\.(gz|zst))?$"))) (lambda (file) (match (regexp-exec man-file-rx (basename file)) (#f @@ -71,6 +73,14 @@ (matches (match:substring matches 1)))))) +(define (gzip-compressed? file-name) + "True if FILE-NAME is suffixed with the '.gz' file extension." + (string-suffix? ".gz" file-name)) + +(define (zstd-compressed? file-name) + "True if FILE-NAME is suffixed with the '.zst' file extension." + (string-suffix? ".zst" file-name)) + (define (entry->string entry) "Return the wire format for ENTRY as a string." (match entry @@ -92,7 +102,11 @@ "\t-\t-\t" - (if (string-suffix? ".gz" file) "gz" "") + (cond + ((gzip-compressed? file) "gz") + ((zstd-compressed? file) "zst") + (else "")) + "\t" synopsis "\x00")))) @@ -148,7 +162,8 @@ (loop (cons line lines)))))) (define* (man-page->entry file #:optional (resolve identity)) - "Parse FILE, a gzipped man page, and return a <mandb-entry> for it." + "Parse FILE, a gzip or zstd compressed man page, and return a <mandb-entry> +for it." (define (string->number* str) (if (and (string-prefix? "\"" str) (> (string-length str) 1) @@ -156,8 +171,13 @@ (string->number (string-drop (string-drop-right str 1) 1)) (string->number str))) - ;; Note: This works for both gzipped and uncompressed files. - (call-with-gzip-input-port (open-file file "r0") + (define call-with-input-port* + (cond + ((gzip-compressed? file) call-with-gzip-input-port) + ((zstd-compressed? file) call-with-zstd-input-port) + (else call-with-port))) + + (call-with-input-port* (open-file file "r0") (lambda (port) (let loop ((name #f) (section #f) @@ -191,14 +211,18 @@ (define (man-files directory) "Return the list of man pages found under DIRECTORY, recursively." ;; Filter the list to ensure that broken symlinks are excluded. - (filter file-exists? (find-files directory "\\.[0-9][a-z]?(\\.gz)?$"))) + (filter file-exists? + (find-files directory "\\.[0-9][a-z]?(\\.(gz|zst))?$"))) (define (mandb-entries directory) "Return mandb entries for the man pages found under DIRECTORY, recursively." (map (lambda (file) (man-page->entry file (lambda (link) - (let ((file (string-append directory "/" link - ".gz"))) - (and (file-exists? file) file))))) + (let ((file-gz (string-append directory "/" link + ".gz")) + (file-zst (string-append directory "/" link + ".zst"))) + (or (and (file-exists? file-gz) file-gz) + (and (file-exists? file-zst) file-zst)))))) (man-files directory))) diff --git a/guix/modules.scm b/guix/modules.scm index 77e1c2b6f4..74400ffacc 100644 --- a/guix/modules.scm +++ b/guix/modules.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2016-2019, 2021-2022 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2016-2019, 2021-2022, 2024 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -104,7 +104,9 @@ depends on." (lambda (file) "Return the module name (a list of symbols) corresponding to FILE." (map string->symbol - (string-tokenize (string-drop-right file 4) not-slash))))) + (match (string-tokenize (string-drop-right file 4) not-slash) + (("." . rest) rest) ;strip the leading "." + (lst lst)))))) (define (module-name->file-name module) "Return the file name for MODULE." diff --git a/guix/packages.scm b/guix/packages.scm index abe89cdb07..84f2c6f838 100644 --- a/guix/packages.scm +++ b/guix/packages.scm @@ -5,11 +5,12 @@ ;;; Copyright © 2016 Alex Kost <alezost@gmail.com> ;;; Copyright © 2017, 2019, 2020, 2022 Efraim Flashner <efraim@flashner.co.il> ;;; Copyright © 2019 Marius Bakke <mbakke@fastmail.com> -;;; Copyright © 2020, 2021 Maxim Cournoyer <maxim.cournoyer@gmail.com> +;;; Copyright © 2020, 2021, 2024 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> ;;; Copyright © 2023 Simon Tournier <zimon.toutoune@gmail.com> +;;; Copyright © 2024 Janneke Nieuwenhuizen <janneke@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -160,6 +161,11 @@ %cuirass-supported-systems supported-package? + &unsupported-cross-compilation-target-error + unsupported-cross-compilation-target-error? + unsupported-cross-compilation-target-error-build-system + unsupported-cross-compilation-target-error-target + &package-error package-error? package-error-package @@ -173,6 +179,9 @@ package-error-invalid-input &package-cross-build-system-error package-cross-build-system-error? + &package-unsupported-target-error + package-unsupported-target-error? + package-unsupported-target-error-target package->bag bag->derivation @@ -411,7 +420,7 @@ from forcing GEXP-PROMISE." (define %64bit-supported-systems ;; This is the list of 64-bit system types that are supported. '("x86_64-linux" "mips64el-linux" "aarch64-linux" "powerpc64le-linux" - "riscv64-linux")) + "riscv64-linux" "x86_64-gnu")) (define %supported-systems ;; This is the list of system types that are supported. By default, we @@ -420,14 +429,15 @@ from forcing GEXP-PROMISE." (define %hurd-systems ;; The GNU/Hurd systems for which support is being developed. - '("i586-gnu")) + '("i586-gnu" "x86_64-gnu")) (define %cuirass-supported-systems ;; This is the list of system types for which build machines are available. ;; ;; XXX: MIPS is unavailable in CI: ;; <https://lists.gnu.org/archive/html/guix-devel/2017-03/msg00790.html>. - (fold delete %supported-systems '("mips64el-linux" "powerpc-linux" "riscv64-linux"))) + (fold delete %supported-systems '("mips64el-linux" "powerpc-linux" + "riscv64-linux" "x86_64-gnu"))) (define (maybe-add-input-labels inputs) "Add labels to INPUTS unless it already has them." @@ -668,6 +678,9 @@ Texinfo. Otherwise, return the string." "_") ,obj ,@(if (string=? output "out") '() (list output))))) + ((? origin? origin) + ;; Allow references to origins by their file name. + (list (or (origin-actual-file-name origin) "_") origin)) (x `("_" ,x)))) @@ -831,6 +844,11 @@ exist, return #f instead." ;; Error conditions. +(define-condition-type &unsupported-cross-compilation-target-error &error + unsupported-cross-compilation-target-error? + (build-system unsupported-cross-compilation-target-error-build-system) + (target unsupported-cross-compilation-target-error-target)) + (define-condition-type &package-error &error package-error? (package package-error-package)) @@ -850,6 +868,10 @@ exist, return #f instead." (define-condition-type &package-cross-build-system-error &package-error package-cross-build-system-error?) +(define-condition-type &package-unsupported-target-error &package-error + package-unsupported-target-error? + (target package-unsupported-target-error-target)) + (define* (package-full-name package #:optional (delimiter "@")) "Return the full name of PACKAGE--i.e., `NAME@VERSION'. By specifying DELIMITER (a string), you can customize what will appear between the name and @@ -895,17 +917,12 @@ identifiers. The result is inferred from the file names of patches." (module-ref (resolve-interface module) var)))))) `(("tar" ,(ref '(gnu packages base) 'tar)) ("xz" ,(ref '(gnu packages compression) 'xz)) + ("zstd" ,(ref '(gnu packages compression) 'zstd)) ("bzip2" ,(ref '(gnu packages compression) 'bzip2)) ("gzip" ,(ref '(gnu packages compression) 'gzip)) ("lzip" ,(ref '(gnu packages compression) 'lzip)) ("unzip" ,(ref '(gnu packages compression) 'unzip)) - ("patch" ,(ref '(gnu packages base) 'patch)) - ("locales" - ,(parameterize ((%current-target-system #f) - (%current-system system)) - (canonical - ((module-ref (resolve-interface '(gnu packages base)) - 'libc-utf8-locales-for-target)))))))) + ("patch" ,(ref '(gnu packages base) 'patch/pinned))))) (define (default-guile) "Return the default Guile package used to run the build code of @@ -915,10 +932,8 @@ derivations." (define (guile-for-grafts) "Return the Guile package used to build grafting derivations." - ;; Guile 2.2 would not work due to <https://bugs.gnu.org/28211> when - ;; grafting packages. - (let ((distro (resolve-interface '(gnu packages guile)))) - (module-ref distro 'guile-2.0))) + (let ((distro (resolve-interface '(gnu packages commencement)))) + (module-ref distro 'guile-final))) (define* (default-guile-derivation #:optional (system (%current-system))) "Return the derivation for SYSTEM of the default Guile package used to run @@ -965,32 +980,32 @@ specifies modules in scope when evaluating SNIPPET." ;; Return true if DIRECTORY is a checkout (git, svn, etc). (string-suffix? "-checkout" directory)) - (define (tarxz-name file-name) - ;; Return a '.tar.xz' file name based on FILE-NAME. + (define (tar-file-name file-name ext) + ;; Return a '$filename.tar.$ext' file name based on FILE-NAME and EXT. (let ((base (if (numeric-extension? file-name) original-file-name (file-sans-extension file-name)))) (string-append base (if (equal? (file-extension base) "tar") - ".xz" - ".tar.xz")))) + (string-append "." ext) + (string-append ".tar." ext))))) (define instantiate-patch (match-lambda - ((? string? patch) ;deprecated + ((? string? patch) ;deprecated (local-file patch #:recursive? #t)) - ((? struct? patch) ;origin, local-file, etc. + ((? struct? patch) ;origin, local-file, etc. patch))) - (let ((tar (lookup-input "tar")) - (gzip (lookup-input "gzip")) - (bzip2 (lookup-input "bzip2")) - (lzip (lookup-input "lzip")) - (xz (lookup-input "xz")) - (patch (lookup-input "patch")) - (locales (lookup-input "locales")) - (comp (and=> (compressor source-file-name) lookup-input)) - (patches (map instantiate-patch patches))) + (let* ((tar (lookup-input "tar")) + (gzip (lookup-input "gzip")) + (bzip2 (lookup-input "bzip2")) + (lzip (lookup-input "lzip")) + (xz (lookup-input "xz")) + (zstd (lookup-input "zstd")) + (patch (lookup-input "patch")) + (comp (and=> (compressor source-file-name) lookup-input)) + (patches (map instantiate-patch patches))) (define build (with-imported-modules '((guix build utils)) #~(begin @@ -999,14 +1014,18 @@ specifies modules in scope when evaluating SNIPPET." (ice-9 regex) (srfi srfi-1) (srfi srfi-26) + (srfi srfi-34) + (srfi srfi-35) (guix build utils)) ;; The --sort option was added to GNU tar in version 1.28, released ;; 2014-07-28. During bootstrap we must cope with older versions. (define tar-supports-sort? - (zero? (system* (string-append #+tar "/bin/tar") + (guard (c ((message-condition? c) #f)) + (invoke/quiet (string-append #+tar "/bin/tar") "cf" "/dev/null" "--files-from=/dev/null" - "--sort=name"))) + "--sort=name") + #t)) (define (apply-patch patch) (format (current-error-port) "applying '~a'...~%" patch) @@ -1047,26 +1066,36 @@ specifies modules in scope when evaluating SNIPPET." '("--no-recursion" "--files-from=.file_list")))) + (let ((line (cond-expand (guile-2.0 _IOLBF) + (else 'line)))) + (setvbuf (current-output-port) line) + (setvbuf (current-error-port) line)) + ;; Encoding/decoding errors shouldn't be silent. (fluid-set! %default-port-conversion-strategy 'error) - (when #+locales - ;; First of all, install a UTF-8 locale so that UTF-8 file names - ;; are correctly interpreted. During bootstrap, LOCALES is #f. - (setenv "LOCPATH" - (string-append #+locales "/lib/locale/" - #+(and locales - (version-major+minor - (package-version locales))))) - (setlocale LC_ALL "en_US.utf8")) + ;; First of all, install a UTF-8 locale so that UTF-8 file names + ;; are correctly interpreted. During bootstrap, locales are + ;; missing. + (let ((locale "C.UTF-8")) + (catch 'system-error + (lambda () + (setlocale LC_ALL locale)) + (lambda args + (format (current-error-port) + "failed to install '~a' locale: ~a~%" + locale (system-error-errno args))))) (setenv "PATH" - (string-append #+xz "/bin" - (if #+comp - (string-append ":" #+comp "/bin") - ""))) + (string-join + (map (cut string-append <> "/bin") + ;; Fallback to xz in case zstd is not + ;; available, such as for bootstrap packages. + (delete-duplicates + (filter-map identity (list #+zstd #+xz #+comp)))) + ":")) - (setenv "XZ_DEFAULTS" (string-join (%xz-parallel-args))) + (setenv "ZSTD_NBTHREADS" (number->string (parallel-job-count))) ;; SOURCE may be either a directory, a tarball or a simple file. (let ((name (strip-store-file-name #+source)) @@ -1121,10 +1150,13 @@ specifies modules in scope when evaluating SNIPPET." (else ;single uncompressed file (copy-file file #$output))))))) - (let ((name (if (or (checkout? original-file-name) - (not (compressor original-file-name))) - original-file-name - (tarxz-name original-file-name)))) + (let* ((ext (if zstd + "zst" ;usual case + "xz")) ;zstd-less bootstrap-origin + (name (if (or (checkout? original-file-name) + (not (compressor original-file-name))) + original-file-name + (tar-file-name original-file-name ext)))) (gexp->derivation name build #:graft? #f #:system system @@ -1584,14 +1616,16 @@ package and returns its new name after rewrite." (package-mapping rewrite cut? #:deep? deep?)) -(define* (package-input-rewriting/spec replacements #:key (deep? #t)) +(define* (package-input-rewriting/spec replacements + #:key (deep? #t) (replace-hidden? #f)) "Return a procedure that, given a package, applies the given REPLACEMENTS to all the package graph, including implicit inputs unless DEEP? is false. REPLACEMENTS is a list of spec/procedures pair; each spec is a package specification such as \"gcc\" or \"guile@2\", and each procedure takes a matching package and returns a replacement for that package. Matching -packages that have the 'hidden?' property set are not replaced." +packages that have the 'hidden?' property set are not replaced unless +REPLACE-HIDDEN? is set to true." (define table (fold (lambda (replacement table) (match replacement @@ -1620,7 +1654,8 @@ packages that have the 'hidden?' property set are not replaced." (define (rewrite p) (if (or (assq-ref (package-properties p) replacement-property) - (hidden-package? p)) + (and (not replace-hidden?) + (hidden-package? p))) p (match (find-replacement p) (#f p) diff --git a/guix/platforms/x86.scm b/guix/platforms/x86.scm index 0c8fc7296c..5617e6dd68 100644 --- a/guix/platforms/x86.scm +++ b/guix/platforms/x86.scm @@ -1,6 +1,7 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2022 Mathieu Othacehe <othacehe@gnu.org> ;;; Copyright © 2023, 2024 Efraim Flashner <efraim@flashner.co.il> +;;; Copyright © 2024 Janneke Nieuwenhuizen <janneke@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -25,7 +26,8 @@ x86_64-linux-x32 i686-mingw x86_64-mingw - i586-gnu)) + i586-gnu + x86_64-gnu)) (define i686-linux (platform @@ -71,3 +73,10 @@ (system "i586-gnu") (rust-target "i686-unknown-hurd-gnu") (glibc-dynamic-linker "/lib/ld.so.1"))) + +(define x86_64-gnu + (platform + (target "x86_64-pc-gnu") + (system "x86_64-gnu") + (rust-target "x86_64-unknown-hurd-gnu") + (glibc-dynamic-linker "/lib/ld-x86-64.so.1"))) diff --git a/guix/profiles.scm b/guix/profiles.scm index d41802422b..a28cf872cf 100644 --- a/guix/profiles.scm +++ b/guix/profiles.scm @@ -7,7 +7,7 @@ ;;; Copyright © 2016, 2017, 2018, 2019, 2021, 2022 Ricardo Wurmus <rekado@elephly.net> ;;; Copyright © 2016 Chris Marusich <cmmarusich@gmail.com> ;;; Copyright © 2017 Huang Ying <huang.ying.caritas@gmail.com> -;;; Copyright © 2017, 2021 Maxim Cournoyer <maxim.cournoyer@gmail.com> +;;; Copyright © 2017, 2021, 2024 Maxim Cournoyer <maxim.cournoyer@gmail.com> ;;; Copyright © 2019 Kyle Meyer <kyle@kyleam.com> ;;; Copyright © 2019 Mathieu Othacehe <m.othacehe@gmail.com> ;;; Copyright © 2020 Danny Milosavljevic <dannym@scratchpost.org> @@ -1127,11 +1127,6 @@ certificates in the /etc/ssl/certs sub-directories of the packages in MANIFEST. Single-file bundles are required by programs such as Git and Lynx." ;; See <http://lists.gnu.org/archive/html/guix-devel/2015-02/msg00429.html> ;; for a discussion. - - (define libc-utf8-locales-for-target ;lazy reference - (module-ref (resolve-interface '(gnu packages base)) - 'libc-utf8-locales-for-target)) - (define build (with-imported-modules '((guix build utils)) #~(begin @@ -1163,13 +1158,7 @@ MANIFEST. Single-file bundles are required by programs such as Git and Lynx." ;; Some file names in the NSS certificates are UTF-8 encoded so ;; install a UTF-8 locale. - (setenv "LOCPATH" - (string-append #+(libc-utf8-locales-for-target system) - "/lib/locale/" - #+(version-major+minor - (package-version - (libc-utf8-locales-for-target system))))) - (setlocale LC_ALL "en_US.utf8") + (setlocale LC_ALL "C.UTF-8") (match (append-map ca-files '#$(manifest-inputs manifest)) (() @@ -1487,11 +1476,14 @@ This is meant to be used as a profile hook." (define guile-zlib (module-ref (resolve-interface '(gnu packages guile)) 'guile-zlib)) + (define guile-zstd + (module-ref (resolve-interface '(gnu packages guile)) 'guile-zstd)) + (define build (with-imported-modules (source-module-closure '((guix build utils) (gnu build linux-modules))) - (with-extensions (list guile-zlib) + (with-extensions (list guile-zlib guile-zstd) #~(begin (use-modules (ice-9 ftw) (ice-9 match) @@ -1714,6 +1706,9 @@ the entries in MANIFEST." (define guile-zlib (module-ref (resolve-interface '(gnu packages guile)) 'guile-zlib)) + (define guile-zstd + (module-ref (resolve-interface '(gnu packages guile)) 'guile-zstd)) + (define modules (delete '(guix config) (source-module-closure `((guix build utils) @@ -1722,7 +1717,8 @@ the entries in MANIFEST." (define build (with-imported-modules modules (with-extensions (list gdbm-ffi ;for (guix man-db) - guile-zlib) + guile-zlib + guile-zstd) #~(begin (use-modules (guix man-db) (guix build utils) @@ -1962,8 +1958,7 @@ with a different version number.) Unless ALLOW-UNSUPPORTED-PACKAGES? is true or TARGET is set, raise an error if MANIFEST contains a package that does not support SYSTEM. -When LOCALES? is true, the build is performed under a UTF-8 locale; this adds -a dependency on the 'glibc-utf8-locales' package. +When LOCALES? is true, the build is performed under a UTF-8 locale. When RELATIVE-SYMLINKS? is true, use relative file names for symlink targets. This is one of the things to do for the result to be relocatable. @@ -2006,21 +2001,10 @@ are cross-built for TARGET." (and (derivation? drv) (gexp-input drv))) extras)) - (define libc-utf8-locales-for-target ;lazy reference - (module-ref (resolve-interface '(gnu packages base)) - 'libc-utf8-locales-for-target)) - (define set-utf8-locale - ;; Some file names (e.g., in 'nss-certs') are UTF-8 encoded so - ;; install a UTF-8 locale. - (let ((locales (libc-utf8-locales-for-target - (or system (%current-system))))) - #~(begin - (setenv "LOCPATH" - #$(file-append locales "/lib/locale/" - (version-major+minor - (package-version locales)))) - (setlocale LC_ALL "en_US.utf8")))) + ;; Some file names (e.g., in 'nss-certs') are UTF-8 encoded so install a + ;; UTF-8 locale. Assume libc comes with a copy of C.UTF-8. + #~(setlocale LC_ALL "C.UTF-8")) (define builder (with-imported-modules '((guix build profiles) diff --git a/guix/read-print.scm b/guix/read-print.scm index 6421b79737..1f7902c546 100644 --- a/guix/read-print.scm +++ b/guix/read-print.scm @@ -350,7 +350,7 @@ expressions and blanks that were read." ('swap-space 1) ('user-account 1) ('user-group 1) - ('setuid-program 1) + ('privileged-program 1) ('modify-services 2) ;; (gnu home). diff --git a/guix/records.scm b/guix/records.scm index dca1e3c2e7..fa2d42e17b 100644 --- a/guix/records.scm +++ b/guix/records.scm @@ -415,11 +415,19 @@ inherited." ;; list of symbols. (syntax-case field-specs () (((field get properties ...) ...) - (string-hash (object->string - (syntax->datum #'((field properties ...) ...))) - (cond-expand - (guile-3 (target-most-positive-fixnum)) - (else most-positive-fixnum)))))) + ;; Passing (target-most-positive-fixnum) as the second argument of + ;; 'string-hash' won't have the intended effect when cross-compiling + ;; because that second argument is used to compute a modulo after the + ;; hash has been computed on an 'unsigned long'. Instead, only keep + ;; the 32 most significant bits on 64-bit platforms, unconditionally. + ;; See <https://issues.guix.gnu.org/74296>. + (let ((hash-value + (string-hash + (object->string (syntax->datum #'((field properties ...) ...)))))) + (cond + ((< most-positive-fixnum (ash 1 32)) hash-value) + ((< most-positive-fixnum (ash 1 64)) (ash hash-value -32)) + (else (error "unexpected!" most-positive-fixnum))))))) (syntax-case s () ((_ type syntactic-ctor ctor pred diff --git a/guix/remote.scm b/guix/remote.scm index a58ec2103c..9423f9af12 100644 --- a/guix/remote.scm +++ b/guix/remote.scm @@ -48,9 +48,6 @@ (define* (remote-pipe-for-gexp lowered session #:optional become-command) "Return a remote pipe for the given SESSION to evaluate LOWERED. If BECOME-COMMAND is given, use that to invoke the remote Guile REPL." - (define shell-quote - (compose object->string object->string)) - (define repl-command (append (or become-command '()) (list @@ -65,7 +62,7 @@ BECOME-COMMAND is given, use that to invoke the remote Guile REPL." `("-C" ,directory)) (lowered-gexp-load-path lowered)) `("-c" - ,(shell-quote (lowered-gexp-sexp lowered))))) + ,(object->string (lowered-gexp-sexp lowered))))) (let ((pipe (apply open-remote-pipe* session OPEN_READ repl-command))) (when (eof-object? (peek-char pipe)) diff --git a/guix/scripts/build.scm b/guix/scripts/build.scm index da4859eeaa..f0a637a2ef 100644 --- a/guix/scripts/build.scm +++ b/guix/scripts/build.scm @@ -33,6 +33,9 @@ #:use-module (guix profiles) #:use-module (guix diagnostics) #:autoload (guix http-client) (http-fetch http-get-error?) + #:autoload (guix scripts graph) (%bag-node-type) + #:autoload (guix graph) (node-back-edges) + #:autoload (guix sets) (setq set-contains? set-insert) #:use-module (ice-9 format) #:use-module (ice-9 match) #:use-module (srfi srfi-1) @@ -60,6 +63,8 @@ show-cross-build-options-help show-native-build-options-help + dependents + guix-build register-root register-root*)) @@ -438,6 +443,11 @@ Build the given PACKAGE-OR-DERIVATION and return their output paths.\n")) -m, --manifest=FILE build the packages that the manifest given in FILE evaluates to")) (display (G_ " + -D, --development build the inputs of the following package")) + (display (G_ " + -P, --dependents[=N] build dependents of the following package, up to + depth N")) + (display (G_ " -S, --source build the packages' source derivations")) (display (G_ " --sources[=TYPE] build source derivations; TYPE may optionally be one @@ -522,6 +532,14 @@ must be one of 'package', 'all', or 'transitive'~%") (option '(#\m "manifest") #t #f (lambda (opt name arg result) (alist-cons 'manifest arg result))) + (option '(#\D "development") #f #f + (lambda (opt name arg result) + (alist-cons 'development? #t result))) + (option '(#\P "dependents") #f #t + (lambda (opt name arg result) + (alist-cons 'dependents + (or (and=> arg string->number*) +inf.0) + result))) (option '(#\n "dry-run") #f #f (lambda (opt name arg result) (alist-cons 'dry-run? #t result))) @@ -546,7 +564,39 @@ must be one of 'package', 'all', or 'transitive'~%") %standard-cross-build-options %standard-native-build-options))) -(define (options->things-to-build opts) +(define* (dependents store packages #:optional (max-depth +inf.0)) + "Return the list of dependents of all of PACKAGES up to distance MAX-DEPTH." + ;; Using %BAG-NODE-TYPE is more accurate than using %PACKAGE-NODE-TYPE + ;; because it includes implicit dependencies. + (define (get-dependents packages edges) + (let loop ((packages packages) + (result '()) + (depth 0) + (visited (setq))) + (if (> depth max-depth) + (values result visited) + (match packages + (() + (values result visited)) + ((head . tail) + (if (set-contains? visited head) + (loop tail result depth visited) + (let ((next (edges head))) + (call-with-values + (lambda () + (loop next + (cons head result) + (+ depth 1) + (set-insert head visited))) + (lambda (result visited) + (loop tail result depth visited)))))))))) + + (with-store store + (run-with-store store + (mlet %store-monad ((edges (node-back-edges %bag-node-type (all-packages)))) + (return (get-dependents packages edges)))))) + +(define (options->things-to-build store opts) "Read the arguments from OPTS and return a list of high-level objects to build---packages, gexps, derivations, and so on." (define (validate-type x) @@ -581,43 +631,100 @@ values."))))))))) (for-each validate-type lst) lst)) - (append-map (match-lambda - (('argument . (? string? spec)) - (cond ((derivation-path? spec) - (catch 'system-error - (lambda () - ;; Ask for absolute file names so that .drv file - ;; names passed from the user to 'read-derivation' - ;; are absolute when it returns. - (let ((spec (canonicalize-path spec))) - (list (read-derivation-from-file spec)))) - (lambda args - ;; Non-existent .drv files can be substituted down - ;; the road, so don't error out. - (if (= ENOENT (system-error-errno args)) - '() - (apply throw args))))) - ((store-path? spec) - ;; Nothing to do; maybe for --log-file. - '()) - (else - (list (specification->package spec))))) - (('file . file) - (let ((file (or (and (string-suffix? ".json" file) - (json->scheme-file file)) - file))) - (ensure-list (load* file (make-user-module '()))))) - (('manifest . manifest) - (map manifest-entry-item - (manifest-entries - (load* manifest - (make-user-module '((guix profiles) (gnu))))))) - (('expression . str) - (ensure-list (read/eval str))) - (('argument . (? derivation? drv)) - drv) - (_ '())) - opts)) + (define (ensure-manifest x file) + (unless (manifest? x) + (raise (formatted-message (G_ "file '~a' does not return a manifest") + file))) + x) + + (define system + (or (assoc-ref opts 'system) (%current-system))) + + ;; Process OPTS in "the right order", meaning that if the user typed + ;; "-D hello", arrange to see the 'development? option before the "hello" + ;; spec. + (let loop ((opts (reverse opts)) + (type 'regular) + (result '())) + (define (for-type obj) + ;; Return a list of objects corresponding to OBJ adjusted for TYPE. + (match type + ('regular + (list obj)) + (('dependents . depth) + (if (package? obj) + (begin + (info (G_ "computing dependents of package ~a...~%") + (package-full-name obj)) + (dependents store (list obj) depth)) + (list obj))) + ('development + (if (package? obj) + (map manifest-entry-item + (manifest-entries + (package->development-manifest obj system))) + obj)))) + + (match opts + (() + (reverse result)) + ((head . tail) + (match head + (('argument . (? string? spec)) + (cond ((derivation-path? spec) + (catch 'system-error + (lambda () + ;; Ask for absolute file names so that .drv file + ;; names passed from the user to 'read-derivation' + ;; are absolute when it returns. + (let ((spec (canonicalize-path spec))) + (loop tail 'regular + (cons (read-derivation-from-file spec) + result)))) + (lambda args + ;; Non-existent .drv files can be substituted down + ;; the road, so don't error out. + (if (= ENOENT (system-error-errno args)) + (loop tail 'regular result) + (apply throw args))))) + ((store-path? spec) + ;; Nothing to do; maybe for --log-file. + (loop tail type result)) + (else + (loop tail 'regular + (append (for-type (specification->package spec)) + result))))) + (('argument . (? derivation? drv)) + (loop tail 'regular (cons drv result))) + (('file . file) + (let ((file (or (and (string-suffix? ".json" file) + (json->scheme-file file)) + file))) + (loop tail 'regular + (append (append-map + for-type + (ensure-list (load* file (make-user-module '())))) + result)))) + (('manifest . manifest) + (loop tail 'regular + (append (map manifest-entry-item + (manifest-entries + (ensure-manifest + (load* manifest + (make-user-module '((guix profiles) + (gnu)))) + manifest))) + result))) + (('expression . str) + (loop tail 'regular + (append (append-map for-type (ensure-list (read/eval str))) + result))) + (('development? . #t) + (loop tail 'development result)) + (('dependents . depth) + (loop tail `(dependents . ,depth) result)) + (_ + (loop tail type result))))))) (define (options->derivations store opts) "Given OPTS, the result of 'args-fold', return a list of derivations to @@ -642,7 +749,7 @@ build." (systems systems))) (define things-to-build - (map transform (options->things-to-build opts))) + (map transform (options->things-to-build store opts))) (define warn-if-unsupported (let ((target (assoc-ref opts 'target))) @@ -678,9 +785,9 @@ build." (package-name p)) '()) (s - (list (package-source-derivation store s))))) + (list (package-source-derivation store s system))))) (proc - (map (cut package-source-derivation store <>) + (map (cut package-source-derivation store <> system) (proc p)))))) ((? derivation? drv) (list drv)) @@ -760,13 +867,6 @@ needed." (%graft? graft?)) (let* ((mode (assoc-ref opts 'build-mode)) (drv (options->derivations store opts)) - (urls (map (cut string-append <> "/log") - (if (assoc-ref opts 'substitutes?) - (or (assoc-ref opts 'substitute-urls) - ;; XXX: This does not necessarily match the - ;; daemon's substitute URLs. - %default-substitute-urls) - '()))) (items (filter-map (match-lambda (('argument . (? store-path? file)) ;; If FILE is a .drv that's not in @@ -789,10 +889,19 @@ needed." ;; Pass 'show-build-log' the output file names, not the ;; derivation file names, because there can be several ;; derivations leading to the same output. - (for-each (cut show-build-log store <> urls) - (delete-duplicates - (append (map derivation->output-path drv) - items)))) + (let ((urls (map (cut string-append <> "/log") + (if (assoc-ref opts 'substitutes?) + (or (assoc-ref opts 'substitute-urls) + (substitute-urls store) + (begin + (warning (G_ "\ +could not determine current substitute URLs; using defaults~%")) + %default-substitute-urls)) + '())))) + (for-each (cut show-build-log store <> urls) + (delete-duplicates + (append (map derivation->output-path drv) + items))))) ((assoc-ref opts 'derivations-only?) (format #t "~{~a~%~}" (map derivation-file-name drv)) (for-each (cut register-root store <> <>) diff --git a/guix/scripts/describe.scm b/guix/scripts/describe.scm index 70ae84e9f6..08cb1b07c7 100644 --- a/guix/scripts/describe.scm +++ b/guix/scripts/describe.scm @@ -254,6 +254,7 @@ PROFILE and NUMBER " "/commit/?id=" commit))) ("notabug.org" ,labhub-url) ("framagit.org" ,labhub-url) + ("codeberg.org" ,labhub-url) ("gitlab.com" ,labhub-url) ("gitlab.inria.fr" ,labhub-url) ("github.com" ,labhub-url)))) diff --git a/guix/scripts/environment.scm b/guix/scripts/environment.scm index 1d7a6e198d..fc7fa84be7 100644 --- a/guix/scripts/environment.scm +++ b/guix/scripts/environment.scm @@ -1,6 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2014, 2015, 2018 David Thompson <davet@gnu.org> -;;; Copyright © 2015-2023 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2015-2024 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2018 Mike Gerwitz <mtg@gnu.org> ;;; Copyright © 2022, 2023 John Kehayias <john.kehayias@protonmail.com> ;;; @@ -464,8 +464,15 @@ providing a symlink for CC if GCC is in the container PROFILE, and writing ;; /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"))) + (when (file-exists? gcc-path) + (catch 'system-error + (lambda () + (symlink gcc-path "/bin/cc")) + (lambda args + ;; If /bin/cc already exists because it was provided by another + ;; package in PROFILE, such as 'clang-toolchain', leave it. + (unless (= EEXIST (system-error-errno args)) + (apply throw args)))))) ;; Guix's ldconfig doesn't search in FHS default locations, so provide a ;; minimal ld.so.conf. @@ -812,7 +819,7 @@ WHILE-LIST." (passwd:gecos pwd))) (uid uid) (gid gid) (shell bash) (directory (if (or user (not pwd)) - (string-append "/home/" user) + (string-append "/home/" name) (passwd:dir pwd)))))) (groups (list (group-entry (name "users") (gid gid)) (group-entry (gid 65534) ;the overflow GID diff --git a/guix/scripts/graph.scm b/guix/scripts/graph.scm index 6740858d8b..935721edea 100644 --- a/guix/scripts/graph.scm +++ b/guix/scripts/graph.scm @@ -119,16 +119,6 @@ name." ;;; Reverse package DAG. ;;; -(define (all-packages) ;XXX: duplicated from (guix scripts refresh) - "Return the list of all the distro's packages." - (fold-packages (lambda (package result) - ;; Ignore deprecated packages. - (if (package-superseded package) - result - (cons package result))) - '() - #:select? (const #t))) ;include hidden packages - (define %reverse-package-node-type ;; For this node type we first need to compute the list of packages and the ;; list of back-edges. Since we want to do it only once, we use the diff --git a/guix/scripts/hash.scm b/guix/scripts/hash.scm index 7197d3965c..dec037ed3f 100644 --- a/guix/scripts/hash.scm +++ b/guix/scripts/hash.scm @@ -3,7 +3,7 @@ ;;; Copyright © 2013 Nikita Karetnikov <nikita@karetnikov.org> ;;; Copyright © 2016 Jan Nieuwenhuizen <janneke@gnu.org> ;;; Copyright © 2018 Tim Gesthuizen <tim.gesthuizen@yahoo.de> -;;; Copyright © 2021 Simon Tournier <zimon.toutoune@gmail.com> +;;; Copyright © 2021, 2023 Simon Tournier <zimon.toutoune@gmail.com> ;;; Copyright © 2021 Sarah Morgensen <iskarian@mgsn.dev> ;;; ;;; This file is part of GNU Guix. @@ -181,9 +181,6 @@ use '--serializer=nar' instead~%"))) (_ #f)) (reverse opts))) (fmt (assq-ref opts 'format)) - (select? (if (assq-ref opts 'exclude-vcs?) - (negate vcs-file?) - (const #t))) (algorithm (assoc-ref opts 'hash-algorithm)) (serializer (assoc-ref opts 'serializer))) @@ -193,7 +190,10 @@ use '--serializer=nar' instead~%"))) (catch 'system-error (lambda _ (with-error-handling - (serializer file algorithm select?))) + (let ((select? (if (assq-ref opts 'exclude-vcs?) + (negate (vcs-file-predicate file)) + (const #t)))) + (serializer file algorithm select?)))) (lambda args (leave (G_ "~a ~a~%") file diff --git a/guix/scripts/import.scm b/guix/scripts/import.scm index 1f34cab088..bbf31baa15 100644 --- a/guix/scripts/import.scm +++ b/guix/scripts/import.scm @@ -47,9 +47,11 @@ ;;; Entry point. ;;; -(define importers '("gnu" "pypi" "cpan" "hackage" "stackage" "egg" "elpa" - "gem" "go" "cran" "crate" "texlive" "json" "opam" - "minetest" "elm" "hexpm" "composer")) +;; The list of all known importers. These are printed in order by SHOW-HELP, so +;; please keep this list alphabetically sorted! +(define importers '("composer" "cpan" "cran" "crate" "egg" "elm" "elpa" + "gem" "gnu" "go" "hackage" "hexpm" "json" "minetest" + "npm-binary" "opam" "pypi" "stackage" "texlive")) (define (resolve-importer name) (let ((module (resolve-interface diff --git a/guix/scripts/import/cpan.scm b/guix/scripts/import/cpan.scm index bdf5a1e423..4ddd85ee57 100644 --- a/guix/scripts/import/cpan.scm +++ b/guix/scripts/import/cpan.scm @@ -44,6 +44,8 @@ Import and convert the CPAN package for PACKAGE-NAME.\n")) (display (G_ " -h, --help display this help and exit")) (display (G_ " + -r, --recursive import missing packages recursively")) + (display (G_ " -V, --version display version information and exit")) (newline) (show-bug-report-information)) @@ -54,6 +56,9 @@ Import and convert the CPAN package for PACKAGE-NAME.\n")) (lambda args (show-help) (exit 0))) + (option '(#\r "recursive") #f #f + (lambda (opt name arg result) + (alist-cons 'recursive #t result))) (option '(#\V "version") #f #f (lambda args (show-version-and-exit "guix import cpan"))) @@ -78,11 +83,20 @@ Import and convert the CPAN package for PACKAGE-NAME.\n")) (reverse opts)))) (match args ((package-name) - (let ((sexp (cpan->guix-package package-name))) - (unless sexp - (leave (G_ "failed to download meta-data for package '~a'~%") - package-name)) - sexp)) + (let ((sexp + (if (assoc-ref opts 'recursive) + (map (match-lambda + ((and ('package ('name name) . rest) pkg) + `(define-public ,(string->symbol name) + ,pkg)) + (_ #f)) + (cpan-recursive-import package-name)) + (let ((sexp (cpan->guix-package package-name))) + sexp)))) + (unless sexp + (leave (G_ "failed to download meta-data for package '~a'~%") + package-name)) + sexp)) (() (leave (G_ "too few arguments~%"))) ((many ...) diff --git a/guix/scripts/import/crate.scm b/guix/scripts/import/crate.scm index 082a973aee..a4adabfeff 100644 --- a/guix/scripts/import/crate.scm +++ b/guix/scripts/import/crate.scm @@ -1,4 +1,3 @@ - ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2014 David Thompson <davet@gnu.org> ;;; Copyright © 2016 David Craven <david@craven.ch> diff --git a/guix/scripts/import/go.scm b/guix/scripts/import/go.scm index f1970d3543..b90c6ac72f 100644 --- a/guix/scripts/import/go.scm +++ b/guix/scripts/import/go.scm @@ -51,7 +51,7 @@ can be specified after the arobas (@) character.\n")) -h, --help display this help and exit")) (display (G_ " -r, --recursive generate package expressions for all Go modules -that are not yet in Guix")) + that are not yet in Guix")) (display (G_ " -p, --goproxy=GOPROXY specify which goproxy server to use")) (display (G_ " diff --git a/guix/scripts/import/npm-binary.scm b/guix/scripts/import/npm-binary.scm new file mode 100644 index 0000000000..b2771bc539 --- /dev/null +++ b/guix/scripts/import/npm-binary.scm @@ -0,0 +1,121 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2014 David Thompson <davet@gnu.org> +;;; Copyright © 2018 Ricardo Wurmus <rekado@elephly.net> +;;; Copyright © 2019 Timothy Sample <samplet@ngyro.com> +;;; +;;; 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 scripts import npm-binary) + #:use-module (guix ui) + #:use-module (guix utils) + #:use-module (guix scripts) + #:use-module (guix import npm-binary) + #:use-module (guix scripts import) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-11) + #:use-module (srfi srfi-37) + #:use-module (srfi srfi-41) + #:use-module (ice-9 match) + #:use-module (ice-9 format) + #:export (guix-import-npm-binary)) + + +;;; +;;; Command-line options. +;;; + +(define %default-options + '()) + +(define (show-help) + (display (G_ "Usage: guix import npm-binary PACKAGE-NAME [VERSION] +Import and convert the npm package PACKAGE-NAME using the +`node-build-system' (but without building the package from source).")) + (display (G_ " + -h, --help display this help and exit")) + (display (G_ " + -r, --recursive import packages recursively")) + (display (G_ " + -V, --version display version information and exit")) + (newline) + (show-bug-report-information)) + +(define %options + ;; Specification of the command-line options. + (cons* (option '(#\h "help") #f #f + (lambda args + (show-help) + (exit 0))) + (option '(#\V "version") #f #f + (lambda args + (show-version-and-exit "guix import npm-binary"))) + (option '(#\r "recursive") #f #f + (lambda (opt name arg result) + (alist-cons 'recursive #t result))) + %standard-import-options)) + +(define* (package-name->name+version* spec) + "Given SPEC, a package name like \"@scope/pac@^0.9.1\", return two values: +\"@scope/pac\" and \"^0.9.1\". When the version part is unavailable, SPEC and \"*\" +are returned. The first part may start with '@', the latter part must not contain +contain '@'." + (match (string-rindex spec #\@) + (#f (values spec "*")) + (0 (values spec "*")) + (idx (values (substring spec 0 idx) + (substring spec (1+ idx)))))) + + +;;; +;;; Entry point. +;;; + +(define (guix-import-npm-binary . args) + (define (parse-options) + ;; Return the alist of option values. + (parse-command-line args %options (list %default-options) + #:build-options? #f)) + + (let* ((opts (parse-options)) + (args (filter-map (match-lambda + (('argument . value) + value) + (_ #f)) + (reverse opts)))) + (match args + ((spec) + (define-values (package-name version) + (package-name->name+version* spec)) + (match (if (assoc-ref opts 'recursive) + ;; Recursive import + (npm-binary-recursive-import package-name #:version version) + ;; Single import + (npm-binary->guix-package package-name #:version version)) + ((or #f '()) + (leave (G_ "failed to download meta-data for package '~a@~a'~%") + package-name version)) + (('package etc ...) `(package ,@etc)) + ((? list? sexps) + (map (match-lambda + ((and ('package ('name name) ('version version) . rest) pkg) + `(define-public ,(name+version->symbol name version) + ,pkg)) + (_ #f)) + sexps)))) + (() + (leave (G_ "too few arguments~%"))) + ((many ...) + (leave (G_ "too many arguments~%")))))) diff --git a/guix/scripts/locate.scm b/guix/scripts/locate.scm index 963ff2bf57..f8ee875c7c 100644 --- a/guix/scripts/locate.scm +++ b/guix/scripts/locate.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2022, 2023 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2022-2024 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2023 Antoine R. Dumont <antoine.romain.dumont@gmail.com> ;;; ;;; This file is part of GNU Guix. @@ -600,7 +600,7 @@ Locate FILE and return the list of packages that contain it.\n")) ;;; (define-command (guix-locate . args) - (category packaging) + (category main) (synopsis "search for packages providing a given file") (define age-update-threshold diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm index fe4df042d7..d0e66c3013 100644 --- a/guix/scripts/pack.scm +++ b/guix/scripts/pack.scm @@ -10,6 +10,8 @@ ;;; Copyright © 2022 Alex Griffin <a@ajgrf.com> ;;; Copyright © 2023 Graham James Addis <graham@addis.org.uk> ;;; Copyright © 2023 Oleg Pykhalov <go.wigust@gmail.com> +;;; Copyright © 2024 Sebastian Dümcke <code@sam-d.com> +;;; Copyright © 2024 Noé Lopez <noelopez@free.fr> ;;; ;;; This file is part of GNU Guix. ;;; @@ -28,6 +30,7 @@ (define-module (guix scripts pack) #:use-module (guix scripts) + #:autoload (guix import json) (json->scheme-file) #:use-module (guix ui) #:use-module (guix gexp) #:use-module (guix utils) @@ -56,6 +59,7 @@ #:use-module ((gnu packages compression) #:hide (zip)) #:use-module (gnu packages guile) #:use-module (gnu packages base) + #:autoload (gnu packages appimage) (appimage-type2-runtime) #:autoload (gnu packages gnupg) (guile-gcrypt) #:autoload (gnu packages guile) (guile2.0-json guile-json) #:use-module (srfi srfi-1) @@ -64,6 +68,7 @@ #:use-module (srfi srfi-35) #:use-module (srfi srfi-37) #:use-module (ice-9 match) + #:use-module (ice-9 optargs) #:export (symlink-spec-option-parser self-contained-tarball @@ -71,6 +76,7 @@ rpm-archive docker-image squashfs-image + self-contained-appimage %formats guix-pack)) @@ -493,7 +499,8 @@ added to the pack." "-p" "/proc d 555 0 0" "-p" "/sys d 555 0 0" "-p" "/dev d 555 0 0" - "-p" "/home d 555 0 0")) + "-p" "/home d 555 0 0" + "-p" "/tmp d 555 0 0")) (when database ;; Initialize /var/guix. @@ -973,8 +980,100 @@ PREUN-FILE and POSTUN-FILE can be provided via EXTRA-OPTIONS." (gexp->derivation (string-append name ".rpm") build #:target target #:references-graphs `(("profile" ,profile)))) + +;;; +;;; AppImage format +;;; +(define* (self-contained-appimage name profile + #:key target + (profile-name "guix-profile") + entry-point + (compressor (lookup-compressor "zstd")) + localstatedir? + (symlinks '()) + (archiver tar) + (extra-options '())) + "Return a self-contained AppImage containing a store initialized with the +closure of PROFILE, a derivation. The AppImage contains /gnu/store unless +RELOCATABLE option is used; if LOCALSTATEDIR? is true, it also contains +/var/guix, including /var/guix/db with a properly initialized store database. + +SYMLINKS must be a list of (SOURCE -> TARGET) tuples denoting symlinks to be +added to the pack." + (unless entry-point + (leave (G_ "entry-point must be provided in the '~a' format~%") + 'appimage)) + (let-keywords extra-options #f ((relocatable? #f)) + (unless relocatable? + (warning (G_ "AppImages should be built with the --relocatable flag~%")))) - + (define runtime-package appimage-type2-runtime) + (define runtime-path "bin/runtime-fuse3") + (define %valid-compressors '("gzip" "zstd")) + + (let ((compressor-name (compressor-name compressor))) + (unless (member compressor-name %valid-compressors) + (leave (G_ "~a is not a valid squashfs archive compressor used in +generating the AppImage. Valid compressors are: ~a~%") + compressor-name + %valid-compressors))) + + (define builder + (with-extensions (list guile-gcrypt) + (with-imported-modules (source-module-closure + '((guix build store-copy) + (guix build utils)) + #:select? not-config?) + #~(begin + (use-modules (guix build utils) + (guix build store-copy) + (rnrs io ports) + (srfi srfi-1) + (srfi srfi-26)) + + (define (concatenate-files result file1 file2) + "Creates a new file RESULT containing FILE1 followed by FILE2." + (call-with-output-file result + (lambda (output) + (call-with-input-file file1 + (lambda (input) + (dump-port input output))) + (call-with-input-file file2 + (lambda (input) + (dump-port input output)))))) + + (let* ((appdir "AppDir") + (squashfs "squashfs") + (profile-items (map store-info-item + (call-with-input-file "profile" read-reference-graph))) + (profile (find (lambda (item) + (string-suffix? "-profile" item)) + profile-items))) + (mkdir-p appdir) + ;; Copy all store items from the profile to the AppDir. + (populate-store '("profile") appdir) + ;; Symlink the provided entry-point to AppDir/AppRun. + (symlink (string-append "." profile "/" #$entry-point) + (string-append appdir "/AppRun")) + ;; Create .desktop file as required by the spec. + (make-desktop-entry-file + (string-append appdir "/" #$name ".desktop") + #:name #$name + #:exec #$entry-point) + ;; Compress the AppDir. + (invoke #+(file-append squashfs-tools "/bin/mksquashfs") appdir + squashfs "-root-owned" "-noappend" + "-comp" #+(compressor-name compressor)) + ;; Append runtime and squashFS into file AppImage. + (concatenate-files #$output + #$(file-append runtime-package "/" runtime-path) + squashfs) + ;; Add execution permission. + (chmod #$output #o555)))))) + (gexp->derivation (string-append name ".AppImage") builder + #:target target + #:references-graphs `(("profile" ,profile)))) + ;;; ;;; Compiling C programs. ;;; @@ -1006,12 +1105,30 @@ by '--bootstrap', for testing purposes." "Lower COMPILER to a single script that does the right thing." (define toolchain (or (c-compiler-toolchain compiler) - (list (first (assoc-ref (standard-packages) "gcc")) - (first (assoc-ref (standard-packages) "ld-wrapper")) - (first (assoc-ref (standard-packages) "binutils")) - (first (assoc-ref (standard-packages) "libc")) - (gexp-input (first (assoc-ref (standard-packages) "libc")) - "static")))) + (if target + (let* ((cross-packages-host + (standard-cross-packages target 'host)) + (cross-packages-target + (standard-cross-packages target 'target)) + (xgcc + (first (assoc-ref cross-packages-host "cross-gcc")))) + (list xgcc + ;; ld-wrapper-cross isn't included with + ;; STANDARD-CROSS-PACKAGES, pull it from the inputs of + ;; cross-gcc instead + (first (assoc-ref (package-native-inputs xgcc) + "ld-wrapper-cross")) + (first (assoc-ref cross-packages-host "cross-binutils")) + (first (assoc-ref cross-packages-target "cross-libc")) + (gexp-input (first (assoc-ref cross-packages-target + "cross-libc:static")) + "static"))) + (list (first (assoc-ref (standard-packages) "gcc")) + (first (assoc-ref (standard-packages) "ld-wrapper")) + (first (assoc-ref (standard-packages) "binutils")) + (first (assoc-ref (standard-packages) "libc")) + (gexp-input (first (assoc-ref (standard-packages) "libc")) + "static"))))) (define inputs (match (append-map package-propagated-inputs @@ -1021,7 +1138,9 @@ by '--bootstrap', for testing purposes." (define search-paths (cons $PATH - (append-map package-native-search-paths + (append-map (if target + package-search-paths + package-native-search-paths) (filter package? inputs)))) (define run @@ -1045,17 +1164,12 @@ by '--bootstrap', for testing purposes." '#$inputs) (let ((output (output-file (command-line)))) - (apply invoke "gcc" (cdr (command-line))) - (invoke "strip" output))))) - - (when target - ;; TODO: Yep, we'll have to do it someday! - (leave (G_ "cross-compilation not implemented here; -please email '~a'~%") - (@ (guix config) %guix-bug-report-address))) + (apply invoke #$(cc-for-target target) (cdr (command-line))) + (invoke #$(strip-for-target target) output))))) (gexp->script "c-compiler" run - #:guile (c-compiler-guile compiler))) + #:guile (c-compiler-guile compiler) + #:target #f)) ;;; @@ -1310,6 +1424,7 @@ libfakechroot.so and related ld.so machinery as a fallback." (squashfs . ,squashfs-image) (docker . ,docker-image) (deb . ,debian-archive) + (appimage . ,self-contained-appimage) (rpm . ,rpm-archive))) (define (show-formats) @@ -1326,6 +1441,8 @@ libfakechroot.so and related ld.so machinery as a fallback." deb Debian archive installable via dpkg/apt")) (display (G_ " rpm RPM archive installable via rpm/yum")) + (display (G_ " + appimage AppImage self-contained and executable format")) (newline)) (define (required-option symbol) @@ -1429,6 +1546,9 @@ libfakechroot.so and related ld.so machinery as a fallback." (lambda (opt name arg result) (alist-cons 'derivation-only? #t result))) + (option '("file") #t #f + (lambda (opt name arg result) + (alist-cons 'file arg result))) (option '(#\f "format") #t #f (lambda (opt name arg result) (alist-cons 'format (string->symbol arg) result))) @@ -1520,6 +1640,8 @@ Create a bundle of PACKAGE.\n")) (show-rpm-format-options) (newline) (display (G_ " + --file=FORMAT build a pack the code within FILE evaluates to")) + (display (G_ " -f, --format=FORMAT build a pack in the given FORMAT")) (display (G_ " --list-formats list the formats available")) @@ -1583,6 +1705,11 @@ Create a bundle of PACKAGE.\n")) list)) (('expression . exp) (read/eval-package-expression exp)) + (('file . file) + (let ((file (or (and (string-suffix? ".json" file) + (json->scheme-file file)) + file))) + (load* file (make-user-module '())))) (x #f))) (define (manifest-from-args store opts) @@ -1693,6 +1820,8 @@ Create a bundle of PACKAGE.\n")) (process-file-arg opts 'preun-file) #:postun-file (process-file-arg opts 'postun-file))) + ('appimage + (list #:relocatable? relocatable?)) (_ '()))) (target (assoc-ref opts 'target)) (bootstrap? (assoc-ref opts 'bootstrap?)) diff --git a/guix/scripts/refresh.scm b/guix/scripts/refresh.scm index d858ed07cb..8c72d0c545 100644 --- a/guix/scripts/refresh.scm +++ b/guix/scripts/refresh.scm @@ -43,7 +43,7 @@ #:use-module (guix gnupg) #:use-module (guix hash) #:use-module (gnu packages) - #:use-module ((gnu packages commencement) #:select (%final-inputs)) + #:use-module ((gnu packages base) #:select (%final-inputs)) #:use-module (ice-9 match) #:use-module (ice-9 format) #:use-module (ice-9 regex) @@ -455,16 +455,6 @@ releases for ~a~%") ;;; Dependents. ;;; -(define (all-packages) - "Return the list of all the distro's packages." - (fold-packages (lambda (package result) - ;; Ignore deprecated packages. - (if (package-superseded package) - result - (cons package result))) - '() - #:select? (const #t))) ;include hidden packages - (define (list-dependents packages) "List all the things that would need to be rebuilt if PACKAGES are changed." ;; Using %BAG-NODE-TYPE is more accurate than using %PACKAGE-NODE-TYPE diff --git a/guix/scripts/shell.scm b/guix/scripts/shell.scm index 0584a7e018..d23362a15d 100644 --- a/guix/scripts/shell.scm +++ b/guix/scripts/shell.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2021-2023 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2021-2024 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2023 Janneke Nieuwenhuizen <janneke@gnu.org> ;;; ;;; This file is part of GNU Guix. @@ -25,6 +25,7 @@ show-native-build-options-help) #:autoload (guix transformations) (options->transformation transformation-option-key? + cacheable-transformation-option-key? show-transformation-options-help) #:autoload (guix grafts) (%graft?) #:use-module (guix scripts) @@ -417,11 +418,13 @@ return #f and #f." ;; Arbitrary expressions might be non-deterministic or otherwise depend ;; on external state so do not cache when they're used. (values #f #f)) - ((((? transformation-option-key?) . _) . _) + ((((? transformation-option-key? key) . _) . rest) ;; Transformation options are potentially "non-deterministic", or at - ;; least depending on external state (with-source, with-commit, etc.), - ;; so do not cache anything when they're used. - (values #f #f)) + ;; least depending on external state (with-source, with-commit, etc.). + ;; Cache only those that are known to be "cacheable". + (if (cacheable-transformation-option-key? key) + (loop rest system file (cons (first opts) specs)) + (values #f #f))) ((('profile . _) . _) ;; If the user already specified a profile, there's nothing more to ;; cache. diff --git a/guix/scripts/style.scm b/guix/scripts/style.scm index 211980dc1c..51234952e9 100644 --- a/guix/scripts/style.scm +++ b/guix/scripts/style.scm @@ -1,5 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2021-2023 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2021-2024 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2024 Herman Rimm <herman@rimm.ee> ;;; ;;; This file is part of GNU Guix. ;;; @@ -29,6 +30,7 @@ (define-module (guix scripts style) #:autoload (gnu packages) (specification->package fold-packages) + #:use-module (guix combinators) #:use-module (guix scripts) #:use-module ((guix scripts build) #:select (%standard-build-options)) #:use-module (guix ui) @@ -304,7 +306,7 @@ counterpart." value)) (('unquote-splicing x) (if (= quotation 1) - `(ungexp-splicing x) + `(ungexp-splicing ,x) value)) (('quasiquote x) (list 'quasiquote (loop x (+ quotation 1)))) @@ -494,11 +496,62 @@ bailing out~%")) ;;; Whole-file formatting. ;;; -(define* (format-whole-file file #:rest rest) - "Reformat all of FILE." +(define (order-packages lst) + "Return LST, a list of top-level expressions and blanks, with +top-level package definitions in alphabetical order. Packages which +share a name are placed with versions in descending order." + (define (package-name pkg) + (match pkg + ((('define-public _ expr) _ ...) + (match expr + ((or ('package _ ('name name) _ ...) + ('package ('name name) _ ...)) + name) + (_ #f))) + (_ #f))) + + (define (package-version pkg) + (match pkg + ((('define-public _ expr) _ ...) + (match expr + ((or ('package _ _ ('version version) _ ...) + ('package _ ('version version) _ ...)) + version) + (_ #f))) + (_ #f))) + + (define (package>? lst1 lst2) + (let ((name1 (package-name lst1)) + (name2 (package-name lst2)) + (version1 (package-version lst1)) + (version2 (package-version lst2))) + (and name1 name2 (or (string>? name1 name2) + (and (string=? name1 name2) + version1 + version2 + (version>? version2 version1)))))) + + ;; Group define-public with preceding blanks and defines. + (let ((lst (fold2 (lambda (expr tail head) + (let ((head (cons expr head))) + (match expr + ((? blank?) + (values tail head)) + (('define _ ...) + (values tail head)) + (_ (values (cons head tail) '()))))) + '() '() lst))) + (reverse (concatenate (sort! lst package>?))))) + +(define* (format-whole-file file order? #:rest rest) + "Reformat all of FILE. When ORDER? is true, top-level package definitions +are put in alphabetical order." (with-fluids ((%default-port-encoding "UTF-8")) - (let ((lst (call-with-input-file file read-with-comments/sequence - #:guess-encoding #t))) + (let* ((lst (call-with-input-file file read-with-comments/sequence + #:guess-encoding #t)) + (lst (if order? + (order-packages lst) + lst))) (with-atomic-file-output file (lambda (port) (apply pretty-print-with-comments/splice port lst @@ -526,6 +579,9 @@ bailing out~%")) (option '(#\f "whole-file") #f #f (lambda (opt name arg result) (alist-cons 'whole-file? #t result))) + (option '(#\A "alphabetical-sort") #f #f + (lambda (opt name arg result) + (alist-cons 'order? #t result))) (option '(#\S "styling") #t #f (lambda (opt name arg result) (alist-cons 'styling-procedure @@ -569,7 +625,7 @@ Update package definitions to the latest style.\n")) (display (G_ " -S, --styling=RULE apply RULE, a styling rule")) (display (G_ " - -l, --list-stylings display the list of available style rules")) + -l, --list-stylings display the list of available style rules")) (newline) (display (G_ " -n, --dry-run display files that would be edited but do nothing")) @@ -584,6 +640,9 @@ Update package definitions to the latest style.\n")) (newline) (display (G_ " -f, --whole-file format the entire contents of the given file(s)")) + (display (G_ " + -A, --alphabetical-sort + place the contents in alphabetical order as well")) (newline) (display (G_ " -h, --help display this help and exit")) @@ -627,7 +686,9 @@ Update package definitions to the latest style.\n")) (warning (G_ "'--styling' option has no effect in whole-file mode~%"))) (when (null? files) (warning (G_ "no files specified, nothing to do~%"))) - (for-each format-whole-file files)) + (for-each + (cute format-whole-file <> (assoc-ref opts 'order?)) + files)) (let ((packages (filter-map (match-lambda (('argument . spec) (specification->package spec)) diff --git a/guix/scripts/substitute.scm b/guix/scripts/substitute.scm index a7ad56dbcd..8db730a9c0 100755 --- a/guix/scripts/substitute.scm +++ b/guix/scripts/substitute.scm @@ -43,7 +43,11 @@ #:select (uri-abbreviation nar-uri-abbreviation (open-connection-for-uri . guix:open-connection-for-uri))) - #:autoload (gnutls) (error/invalid-session error/again error/interrupted) + #:autoload (gnutls) (error/invalid-session + error/again + error/interrupted + error/push-error + error/pull-error) #:use-module (guix progress) #:use-module ((guix build syscalls) #:select (set-thread-name)) @@ -77,7 +81,7 @@ (define %narinfo-expired-cache-entry-removal-delay ;; How often we want to remove files corresponding to expired cache entries. - (* 7 24 3600)) + (* 5 24 3600)) (define (warn-about-missing-authentication) (warning (G_ "authentication and authorization of substitutes \ @@ -169,8 +173,9 @@ was found." "Return the expiration time for FILE, which is a cached narinfo." (define max-ttl ;; Upper bound on the TTL used to avoid keeping around cached narinfos for - ;; too long, which makes the cache bigger and more expensive to traverse. - (* 2 30 24 60 60)) ;2 months + ;; too long, which makes the cache bigger and more expensive to traverse + ;; when deleting old entries. + (* 2 24 60 60)) (catch 'system-error (lambda () @@ -425,6 +430,11 @@ server certificates." (memq (first args) (list error/invalid-session + ;; "Error in the push function" is + ;; usually a transient error. + error/push-error + error/pull-error + ;; XXX: These two are not properly handled in ;; GnuTLS < 3.7.3, in ;; 'write_to_session_record_port'; see diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm index 2260bcf985..dd34f6cd15 100644 --- a/guix/scripts/system.scm +++ b/guix/scripts/system.scm @@ -5,7 +5,7 @@ ;;; Copyright © 2017, 2019 Mathieu Othacehe <m.othacehe@gmail.com> ;;; Copyright © 2018 Ricardo Wurmus <rekado@elephly.net> ;;; Copyright © 2019 Christopher Baines <mail@cbaines.net> -;;; Copyright © 2020 Jan (janneke) Nieuwenhuizen <janneke@gnu.org> +;;; Copyright © 2020, 2024 Janneke Nieuwenhuizen <janneke@gnu.org> ;;; Copyright © 2020 Julien Lepiller <julien@lepiller.eu> ;;; Copyright © 2020 Efraim Flashner <efraim@flashner.co.il> ;;; Copyright © 2021 Brice Waegeneire <brice@waegenei.re> @@ -56,6 +56,7 @@ delete-matching-generations list-installed) #:autoload (guix scripts pull) (channel-commit-hyperlink) + #:autoload (guix scripts system installer) (guix-system-installer) #:autoload (guix graph) (export-graph node-type graph-backend-name lookup-backend) #:use-module (guix scripts system reconfigure) @@ -63,6 +64,7 @@ #:autoload (guix progress) (progress-reporter/bar call-with-progress-reporter) #:use-module ((guix docker) #:select (%docker-image-max-layers)) + #:use-module (gnu build hurd-boot) #:use-module (gnu build image) #:use-module (gnu build install) #:autoload (gnu build file-systems) @@ -243,6 +245,9 @@ the ownership of '~a' may be incorrect!~%") (delete-file-recursively state))) (chmod target #o755) + ;; For the Hurd to boot, it needs some essential device nodes. + (when (target-hurd?) + (make-hurd-device-nodes target)) (let ((os-dir (derivation->output-path os-drv)) (format (lift format %store-monad)) (populate (lift2 populate-root-file-system %store-monad))) @@ -591,7 +596,8 @@ any, are available. Raise an error if they're not." (not (member (file-system-type fs) %pseudo-file-system-types)) ;; Don't try to validate network file systems. - (not (string-prefix? "nfs" (file-system-type fs))) + (not (or (string-prefix? "nfs" (file-system-type fs)) + (string-prefix? "cifs" (file-system-type fs)))) (not (memq 'bind-mount (file-system-flags fs))))) file-systems)) @@ -992,6 +998,8 @@ Some ACTIONS support additional ARGS.\n")) (display (G_ "\ init initialize a root file system to run GNU\n")) (display (G_ "\ + installer run the graphical installer\n")) + (display (G_ "\ extension-graph emit the service extension graph in Dot format\n")) (display (G_ "\ shepherd-graph emit the graph of shepherd services in Dot format\n")) @@ -1224,7 +1232,7 @@ Some ACTIONS support additional ARGS.\n")) "list-generations" "describe" "delete-generations" "roll-back" "switch-generation" "search" "edit" - "docker-image")) + "docker-image" "installer")) (define (process-action action args opts) "Process ACTION, a sub-command, with the arguments are listed in ARGS. @@ -1436,6 +1444,8 @@ argument list and OPTS is the option alist." ;; Parse sub-command ARG and augment RESULT accordingly. (cond ((assoc-ref result 'action) (alist-cons 'argument arg result)) + ((equal? arg "installer") + (apply guix-system-installer args)) ((member arg actions) (let ((action (string->symbol arg))) (alist-cons 'action action result))) diff --git a/guix/scripts/system/installer.scm b/guix/scripts/system/installer.scm new file mode 100644 index 0000000000..48baaefe42 --- /dev/null +++ b/guix/scripts/system/installer.scm @@ -0,0 +1,70 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2024 Janneke Nieuwenhuizen <janneke@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 scripts system installer) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-37) + #:use-module (gnu installer) + #:use-module (guix scripts) + #:use-module (guix ui) + #:use-module (guix utils) + #:export (guix-system-installer)) + +;;; Commentary: +;;; +;;; Implement the 'guix system installer' command, which runs the installer, +;;; directly as a Guix command, also in dry-run mode. +;;; +;;; Code: + +(define %options + (list (option '(#\n "dry-run") #f #f + (lambda (opt name arg result) + (alist-cons 'dry-run? #t result))) + (option '(#\h "help") #f #f + (lambda args + (show-help) + (exit 0))) + (option '(#\V "version") #f #f + (lambda args + (show-version-and-exit "guix system installer"))))) + +(define (show-help) + (display (G_ "Usage: guix system installer [OPTION]... +Run the system installler.\n")) + (display (G_ " + -n, --dry-run skip network setup, partitioning, and actual install")) + (display (G_ " + -h, --help display this help and exit")) + (display (G_ " + -V, --version display version information and exit")) + (newline) + (show-bug-report-information)) + + +;;; +;;; Entry Point. +;;; +(define-command (guix-system-installer . args) + (synopsis "run the graphical installer program") + + (with-error-handling + (let* ((opts (parse-command-line args %options '((dry-run? . #f)) + #:build-options? #f)) + (dry-run? (assoc-ref opts 'dry-run?))) + (run-installer #:dry-run? dry-run?)))) diff --git a/guix/scripts/system/reconfigure.scm b/guix/scripts/system/reconfigure.scm index 604ba08fee..ddb561d28c 100644 --- a/guix/scripts/system/reconfigure.scm +++ b/guix/scripts/system/reconfigure.scm @@ -7,6 +7,7 @@ ;;; Copyright © 2019 Christopher Baines <mail@cbaines.net> ;;; Copyright © 2019 Jakob L. Kreuze <zerodaysfordays@sdf.org> ;;; Copyright © 2022 Arun Isaac <arunisaac@systemreboot.net> +;;; Copyright © 2024 Janneke Nieuwenhuizen <janneke@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -299,7 +300,7 @@ additional configurations specified by MENU-ENTRIES can be selected." (eval #~(parameterize ((current-warning-port (%make-void-port "w"))) (primitive-load #$(install-bootloader-program installer disk-installer - package + #~#+package bootcfg bootcfg-file devices diff --git a/guix/scripts/time-machine.scm b/guix/scripts/time-machine.scm index d9ce85df84..21145239d4 100644 --- a/guix/scripts/time-machine.scm +++ b/guix/scripts/time-machine.scm @@ -52,8 +52,10 @@ ;;; (define (show-help) - (display (G_ "Usage: guix time-machine [OPTION] -- COMMAND ARGS... -Execute COMMAND ARGS... in an older version of Guix.\n")) + (display (G_ "Usage: guix time-machine [OPTION] [-- COMMAND ARGS...] +Execute COMMAND ARGS... in an older version of Guix. + +If COMMAND is not provided, print path to the time-machine profile.\n")) (display (G_ " -C, --channels=FILE deploy the channels defined in FILE")) (display (G_ " @@ -179,22 +181,22 @@ to %OLDEST-POSSIBLE-COMMIT is not that of an ancestor." (ref (assoc-ref opts 'ref)) (substitutes? (assoc-ref opts 'substitutes?)) (authenticate? (assoc-ref opts 'authenticate-channels?))) - (if command-line - (let* ((directory - (with-store store - (with-status-verbosity (assoc-ref opts 'verbosity) - (with-build-handler (build-notifier #:use-substitutes? - substitutes? - #:verbosity - (assoc-ref opts 'verbosity) - #:dry-run? #f) - (set-build-options-from-command-line store opts) - (cached-channel-instance store channels - #:authenticate? authenticate? - #:reference-channels - %reference-channels - #:validate-channels - validate-guix-channel))))) - (executable (string-append directory "/bin/guix"))) - (apply execl (cons* executable executable command-line))) - (warning (G_ "no command specified; nothing to do~%"))))))) + (let* ((directory + (with-store store + (with-status-verbosity (assoc-ref opts 'verbosity) + (with-build-handler (build-notifier #:use-substitutes? + substitutes? + #:verbosity + (assoc-ref opts 'verbosity) + #:dry-run? #f) + (set-build-options-from-command-line store opts) + (cached-channel-instance store channels + #:authenticate? authenticate? + #:reference-channels + %reference-channels + #:validate-channels + validate-guix-channel))))) + (executable (string-append directory "/bin/guix"))) + (if command-line + (apply execl (cons* executable executable command-line)) + (format #t "~a\n" directory))))))) diff --git a/guix/scripts/weather.scm b/guix/scripts/weather.scm index 08a1b22a74..29432fd923 100644 --- a/guix/scripts/weather.scm +++ b/guix/scripts/weather.scm @@ -55,21 +55,6 @@ #:use-module (ice-9 vlist) #:export (guix-weather)) -(define (all-packages) - "Return the list of public packages we are going to query." - (delete-duplicates - (fold-packages (lambda (package result) - (match (package-replacement package) - ((? package? replacement) - (cons* replacement package result)) - (#f - (cons package result)))) - '() - - ;; Dismiss deprecated packages but keep hidden packages. - #:select? (negate package-superseded)) - eq?)) - (define (call-with-progress-reporter reporter proc) "This is a variant of 'call-with-progress-reporter' that works with monadic scope." diff --git a/guix/search-paths.scm b/guix/search-paths.scm index 5375fae34b..27fcb78054 100644 --- a/guix/search-paths.scm +++ b/guix/search-paths.scm @@ -35,6 +35,8 @@ $CPLUS_INCLUDE_PATH $C_INCLUDE_PATH + $OBJC_INCLUDE_PATH + $OBJCPLUS_INCLUDE_PATH $LIBRARY_PATH $GUIX_EXTENSIONS_PATH $PATH @@ -42,8 +44,11 @@ $SSL_CERT_DIR $SSL_CERT_FILE $TZDIR + $SGML_CATALOG_FILES + $XML_CATALOG_FILES %gcc-search-paths + %libxslt-search-paths search-path-specification->sexp sexp->search-path-specification @@ -75,18 +80,30 @@ (file-pattern search-path-specification-file-pattern ;#f | string (default #f))) -(define $C_INCLUDE_PATH +(define $CPLUS_INCLUDE_PATH (search-path-specification (variable "CPLUS_INCLUDE_PATH") ;; Add 'include/c++' here so that <cstdlib>'s "#include_next ;; <stdlib.h>" finds GCC's <stdlib.h>, not libc's. (files '("include/c++" "include")))) -(define $CPLUS_INCLUDE_PATH +(define $C_INCLUDE_PATH (search-path-specification (variable "C_INCLUDE_PATH") (files '("include")))) +(define $OBJC_INCLUDE_PATH + (search-path-specification + (variable "OBJC_INCLUDE_PATH") + (files '("include")))) + +(define $OBJCPLUS_INCLUDE_PATH + (search-path-specification + (variable "OBJCPLUS_INCLUDE_PATH") + ;; Add 'include/c++' here so that <cstdlib>'s "#include_next + ;; <stdlib.h>" finds GCC's <stdlib.h>, not libc's. + (files '("include/c++" "include")))) + (define $LIBRARY_PATH (search-path-specification (variable "LIBRARY_PATH") @@ -100,6 +117,8 @@ ;; the typical /usr/include headers on an FHS system. (list $C_INCLUDE_PATH $CPLUS_INCLUDE_PATH + $OBJC_INCLUDE_PATH + $OBJCPLUS_INCLUDE_PATH $LIBRARY_PATH)) (define $PATH @@ -154,6 +173,32 @@ (files '("share/zoneinfo")) (separator #f))) ;single entry +;; Some packages (notably libxml2) make use of 'XML_CATALOG_FILES' +;; and 'SGML_CATALOG_FILES' for remapping URI references or public/system +;; identifiers to other URI references. +(define $SGML_CATALOG_FILES + ;; $SGML_CATALOG_FILES lists 'catalog' or 'CATALOG' or '*.cat' files found + ;; under the 'sgml' sub-directory of any given package. + (search-path-specification + (variable "SGML_CATALOG_FILES") + (separator ":") + (files '("sgml")) + (file-pattern "^catalog$|^CATALOG$|^.*\\.cat$") + (file-type 'regular))) + +(define $XML_CATALOG_FILES + ;; $XML_CATALOG_FILES lists 'catalog.xml' files found in under the 'xml' + ;; sub-directory of any given package. + (search-path-specification + (variable "XML_CATALOG_FILES") + (separator " ") + (files '("xml")) + (file-pattern "^catalog\\.xml$") + (file-type 'regular))) + +(define %libxslt-search-paths + (list $SGML_CATALOG_FILES $XML_CATALOG_FILES)) + (define (search-path-specification->sexp spec) "Return an sexp representing SPEC, a <search-path-specification>. The sexp corresponds to the arguments expected by `set-path-environment-variable'." diff --git a/guix/self.scm b/guix/self.scm index 8c85684090..2652688c71 100644 --- a/guix/self.scm +++ b/guix/self.scm @@ -2,6 +2,7 @@ ;;; Copyright © 2017-2023 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2020 Martin Becze <mjbecze@riseup.net> ;;; Copyright © 2023 Janneke Nieuwenhuizen <janneke@gnu.org> +;;; Copyright © 2024 gemmaro <gemmaro.dev@gmail.com> ;;; ;;; This file is part of GNU Guix. ;;; @@ -317,9 +318,14 @@ DOMAIN, a gettext domain." (define (translate-tmp-texi po source output) "Translate Texinfo file SOURCE using messages from PO, and write the result to OUTPUT." - (invoke #+(file-append po4a-minimal "/bin/po4a-translate") - "-M" "UTF-8" "-L" "UTF-8" "-k" "0" "-f" "texinfo" - "-m" source "-p" po "-l" output)) + (invoke #+(file-append po4a-minimal "/bin/po4a") + "--no-update" + "--variable" (string-append "localized=" output) + "--variable" (string-append "master=" source) + "--variable" (string-append "po=" po) + "--variable" (string-append "pot=" (string-append (tmpnam) ".pot")) + "--destdir=." + #+(file-append documentation-po "/po4a.cfg"))) (define (canonicalize-whitespace str) ;; Change whitespace (newlines, etc.) in STR to #\space. diff --git a/guix/store.scm b/guix/store.scm index 58ddaa8d15..cf5848e580 100644 --- a/guix/store.scm +++ b/guix/store.scm @@ -524,54 +524,49 @@ non-blocking." (errno (system-error-errno args))))) (loop rest))))))))) -(define* (connect-to-daemon uri #:key non-blocking?) - "Connect to the daemon at URI, a string that may be an actual URI or a file -name, and return an input/output port. If NON-BLOCKING?, use a non-blocking -socket when using the file, unix or guix URI schemes. +(define* (connect-to-daemon uri-or-filename #:key non-blocking?) + "Connect to the daemon at URI-OR-FILENAME and return an input/output port. +If NON-BLOCKING?, use a non-blocking socket when using the file, unix or guix +URI schemes. This is a low-level procedure that does not perform the initial handshake with the daemon. Use 'open-connection' for that." (define (not-supported) (raise (condition (&store-connection-error - (file uri) + (file uri-or-filename) (errno ENOTSUP))))) - (define connect - (match (string->uri uri) - (#f ;URI is a file name - open-unix-domain-socket) - ((? uri? uri) - (match (uri-scheme uri) - ((or #f 'file 'unix) - (lambda (_) - (open-unix-domain-socket (uri-path uri) - #:non-blocking? non-blocking?))) - ('guix - (lambda (_) - (open-inet-socket (uri-host uri) - (or (uri-port uri) %default-guix-port) - #:non-blocking? non-blocking?))) - ((? symbol? scheme) - ;; Try to dynamically load a module for SCHEME. - ;; XXX: Errors are swallowed. - (match (false-if-exception - (resolve-interface `(guix store ,scheme))) - ((? module? module) - (match (false-if-exception - (module-ref module 'connect-to-daemon)) - ((? procedure? connect) - (lambda (_) - (connect uri))) - (x (not-supported)))) - (#f (not-supported)))) - (x - (not-supported)))))) - - (connect uri)) + (match (string->uri uri-or-filename) + (#f ;URI is a file name + (open-unix-domain-socket uri-or-filename + #:non-blocking? non-blocking?)) + ((? uri? uri) + (match (uri-scheme uri) + ((or #f 'file 'unix) + (open-unix-domain-socket (uri-path uri) + #:non-blocking? non-blocking?)) + ('guix + (open-inet-socket (uri-host uri) + (or (uri-port uri) %default-guix-port) + #:non-blocking? non-blocking?)) + ((? symbol? scheme) + ;; Try to dynamically load a module for SCHEME. + ;; XXX: Errors are swallowed. + (match (false-if-exception + (resolve-interface `(guix store ,scheme))) + ((? module? module) + (match (false-if-exception + (module-ref module 'connect-to-daemon)) + ((? procedure? connect) + (connect uri)) + (x (not-supported)))) + (#f (not-supported)))) + (x + (not-supported)))))) (define* (open-connection #:optional (uri (%daemon-socket-uri)) #:key port (reserve-space? #t) cpu-affinity - non-blocking?) + non-blocking? built-in-builders) "Connect to the daemon at URI (a string), or, if PORT is not #f, use it as the I/O port over which to communicate to a build daemon. @@ -580,8 +575,10 @@ space on the file system so that the garbage collector can still operate, should the disk become full. When CPU-AFFINITY is true, it must be an integer corresponding to an OS-level CPU number to which the daemon's worker process for this connection will be pinned. If NON-BLOCKING?, use a non-blocking -socket when using the file, unix or guix URI schemes. Return a server -object." +socket when using the file, unix or guix URI schemes. If +BUILT-IN-BUILDERS is provided, it should be a list of strings +and this will be used instead of the builtin builders provided by the build +daemon. Return a server object." (define (handshake-error) (raise (condition (&store-connection-error (file (or port uri)) @@ -615,8 +612,10 @@ object." (write-int cpu-affinity port))) (when (>= (protocol-minor v) 11) (write-int (if reserve-space? 1 0) port)) - (letrec* ((built-in-builders - (delay (%built-in-builders conn))) + (letrec* ((actual-built-in-builders + (if built-in-builders + (delay built-in-builders) + (delay (%built-in-builders conn)))) (caches (make-vector (atomic-box-ref %store-connection-caches) @@ -629,15 +628,19 @@ object." (make-hash-table 100) (make-hash-table 100) caches - built-in-builders))) + actual-built-in-builders))) (let loop ((done? (process-stderr conn))) (or done? (process-stderr conn))) conn)))))) (define* (port->connection port - #:key (version %protocol-version)) + #:key (version %protocol-version) + built-in-builders) "Assimilate PORT, an input/output port, and return a connection to the -daemon, assuming the given protocol VERSION. +daemon, assuming the given protocol VERSION. If +BUILT-IN-BUILDERS is provided, it should be a list of strings +and this will be used instead of the builtin builders provided by the build +daemon. Warning: this procedure assumes that the initial handshake with the daemon has already taken place on PORT and that we're just continuing on this established @@ -654,7 +657,9 @@ connection. Use with care." (make-vector (atomic-box-ref %store-connection-caches) vlist-null) - (delay (%built-in-builders connection)))) + (if built-in-builders + (delay built-in-builders) + (delay (%built-in-builders connection))))) connection)) diff --git a/guix/store/deduplication.scm b/guix/store/deduplication.scm index 129574c073..2005653c95 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-2022 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2018-2022, 2024 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -28,6 +28,7 @@ #:use-module (srfi srfi-11) #:use-module (srfi srfi-34) #:use-module (srfi srfi-35) + #:use-module (rnrs bytevectors) #:use-module (rnrs io ports) #:use-module (ice-9 match) #:use-module (guix serialization) @@ -206,6 +207,48 @@ under STORE." #f) (else (apply throw args))))))))))) +(define (hole-size bv start size) + "Return a lower bound of the number of leading zeros in the first SIZE bytes +of BV, starting at offset START." + (let ((end (+ start size))) + (let loop ((offset start)) + (if (> offset (- end 4)) + (- offset start) + (if (zero? (bytevector-u32-native-ref bv offset)) + (loop (+ offset 4)) + (- offset start)))))) + +(define (find-holes bv start size) + "Return the list of offset/size pairs representing \"holes\" (sequences of +zeros) in the SIZE bytes starting at START in BV." + (define granularity + ;; Disk block size is traditionally 512 bytes; focus on larger holes to + ;; reduce the computational effort. + 1024) + + (define (align offset) + (match (modulo offset granularity) + (0 offset) + (mod (+ offset (- granularity mod))))) + + (define end + (+ start size)) + + (let loop ((offset start) + (size size) + (holes '())) + (if (>= offset end) + (reverse! holes) + (let ((hole (hole-size bv offset size))) + (if (and hole (>= hole granularity)) + (let ((next (align (+ offset hole)))) + (loop next + (- size (- next offset)) + (cons (cons offset hole) holes))) + (loop (+ offset granularity) + (- size granularity) + holes)))))) + (define (tee input len output) "Return a port that reads up to LEN bytes from INPUT and writes them to OUTPUT as it goes." @@ -217,6 +260,10 @@ OUTPUT as it goes." (&nar-error (port input) (file (port-filename output)))))) + (define seekable? + ;; Whether OUTPUT can be a sparse file. + (file-port? output)) + (define (read! bv start count) ;; Read at most LEN bytes in total. (let ((count (min count (- len bytes-read)))) @@ -229,7 +276,35 @@ OUTPUT as it goes." ;; Do not return zero since zero means EOF, so try again. (loop (get-bytevector-n! input bv start count))) (else - (put-bytevector output bv start ret) + (if seekable? + ;; Render long-enough sequences of zeros as "holes". + (match (find-holes bv start ret) + (() + (put-bytevector output bv start ret)) + (holes + (let loop ((offset start) + (size ret) + (holes holes)) + (match holes + (() + (if (> size 0) + (put-bytevector output bv offset size) + (when (= len (+ bytes-read ret)) + ;; We created a hole in OUTPUT by seeking + ;; forward but that hole only comes into + ;; existence if we write something after it. + ;; Make the hole one byte smaller and write a + ;; final zero. + (seek output -1 SEEK_CUR) + (put-u8 output 0)))) + (((hole-start . hole-size) . rest) + (let ((prefix-len (- hole-start offset))) + (put-bytevector output bv offset prefix-len) + (seek output hole-size SEEK_CUR) + (loop (+ hole-start hole-size) + (- size prefix-len hole-size) + rest))))))) + (put-bytevector output bv start ret)) (set! bytes-read (+ bytes-read ret)) ret))))) diff --git a/guix/substitutes.scm b/guix/substitutes.scm index e732096933..e31b394020 100644 --- a/guix/substitutes.scm +++ b/guix/substitutes.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2013-2021, 2023 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2013-2021, 2023-2024 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> @@ -65,11 +65,11 @@ (define %narinfo-negative-ttl ;; Likewise, but for negative lookups---i.e., cached lookup failures (404). - (* 10 60)) + (* 2 60)) (define %narinfo-transient-error-ttl ;; Likewise, but for transient errors such as 504 ("Gateway timeout"). - (* 5 60)) + (* 1 60)) (define %narinfo-cache-directory ;; A local cache of narinfos, to avoid going to the network. Most of the diff --git a/guix/svn-download.scm b/guix/svn-download.scm index bdd9c39eb5..b20cdc79d1 100644 --- a/guix/svn-download.scm +++ b/guix/svn-download.scm @@ -30,6 +30,7 @@ #:use-module ((guix build utils) #:select (mkdir-p)) #:use-module (ice-9 match) #:use-module (srfi srfi-1) + #:use-module (rnrs bytevectors) #:export (svn-reference svn-reference? svn-reference-url @@ -73,14 +74,7 @@ (let ((distro (resolve-interface '(gnu packages version-control)))) (module-ref distro 'subversion))) -(define* (svn-fetch ref hash-algo hash - #:optional name - #:key (system (%current-system)) (guile (default-guile)) - (svn (subversion-package))) - "Return a fixed-output derivation that fetches REF, a <svn-reference> -object. The output is expected to have recursive hash HASH of type -HASH-ALGO (a symbol). Use NAME as the file name, or a generic name if #f." - +(define (svn-fetch-builder svn hash-algo) (define guile-json (module-ref (resolve-interface '(gnu packages guile)) 'guile-json-4)) @@ -96,51 +90,64 @@ HASH-ALGO (a symbol). Use NAME as the file name, or a generic name if #f." (module-ref (resolve-interface '(gnu packages base)) 'tar))) - (define build - (with-imported-modules - (source-module-closure '((guix build svn) - (guix build download) - (guix build download-nar) - (guix build utils) - (guix swh))) - (with-extensions (list guile-json guile-gnutls ;for (guix swh) - guile-lzlib) - #~(begin - (use-modules (guix build svn) - ((guix build download) - #:select (download-method-enabled?)) - (guix build download-nar) - (guix build utils) - (guix swh) - (ice-9 match)) + (with-imported-modules + (source-module-closure '((guix build svn) + (guix build download) + (guix build download-nar) + (guix build utils) + (guix swh))) + (with-extensions (list guile-json guile-gnutls ;for (guix swh) + guile-lzlib) + #~(begin + (use-modules (guix build svn) + ((guix build download) + #:select (download-method-enabled?)) + (guix build download-nar) + (guix build utils) + (guix swh) + (ice-9 match)) - ;; Add tar and gzip to $PATH so - ;; 'swh-download-directory-by-nar-hash' can invoke them. - (set-path-environment-variable "PATH" '("bin") '(#+@tar+gzip)) + ;; Add tar and gzip to $PATH so + ;; 'swh-download-directory-by-nar-hash' can invoke them. + (set-path-environment-variable "PATH" '("bin") '(#+@tar+gzip)) - (or (and (download-method-enabled? 'upstream) - (svn-fetch (getenv "svn url") - (string->number (getenv "svn revision")) - #$output - #: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"))) - (and (download-method-enabled? 'nar) - (download-nar #$output)) - (and (download-method-enabled? 'swh) - (parameterize ((%verify-swh-certificate? #f)) - (swh-download-directory-by-nar-hash #$hash '#$hash-algo - #$output)))))))) + (or (and (download-method-enabled? 'upstream) + (svn-fetch (getenv "svn url") + (string->number (getenv "svn revision")) + #$output + #: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"))) + (and (download-method-enabled? 'nar) + (download-nar #$output)) + (and (download-method-enabled? 'swh) + (parameterize ((%verify-swh-certificate? #f)) + (swh-download-directory-by-nar-hash + (u8-list->bytevector + (map string->number + (string-split (getenv "hash") #\,))) + '#$hash-algo + #$output)))))))) +(define* (svn-fetch ref hash-algo hash + #:optional name + #:key (system (%current-system)) (guile (default-guile)) + (svn (subversion-package))) + "Return a fixed-output derivation that fetches REF, a <svn-reference> +object. The output is expected to have recursive hash HASH of type +HASH-ALGO (a symbol). Use NAME as the file name, or a generic name if #f." (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. + (gexp->derivation (or name "svn-checkout") + ;; Avoid the builder differing for every single use as + ;; having less builder is more efficient for computing + ;; derivations. + ;; + ;; Don't pass package specific data in to the following + ;; procedure, use #:env-vars below instead. + (svn-fetch-builder svn hash-algo) #:script-name "svn-download" #:env-vars `(("svn url" . ,(svn-reference-url ref)) @@ -160,7 +167,14 @@ HASH-ALGO (a symbol). Use NAME as the file name, or a generic name if #f." ,@(match (getenv "GUIX_DOWNLOAD_METHODS") (#f '()) (value - `(("GUIX_DOWNLOAD_METHODS" . ,value))))) + `(("GUIX_DOWNLOAD_METHODS" . ,value)))) + ;; To avoid pulling in (guix base32) in the builder + ;; script, use bytevector->u8-list from (rnrs + ;; bytevectors) + ("hash" . ,(string-join + (map number->string + (bytevector->u8-list hash)) + ","))) #:system system #:hash-algo hash-algo @@ -179,14 +193,7 @@ HASH-ALGO (a symbol). Use NAME as the file name, or a generic name if #f." (user-name svn-multi-reference-user-name (default #f)) (password svn-multi-reference-password (default #f))) -(define* (svn-multi-fetch ref hash-algo hash - #:optional name - #:key (system (%current-system)) (guile (default-guile)) - (svn (subversion-package))) - "Return a fixed-output derivation that fetches REF, a <svn-multi-reference> -object. The output is expected to have recursive hash HASH of type -HASH-ALGO (a symbol). Use NAME as the file name, or a generic name if #f." - +(define (svn-multi-fetch-builder svn hash-algo) (define guile-json (module-ref (resolve-interface '(gnu packages guile)) 'guile-json-4)) @@ -202,69 +209,83 @@ HASH-ALGO (a symbol). Use NAME as the file name, or a generic name if #f." (module-ref (resolve-interface '(gnu packages base)) 'tar))) - (define build - (with-imported-modules - (source-module-closure '((guix build svn) - (guix build download) - (guix build download-nar) - (guix build utils) - (guix swh))) - (with-extensions (list guile-json guile-gnutls ;for (guix swh) - guile-lzlib) - #~(begin - (use-modules (guix build svn) - (guix build utils) - ((guix build download) - #:select (download-method-enabled?)) - (guix build download-nar) - (guix swh) - (srfi srfi-1) - (ice-9 match)) + (with-imported-modules + (source-module-closure '((guix build svn) + (guix build download) + (guix build download-nar) + (guix build utils) + (guix swh))) + (with-extensions (list guile-json guile-gnutls ;for (guix swh) + guile-lzlib) + #~(begin + (use-modules (guix build svn) + (guix build utils) + ((guix build download) + #:select (download-method-enabled?)) + (guix build download-nar) + (guix swh) + (srfi srfi-1) + (ice-9 match) + (rnrs bytevectors)) - ;; Add tar and gzip to $PATH so - ;; 'swh-download-directory-by-nar-hash' can invoke them. - (set-path-environment-variable "PATH" '("bin") '(#+@tar+gzip)) + ;; Add tar and gzip to $PATH so + ;; 'swh-download-directory-by-nar-hash' can invoke them. + (set-path-environment-variable "PATH" '("bin") '(#+@tar+gzip)) - (or (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)))) - (and (download-method-enabled? 'upstream) - (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)) - (begin - (when (file-exists? #$output) - (delete-file-recursively #$output)) - (or (and (download-method-enabled? 'nar) - (download-nar #$output)) - (and (download-method-enabled? 'swh) - ;; SWH keeps HASH as an ExtID for the combination - ;; of files/directories, which allows us to - ;; retrieve the entire combination at once: - ;; <https://gitlab.softwareheritage.org/swh/infra/sysadm-environment/-/issues/5263>. - (parameterize ((%verify-swh-certificate? #f)) - (swh-download-directory-by-nar-hash - #$hash '#$hash-algo #$output)))))))))) + (or (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)))) + (and (download-method-enabled? 'upstream) + (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)) + (begin + (when (file-exists? #$output) + (delete-file-recursively #$output)) + (or (and (download-method-enabled? 'nar) + (download-nar #$output)) + (and (download-method-enabled? 'swh) + ;; SWH keeps HASH as an ExtID for the combination + ;; of files/directories, which allows us to + ;; retrieve the entire combination at once: + ;; <https://gitlab.softwareheritage.org/swh/infra/sysadm-environment/-/issues/5263>. + (parameterize ((%verify-swh-certificate? #f)) + (swh-download-directory-by-nar-hash + (u8-list->bytevector + (map string->number + (string-split (getenv "hash") #\,))) + '#$hash-algo + #$output)))))))))) +(define* (svn-multi-fetch ref hash-algo hash + #:optional name + #:key (system (%current-system)) (guile (default-guile)) + (svn (subversion-package))) + "Return a fixed-output derivation that fetches REF, a <svn-multi-reference> +object. The output is expected to have recursive hash HASH of type +HASH-ALGO (a symbol). Use NAME as the file name, or a generic name if #f." (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. + (gexp->derivation (or name "svn-checkout") + ;; Avoid the builder differing for every single use as + ;; having less builder is more efficient for computing + ;; derivations. + ;; + ;; Don't pass package specific data in to the following + ;; procedure, use #:env-vars below instead. + (svn-multi-fetch-builder svn hash-algo) #:script-name "svn-multi-download" #:env-vars `(("svn url" . ,(svn-multi-reference-url ref)) @@ -286,7 +307,14 @@ HASH-ALGO (a symbol). Use NAME as the file name, or a generic name if #f." ,@(match (getenv "GUIX_DOWNLOAD_METHODS") (#f '()) (value - `(("GUIX_DOWNLOAD_METHODS" . ,value))))) + `(("GUIX_DOWNLOAD_METHODS" . ,value)))) + ;; To avoid pulling in (guix base32) in the builder + ;; script, use bytevector->u8-list from (rnrs + ;; bytevectors) + ("hash" . ,(string-join + (map number->string + (bytevector->u8-list hash)) + ","))) #:leaked-env-vars '("http_proxy" "https_proxy" "LC_ALL" "LC_MESSAGES" "LANG" @@ -323,21 +351,29 @@ reports to LOG." reports to LOG." (call-with-temporary-directory (lambda (temp) - (and (every (lambda (location) - (let ((dir (string-append temp "/" (dirname location)))) - (mkdir-p dir)) - (parameterize ((current-output-port log)) - (build:svn-fetch (string-append (svn-multi-reference-url ref) - "/" location) - (svn-multi-reference-revision ref) - (if (string-suffix? "/" location) - (string-append temp "/" location) - (string-append temp "/" (dirname location))) - #:recursive? - (svn-multi-reference-recursive? ref) - #:user-name (svn-multi-reference-user-name ref) - #:password (svn-multi-reference-password ref)))) - (svn-multi-reference-locations ref)) - (add-to-store store name #t "sha256" temp))))) + ;; When "svn" is called, TEMP already exists. As a consequence, "svn" + ;; refuses to export files there, assuming it would overwrite a previous + ;; export. It can be an issue if locations includes files at SVN URL. + ;; To circumvent this, export in a fresh sub-directory. + (let ((output (string-append temp "/svn"))) + (mkdir-p output) + (and (every (lambda (location) + (unless (string-suffix? "/" location) + (mkdir-p (string-append output "/" (dirname location)))) + (parameterize ((current-output-port log)) + (build: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))) + #:recursive? + (svn-multi-reference-recursive? ref) + #:user-name (svn-multi-reference-user-name ref) + #:password (svn-multi-reference-password ref)))) + (svn-multi-reference-locations ref)) + (add-to-store store name #t "sha256" output)))))) ;;; svn-download.scm ends here diff --git a/guix/swh.scm b/guix/swh.scm index f602cd89d1..fd17b04b75 100644 --- a/guix/swh.scm +++ b/guix/swh.scm @@ -165,10 +165,16 @@ (define url (string-append root (string-join rest "/" 'prefix))) - ;; Ensure there's a trailing slash or we get a redirect. - (if (string-suffix? "/" url) - url - (string-append url "/"))) + (define (contains-parameters? url) + (match (string-rindex url #\/) + (#f #f) + (offset (string-index (string-drop url (+ 1 offset)) #\?)))) + + ;; Ensure there's a trailing slash or we get a redirect. Don't do that if + ;; URL contains parameters. + (cond ((string-suffix? "/" url) url) + ((contains-parameters? url) url) + (else (string-append url "/")))) ;; XXX: Work around a bug in Guile 3.0.2 where #:verify-certificate? would ;; be ignored (<https://bugs.gnu.org/40486>). @@ -460,8 +466,11 @@ FALSE-IF-404? is true, return #f upon 404 responses." "Return the external ID record for ID, a bytevector, of the given TYPE (currently one of: \"bzr-nodeid\", \"hg-nodeid\", \"nar-sha256\", \"checksum-sha512\")." + ;; Specify "extid_version=1" as explained in + ;; <https://gitlab.softwareheritage.org/swh/meta/-/issues/5093>. (call (swh-url "/api/1/extid" type - (string-append "hex:" (bytevector->base16-string id))) + (string-append "hex:" (bytevector->base16-string id) + "/?extid_version=1")) json->external-id)) (define* (lookup-directory-by-nar-hash hash #:optional (algorithm 'sha256)) diff --git a/guix/tests.scm b/guix/tests.scm index 8f6d040f1f..5a314eb395 100644 --- a/guix/tests.scm +++ b/guix/tests.scm @@ -86,11 +86,11 @@ #f)) (let ((store (open-connection uri))) ;; Make sure we build everything by ourselves. When we build something, - ;; it should take at most 5 minutes. + ;; it should take at most 10 minutes. (set-build-options store #:use-substitutes? #f #:substitute-urls (%test-substitute-urls) - #:timeout (* 5 60)) + #:timeout (* 10 60)) ;; Use the bootstrap Guile when running tests, so we don't end up ;; building everything in the temporary test store. diff --git a/guix/transformations.scm b/guix/transformations.scm index f02b9f94d6..131b8564f8 100644 --- a/guix/transformations.scm +++ b/guix/transformations.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2016-2023 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2016-2024 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2021 Marius Bakke <marius@gnu.org> ;;; Copyright © 2023 Sarthak Shah <shahsarthakw@gmail.com> ;;; Copyright © 2023, 2024 Efraim Flashner <efraim@flashner.co.il> @@ -31,7 +31,8 @@ #:autoload (guix download) (download-to-store) #:autoload (guix git-download) (git-reference? git-reference-url) #:autoload (guix git) (git-checkout git-checkout? git-checkout-url) - #:autoload (guix upstream) (package-latest-release + #:autoload (guix upstream) (upstream-source + package-latest-release upstream-source-version upstream-source-signature-urls) #:autoload (guix cpu) (current-cpu @@ -61,8 +62,11 @@ tunable-package? tuned-package + package-with-upstream-version + show-transformation-options-help transformation-option-key? + cacheable-transformation-option-key? %transformation-options)) ;;; Commentary: @@ -504,8 +508,12 @@ actual compiler." (list "-C" (string-append "target_cpu=" #$micro-architecture))) (else - (list (string-append "-march=" - #$micro-architecture)))))))))))) + (list + ;; Some architectures take '-mcpu' and not '-march'. + (if (string-prefix? "power" #$micro-architecture) + (string-append "-mcpu=" #$micro-architecture) + (string-append "-march=" + #$micro-architecture))))))))))))) (define program (program-file (string-append "tuning-compiler-wrapper-" micro-architecture) @@ -523,7 +531,7 @@ actual compiler." (symlink #$program (string-append bin "/" program))) '("cc" "gcc" "clang" "g++" "c++" "clang++" - "go" "rustc" "zig"))))))) + "gfortran" "go" "rustc" "zig"))))))) (define (build-system-with-tuning-compiler bs micro-architecture) "Return a variant of BS, a build system, that ensures that the compiler that @@ -841,10 +849,32 @@ additional patches." (rewrite obj) obj))) -(define* (package-with-upstream-version p #:optional version) +(define* (upstream-fetch source hash-algo hash + #:optional name + #:key (system (%current-system)) + (guile (default-guile)) + executable?) + "This origin method simply downloads SOURCE, an <upstream-source> record." + (lower-object source system)) + +(define (upstream-source-without-signatures source) + "Return SOURCE with #f as its 'signature-urls' field." + (upstream-source (inherit source) + (signature-urls #f))) + +(define* (package-with-upstream-version p #:optional version + #:key + (preserve-patches? #f) + (authenticate? #t)) "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))) +is #f, the latest known upstream version. When PRESERVE-PATCHES? is true, +preserve patches and snippets found in the source of P, provided it's an +origin. When AUTHENTICATE? is false, disable OpenPGP signature verification +of upstream source code." + (let ((source (and=> (package-latest-release p #:version version) + (if authenticate? + identity + upstream-source-without-signatures)))) (cond ((not source) (if version (warning @@ -878,7 +908,15 @@ version (~a)~%") (package (inherit p) (version (upstream-source-version source)) - (source source)))))) + (source (if (and preserve-patches? + (origin? (package-source p))) + ;; Inherit P's origin so snippets and patches are + ;; applied as if we had run 'guix refresh -u'. + (origin + (inherit (package-source p)) + (method upstream-fetch) + (uri source)) + source))))))) (define (transform-package-latest specs) "Return a procedure that rewrites package graphs such that those in SPECS @@ -934,6 +972,16 @@ are replaced by the specified upstream version." (with-latest . ,transform-package-latest) (with-version . ,transform-package-version))) +(define %transformations-with-external-dependencies + ;; Subset of options that depend on external resources and that can thus be + ;; considered "non-deterministic" and non-cacheable. + '(with-source + with-branch + with-git-url + with-patch + with-latest + with-version)) + (define (transformation-procedure key) "Return the transformation procedure associated with KEY, a symbol such as 'with-source', or #f if there is none." @@ -948,6 +996,13 @@ are replaced by the specified upstream version." For example, (transformation-option-key? 'with-input) => #t." (->bool (transformation-procedure key))) +(define (cacheable-transformation-option-key? key) + "Return true if KEY corresponds to a transformation option whose result can +be cached--i.e., the transformation is deterministic and does not depend on +external resources." + (and (transformation-option-key? key) + (not (memq key %transformations-with-external-dependencies)))) + ;;; ;;; Command-line handling. diff --git a/guix/ui.scm b/guix/ui.scm index d82fa533cc..eba12c8616 100644 --- a/guix/ui.scm +++ b/guix/ui.scm @@ -35,7 +35,7 @@ ;;; 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 ui) +(define-module (guix ui) ;import in user interfaces only #:use-module (guix i18n) #:use-module (guix colors) #:use-module (guix diagnostics) @@ -150,6 +150,10 @@ ;;; ;;; User interface facilities for command-line tools. ;;; +;;; Note: This module is meant to be imported by user interfaces only and not +;;; be "regular" modules. It depends on lots of modules that may be +;;; relatively heavyweight dependencies for non-UI modules. +;;; ;;; Code: (define (print-unbound-variable-error port key args default-printer) @@ -337,7 +341,7 @@ other objects that must match the 'format' escapes in MESSAGE." (display (colorize (G_ "hint: ")) port) (display ;; XXX: We should arrange so that the initial indent is wider. - (parameterize ((%text-width (max 15 (- (terminal-columns) 5)))) + (parameterize ((%text-width (max 15 (- (terminal-columns port) 5)))) (texi->plain-text (match arguments (() (format #f message)) (_ (apply format #f message @@ -531,7 +535,7 @@ See the \"Application Setup\" section in the manual, for more info.\n")) ;; We're now running in the "C" locale. Try to install a UTF-8 locale ;; instead. This one is guaranteed to be available in 'guix' from 'guix ;; pull'. - (false-if-exception (setlocale LC_ALL "en_US.utf8"))))) + (false-if-exception (setlocale LC_ALL "C.UTF-8"))))) (define (initialize-guix) "Perform the usual initialization for stand-alone Guix commands." @@ -756,6 +760,20 @@ evaluating the tests and bodies of CLAUSES." (location->string loc) (package-full-name package) (build-system-name system)))) + ((package-unsupported-target-error? c) + (let* ((package (package-error-package c)) + (loc (package-location package))) + (leave (G_ "~a: ~a: does not support target `~a'~%") + (location->string loc) + (package-full-name package) + (package-unsupported-target-error-target c)))) + ((unsupported-cross-compilation-target-error? c) + (let ((build-system + (unsupported-cross-compilation-target-error-build-system c)) + (target (unsupported-cross-compilation-target-error-target c))) + (leave (G_ "the `~a' build system: does not support target `~a'~%") + (build-system-name build-system) + target))) ((gexp-input-error? c) (let ((input (gexp-error-invalid-input c))) (leave (G_ "~s: invalid G-expression input~%") @@ -1059,7 +1077,7 @@ summary, and level 0 shows nothing." #:hook ,hook #:build ,(cons file build)))))))) '(#:graft () #:hook () #:build ()) - build/full) + (reverse! build/full)) ;preserve ordering ((#:graft graft #:hook hook #:build build) (values graft hook build))))) (define installed-size diff --git a/guix/upstream.scm b/guix/upstream.scm index 180ae21dcf..0593c363aa 100644 --- a/guix/upstream.scm +++ b/guix/upstream.scm @@ -28,6 +28,7 @@ #:use-module ((guix download) #:select (download-to-store url-fetch)) #:use-module (guix git-download) + #:use-module (guix svn-download) #:use-module (guix gnupg) #:use-module (guix packages) #:use-module (guix diagnostics) @@ -47,8 +48,10 @@ #:use-module (srfi srfi-26) #:use-module (srfi srfi-34) #:use-module (srfi srfi-35) + #:use-module (srfi srfi-71) #:use-module (rnrs bytevectors) #:use-module (ice-9 match) + #:use-module (ice-9 regex) #:export (upstream-source upstream-source? upstream-source-package @@ -107,7 +110,7 @@ upstream-source? (package upstream-source-package) ;string (version upstream-source-version) ;string - (urls upstream-source-urls) ;list of strings|git-reference + (urls upstream-source-urls) ;list of strings|git-references... (signature-urls upstream-source-signature-urls ;#f | list of strings (default #f)) (inputs upstream-source-inputs ;#f | list of <upstream-input> @@ -224,15 +227,26 @@ correspond to the same version." (define %updaters ;; The list of publically-known updaters, alphabetically sorted. (delay - (sort (fold-module-public-variables (lambda (obj result) - (if (upstream-updater? obj) - (cons obj result) - result)) - '() - (importer-modules)) - (lambda (updater1 updater2) - (string<? (symbol->string (upstream-updater-name updater1)) - (symbol->string (upstream-updater-name updater2))))))) + (let* ((updaters + (sort (fold-module-public-variables + (lambda (obj result) + (if (upstream-updater? obj) + (cons obj result) + result)) + '() + (importer-modules)) + (lambda (updater1 updater2) + (string<? + (symbol->string (upstream-updater-name updater1)) + (symbol->string (upstream-updater-name updater2)))))) + (generic-updaters rest (partition + (compose (cut string-prefix? "generic" <>) + symbol->string + upstream-updater-name) + updaters))) + ;; Ensure the generic updaters are tried last, as otherwise they could + ;; return less accurate results. + (append rest generic-updaters)))) ;; Tests need to mock this variable so mark it as "non-declarative". (set! %updaters %updaters) @@ -463,10 +477,19 @@ SOURCE, an <upstream-source>." #:recursive? (git-reference-recursive? ref)) source)) +(define* (package-update/svn-multi-fetch store package source + #:key key-download key-server) + "Return the version, checkout, and SOURCE, to update PACKAGE to +SOURCE, an <upstream-source>." + (values (upstream-source-version source) + (download-multi-svn-to-store store (upstream-source-urls source)) + source)) + (define %method-updates ;; Mapping of origin methods to source update procedures. `((,url-fetch . ,package-update/url-fetch) - (,git-fetch . ,package-update/git-fetch))) + (,git-fetch . ,package-update/git-fetch) + (,svn-multi-fetch . ,package-update/svn-multi-fetch))) (define* (package-update store package #:optional (updaters (force %updaters)) @@ -608,9 +631,9 @@ specified in SOURCE, an <upstream-source>." "Modify the source file that defines PACKAGE to refer to SOURCE, an <upstream-source> whose tarball has SHA256 HASH (a bytevector). Return the new version string if an update was made, and #f otherwise." - (define (update-expression expr replacements) + (define (replace-atom expr replacements) ;; Apply REPLACEMENTS to package expression EXPR, a string. REPLACEMENTS - ;; must be a list of replacement pairs, either bytevectors or strings. + ;; must be a list of replacement pairs, either of byte-vectors or strings. (fold (lambda (replacement str) (match replacement (((? bytevector? old-bv) . (? bytevector? new-bv)) @@ -623,62 +646,111 @@ new version string if an update was made, and #f otherwise." expr replacements)) - (let ((name (package-name package)) - (version (upstream-source-version source)) - (version-loc (package-field-location package 'version))) - (if version-loc - (let* ((loc (package-location package)) - (old-version (package-version package)) - (old-hash (content-hash-value - (origin-hash (package-source package)))) - (old-url (match (origin-uri (package-source package)) - ((? string? url) url) - ((? git-reference? ref) - (git-reference-url ref)) - (_ #f))) - (new-url (match (upstream-source-urls source) - ((first _ ...) first) - ((? git-reference? ref) - (git-reference-url ref)) - (_ #f))) - (old-commit (match (origin-uri (package-source package)) - ((? git-reference? ref) - (git-reference-commit ref)) - (_ #f))) - (new-commit (match (upstream-source-urls source) - ((? git-reference? ref) - (git-reference-commit ref)) - (_ #f))) - (file (and=> (location-file loc) - (cut search-path %load-path <>)))) - (if file - ;; Be sure to use absolute filename. Replace the URL directory - ;; when OLD-URL is available; this is useful notably for - ;; mirror://cpan/ URLs where the directory may change as a - ;; function of the person who uploads the package. Note that - ;; package definitions usually concatenate fragments of the URL, - ;; which is why we only attempt to replace a subset of the URL. - (let ((replacements `((,old-version . ,version) - (,old-hash . ,hash) - ,@(if (and old-commit new-commit) - `((,old-commit . ,new-commit)) - '()) - ,@(if (and old-url new-url) - `((,(dirname old-url) . - ,(dirname new-url))) - '())))) - (and (edit-expression (location->source-properties - (absolute-location loc)) - (cut update-expression <> replacements)) - (or (not (upstream-source-inputs source)) - (update-package-inputs package source)) - version)) - (begin - (warning (G_ "~a: could not locate source file") - (location-file loc)) - #f))) - (warning (package-location package) - (G_ "~a: no `version' field in source; skipping~%") - name)))) + (define (replace-commit old new expr) + ;; Replace OLD commit or revision with NEW commit or revision in package + ;; expression EXPR. Special care is given to ensure the commit or + ;; revision does not inadvertently match a part of a bigger item. + (let ((regexp (make-regexp (format #f " ~s($|[ )])" old) + regexp/newline))) + (regexp-substitute/global + #f regexp expr 'pre (lambda (m) (format #f " ~s" new)) 1 'post))) + + (define (replace-list old new expr) + ;; Replace list OLD with list NEW in package expression EXPR. Elements in + ;; NEW are aligned vertically, at the same column as the first element in + ;; OLD. + (if (equal? old new) + expr + (let ((regexp + (make-regexp + (string-append + "(^[^\"]*)" ;initial indentation in group 1 + (string-join (map (compose regexp-quote object->string) old) + "[ \t\n]*")) + regexp/newline)) + (f + (lambda (m) + (let* ((lead (match:substring m 1)) + (indent (make-string (string-length lead) #\space))) + (string-append + lead + (string-join (map object->string new) + (string-append "\n" indent))))))) + (regexp-substitute/global #f regexp expr 'pre f 'post)))) + + (let* ((name (package-name package)) + (loc (package-location package)) + (version (upstream-source-version source)) + (old-version (package-version package)) + (old-hash (content-hash-value + (origin-hash (package-source package)))) + (old-url (match (origin-uri (package-source package)) + ((? string? url) url) + ((? git-reference? ref) + (git-reference-url ref)) + ((? svn-multi-reference? ref) + (svn-multi-reference-url ref)) + (_ #f))) + (old-commit (match (origin-uri (package-source package)) + ((? git-reference? ref) + (git-reference-commit ref)) + ((? svn-multi-reference? ref) + (svn-multi-reference-revision ref)) + (_ #f))) + (old-locations (match (origin-uri (package-source package)) + ((? svn-multi-reference? ref) + (svn-multi-reference-locations ref)) + (_ #f))) + (new-url (match (upstream-source-urls source) + ((first _ ...) first) + ((? git-reference? ref) + (git-reference-url ref)) + ((? svn-multi-reference? ref) + (svn-multi-reference-url ref)) + (_ #f))) + (new-commit (match (upstream-source-urls source) + ((? git-reference? ref) + (git-reference-commit ref)) + ((? svn-multi-reference? ref) + (svn-multi-reference-revision ref)) + (_ #f))) + (new-locations (match (upstream-source-urls source) + ((? svn-multi-reference? ref) + (svn-multi-reference-locations ref)) + (_ #f)))) + (cond + ;; Ensure package exists, has a version field, and is stored in a file + ;; with an absolute file name. + ((not (package-field-location package 'version)) + (warning (package-location package) + (G_ "~a: no `version' field in source; skipping~%") + name)) + ((not (and=> (location-file loc) + (cut search-path %load-path <>))) + (warning (G_ "~a: could not locate source file") + (location-file loc)) + #f) + ;; Proceed with replacements. + (else + (let ((replacement-pairs + `((,old-version . ,version) + (,old-hash . ,hash) + ;; Replace the URL directory when OLD-URL is available; this is + ;; useful notably for mirror://cpan/ URLs where the directory + ;; may change as a function of the person who uploads the + ;; package. Note that package definitions usually concatenate + ;; fragments of the URL, which is why we only attempt to + ;; replace a subset of the URL. + ,@(if (and old-url new-url) + `((,(dirname old-url) . ,(dirname new-url))) + '())))) + (and (edit-expression + (location->source-properties (absolute-location loc)) + (compose (cut replace-atom <> replacement-pairs) + (cut replace-commit old-commit new-commit <>) + (cut replace-list old-locations new-locations <>))) + (or (not (upstream-source-inputs source)) + (update-package-inputs package source)) + version)))))) ;;; upstream.scm ends here diff --git a/guix/utils.scm b/guix/utils.scm index d8ce6ed886..537d0490e0 100644 --- a/guix/utils.scm +++ b/guix/utils.scm @@ -17,7 +17,7 @@ ;;; Copyright © 2022 Denis 'GNUtoo' Carikli <GNUtoo@cyberdimension.org> ;;; Copyright © 2022 Antero Mejr <antero@mailbox.org> ;;; Copyright © 2023 Philip McGrath <philip@philipmcgrath.com> -;;; Copyright © 2023 Janneke Nieuwenhuizen <janneke@gnu.org> +;;; Copyright © 2023, 2024 Janneke Nieuwenhuizen <janneke@gnu.org> ;;; Copyright © 2023 Zheng Junjie <873216071@qq.com> ;;; Copyright © 2023 Foundation Devices, Inc. <hello@foundationdevices.com> ;;; Copyright © 2024 Herman Rimm <herman@rimm.ee> @@ -94,6 +94,11 @@ target-linux? target-hurd? system-hurd? + target-hurd64? + system-hurd64? + host-hurd? + host-hurd64? + host-x86-64? target-mingw? target-x86-32? target-x86-64? @@ -716,6 +721,33 @@ a character other than '@'." "Is the current system the GNU(/Hurd) system?" (and=> (%current-system) target-hurd?)) +(define* (target-hurd64? #:optional (target (or (%current-target-system) + (%current-system)))) + "Does TARGET represent the 64bit GNU(/Hurd) system?" + (and (target-hurd?) + (target-64bit? target))) + +(define* (system-hurd64?) + "Is the current system the 64bit GNU(/Hurd) system?" + (and (system-hurd?) + (target-64bit? (%current-system)))) + +(define (host-hurd?) + "Are we running on a Hurd system? This is almost never the right function, +use target-hurd? or system-hurd? instead." + (equal? (utsname:sysname (uname)) "GNU")) + +(define (host-x86-64?) + "Are we running on a x86_64 system? This is almost never the right +function, use target-x86-64? or system-x86-64? instead." + (equal? (utsname:machine (uname)) "x86_64")) + +(define (host-hurd64?) + "Are we running on a 64bit Hurd? This is almost never the right +function, use target-hurd64? or system-hurd64? instead." + (and (host-hurd?) + (host-x86-64?))) + (define* (target-mingw? #:optional (target (%current-target-system))) "Is the operating system of TARGET Windows?" (and target @@ -973,7 +1005,8 @@ VERSIONS. For example: (define (compressed-file? file) "Return true if FILE denotes a compressed file." (->bool (member (file-extension file) - '("gz" "bz2" "xz" "lz" "lzma" "tgz" "tbz2" "zip")))) + '("gz" "bz2" "xz" "lz" "lzma" "tgz" "tbz2" "tzst" + "zip" "zst")))) (define* (string-replace-substring str substr replacement #:optional |