diff options
Diffstat (limited to 'guix')
99 files changed, 2442 insertions, 1141 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..658a2e525e 100644 --- a/guix/build-system/cargo.scm +++ b/guix/build-system/cargo.scm @@ -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. 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..226688f2d2 100644 --- a/guix/build-system/go.scm +++ b/guix/build-system/go.scm @@ -33,6 +33,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 @@ -101,13 +103,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. @@ -184,6 +192,8 @@ commit hash and its date rather than a proper release tag." (unpack-path "") (build-flags ''()) (tests? #t) + (parallel-build? #t) + (parallel-tests? #t) (allow-go-reference? #f) (system (%current-system)) (goarch #f) @@ -214,6 +224,8 @@ commit hash and its date rather than a proper release tag." #:unpack-path #$unpack-path #:build-flags #$build-flags #:tests? #$tests? + #:parallel-build? #$parallel-build? + #:parallel-tests? #$parallel-tests? #:allow-go-reference? #$allow-go-reference? #:inputs #$(input-tuples->gexp 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..d0654a923e 100644 --- a/guix/build-system/linux-module.scm +++ b/guix/build-system/linux-module.scm @@ -41,7 +41,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." 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..eb2714dd78 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,6 +188,7 @@ TRIPLET." (outputs '("out")) (configure-flags ''()) (search-paths '()) + (out-of-source? #t) (build-type "debugoptimized") (tests? #t) (test-options ''()) @@ -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..9a27ebee35 100644 --- a/guix/build-system/pyproject.scm +++ b/guix/build-system/pyproject.scm @@ -98,7 +98,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 @@ -131,7 +133,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..ed34745bcc 100644 --- a/guix/build-system/r.scm +++ b/guix/build-system/r.scm @@ -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." 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/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..0b1542394a 100644 --- a/guix/build/font-build-system.scm +++ b/guix/build/font-build-system.scm @@ -23,6 +23,7 @@ #:use-module (srfi srfi-1) #:use-module (srfi srfi-26) #:export (%standard-phases + %license-file-regexp font-build)) ;; Commentary: @@ -56,6 +57,11 @@ archive, or a font file." (for-each (cut install-file <> (string-append fonts "/web")) (find-files source "\\.(woff|woff2)$")))) +(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 (replace 'unpack unpack) 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..8aa8a17495 100644 --- a/guix/build/go-build-system.scm +++ b/guix/build/go-build-system.scm @@ -4,8 +4,10 @@ ;;; 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 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> ;;; ;;; This file is part of GNU Guix. ;;; @@ -90,7 +92,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? @@ -227,9 +228,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 +256,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,6 +271,7 @@ 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" @@ -272,9 +279,12 @@ unpacking." (invoke "go" "env")))) ;; Can this also install commands??? -(define* (check #:key tests? import-path #:allow-other-keys) +(define* (check #:key tests? import-path (parallel-tests? #t) + #:allow-other-keys) "Run the tests for the package named by IMPORT-PATH." (when tests? + (let* ((njobs (if parallel-tests? (parallel-job-count) 1))) + (setenv "GOMAXPROCS" (number->string njobs))) (invoke "go" "test" import-path)) #t) @@ -304,58 +314,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 @@ -367,8 +325,7 @@ files in OUTPUTS." (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/mix-build-system.scm b/guix/build/mix-build-system.scm index fe2e36d184..0b021da791 100644 --- a/guix/build/mix-build-system.scm +++ b/guix/build/mix-build-system.scm @@ -1,5 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2023 Pierre-Henry Fröhring <contact@phfrohring.com> +;;; Copyright © 2024 Igor Goryachev <igor@goryachev.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -102,13 +103,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 . _) 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/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/gexp.scm b/guix/gexp.scm index 74b4c49f90..871e59cfdc 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 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..48a962089d 100644 --- a/guix/git.scm +++ b/guix/git.scm @@ -298,6 +298,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 +324,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) 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/crate.scm b/guix/import/crate.scm index 7a25b2243c..263c2a8b16 100644 --- a/guix/import/crate.scm +++ b/guix/import/crate.scm @@ -3,6 +3,7 @@ ;;; Copyright © 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2019, 2020 Martin Becze <mjbecze@riseup.net> ;;; Copyright © 2021 Nicolas Goaziou <mail@nicolasgoaziou.fr> +;;; Copyright © 2021 Sarah Morgensen <iskarian@mgsn.dev> ;;; Copyright © 2022 Hartmut Goebel <h.goebel@crazy-compilers.com> ;;; Copyright © 2023 Simon Tournier <zimon.toutoune@gmail.com> ;;; Copyright © 2023, 2024 Efraim Flashner <efraim@flashner.co.il> @@ -141,19 +142,36 @@ 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) (() '()) ((package-inputs ...) - `(#:cargo-inputs ,package-inputs)))) + `(#:cargo-inputs (,'unquote (list ,@package-inputs)))))) (define (maybe-cargo-development-inputs package-names) (match (package-names->package-inputs package-names) (() '()) ((package-inputs ...) - `(#:cargo-development-inputs ,package-inputs)))) + `(#:cargo-development-inputs (,'unquote (list ,@package-inputs)))))) (define (maybe-arguments arguments) (match arguments @@ -187,6 +205,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 +230,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/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/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..7b9f54a200 100644 --- a/guix/import/pypi.scm +++ b/guix/import/pypi.scm @@ -544,8 +544,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..61012bed28 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? 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..b7756fcc40 100644 --- a/guix/import/utils.scm +++ b/guix/import/utils.scm @@ -370,6 +370,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 +418,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 +442,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/lint.scm b/guix/lint.scm index 68d532968d..7612832a5a 100644 --- a/guix/lint.scm +++ b/guix/lint.scm @@ -1971,10 +1971,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)) @@ -2038,7 +2034,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..9cb07493ba 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,19 @@ (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"))) + (and (or (file-exists? file-gz) + (file-exists? file-zst) file) + file))))) (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..f373136d22 100644 --- a/guix/packages.scm +++ b/guix/packages.scm @@ -5,7 +5,7 @@ ;;; 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> @@ -160,6 +160,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 +178,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 @@ -831,6 +839,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 +863,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 +912,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 +927,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 +975,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 +1009,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 +1061,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 +1145,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 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/scripts/build.scm b/guix/scripts/build.scm index da4859eeaa..b010414d53 100644 --- a/guix/scripts/build.scm +++ b/guix/scripts/build.scm @@ -678,9 +678,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)) @@ -763,9 +763,11 @@ needed." (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) + (substitute-urls store) + (begin + (warning (G_ "could not determine current \ +substitute URLs; using defaults~%")) + %default-substitute-urls)) '()))) (items (filter-map (match-lambda (('argument . (? store-path? file)) diff --git a/guix/scripts/environment.scm b/guix/scripts/environment.scm index 1d7a6e198d..a219b2ac89 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> ;;; @@ -812,7 +812,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/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/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/pack.scm b/guix/scripts/pack.scm index fe4df042d7..7c5fe76fe0 100644 --- a/guix/scripts/pack.scm +++ b/guix/scripts/pack.scm @@ -493,7 +493,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. diff --git a/guix/scripts/refresh.scm b/guix/scripts/refresh.scm index d858ed07cb..ec7d38c22a 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) diff --git a/guix/scripts/style.scm b/guix/scripts/style.scm index 211980dc1c..5f4ee4a492 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..99c58f3812 100644 --- a/guix/scripts/system.scm +++ b/guix/scripts/system.scm @@ -591,7 +591,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)) 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/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..582f8a2729 100644 --- a/guix/transformations.scm +++ b/guix/transformations.scm @@ -504,8 +504,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) diff --git a/guix/ui.scm b/guix/ui.scm index d82fa533cc..966f0611f6 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) @@ -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~%") diff --git a/guix/upstream.scm b/guix/upstream.scm index 180ae21dcf..753916be64 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) @@ -49,6 +50,7 @@ #:use-module (srfi srfi-35) #:use-module (rnrs bytevectors) #:use-module (ice-9 match) + #:use-module (ice-9 regex) #:export (upstream-source upstream-source? upstream-source-package @@ -107,7 +109,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> @@ -463,10 +465,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 +619,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 +634,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..f161cb4ef3 100644 --- a/guix/utils.scm +++ b/guix/utils.scm @@ -973,7 +973,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 |