diff options
Diffstat (limited to 'guix')
138 files changed, 1879 insertions, 724 deletions
diff --git a/guix/android-repo-download.scm b/guix/android-repo-download.scm index 1c3502e673..1d1b9e2f09 100644 --- a/guix/android-repo-download.scm +++ b/guix/android-repo-download.scm @@ -29,10 +29,7 @@ #:use-module (guix modules) #:autoload (guix build-system gnu) (standard-packages) #:use-module (ice-9 match) - #:use-module (ice-9 vlist) #:use-module (srfi srfi-1) - #:use-module (srfi srfi-34) - #:use-module (srfi srfi-35) #:export (android-repo-reference android-repo-reference? android-repo-reference-manifest-url @@ -81,6 +78,9 @@ generic name if unset." (define guile-json (module-ref (resolve-interface '(gnu packages guile)) 'guile-json-4)) + (define guile-lzlib + (module-ref (resolve-interface '(gnu packages guile)) 'guile-lzlib)) + (define gnutls (module-ref (resolve-interface '(gnu packages tls)) 'gnutls)) @@ -102,7 +102,8 @@ generic name if unset." (define build (with-imported-modules modules - (with-extensions (list gnutls guile-json) ;for (guix swh) + (with-extensions (list gnutls guile-json ;for (guix swh) + guile-lzlib) #~(begin (use-modules (guix build android-repo) (guix build utils) diff --git a/guix/base32.scm b/guix/base32.scm index 8f097d4e77..dd18a796f2 100644 --- a/guix/base32.scm +++ b/guix/base32.scm @@ -17,7 +17,6 @@ ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. (define-module (guix base32) - #:use-module (srfi srfi-1) #:use-module (srfi srfi-34) #:use-module (srfi srfi-35) #:use-module (srfi srfi-60) diff --git a/guix/build-system/android-ndk.scm b/guix/build-system/android-ndk.scm index 211fd11311..047f884b19 100644 --- a/guix/build-system/android-ndk.scm +++ b/guix/build-system/android-ndk.scm @@ -26,8 +26,6 @@ #:use-module (guix packages) #:use-module (guix build-system) #:use-module (guix build-system gnu) - #:use-module (ice-9 match) - #:use-module (srfi srfi-26) #:export (android-ndk-build-system)) (define %android-ndk-build-system-modules diff --git a/guix/build-system/ant.scm b/guix/build-system/ant.scm index 08a4c996f9..cfb033f6a5 100644 --- a/guix/build-system/ant.scm +++ b/guix/build-system/ant.scm @@ -26,8 +26,6 @@ #:use-module (guix search-paths) #:use-module (guix build-system) #:use-module (guix build-system gnu) - #:use-module (ice-9 match) - #:use-module (srfi srfi-26) #:export (%ant-build-system-modules ant-build ant-build-system)) diff --git a/guix/build-system/asdf.scm b/guix/build-system/asdf.scm index 74a3e47da1..2b17cee37b 100644 --- a/guix/build-system/asdf.scm +++ b/guix/build-system/asdf.scm @@ -33,9 +33,7 @@ #:use-module (guix build-system) #:use-module (guix build-system gnu) #:use-module (ice-9 match) - #:use-module (ice-9 regex) #:use-module (srfi srfi-1) - #:use-module (srfi srfi-26) #:use-module (gnu packages) #:export (%asdf-build-system-modules %asdf-build-modules diff --git a/guix/build-system/chicken.scm b/guix/build-system/chicken.scm index 07666d1321..9f518e66e6 100644 --- a/guix/build-system/chicken.scm +++ b/guix/build-system/chicken.scm @@ -27,7 +27,6 @@ #:use-module (guix build-system) #:use-module (guix build-system gnu) #:use-module (guix packages) - #:use-module (ice-9 match) #:export (%chicken-build-system-modules chicken-build chicken-build-system diff --git a/guix/build-system/clojure.scm b/guix/build-system/clojure.scm index 2a0713d297..fb897356bc 100644 --- a/guix/build-system/clojure.scm +++ b/guix/build-system/clojure.scm @@ -33,8 +33,6 @@ #:select ((search-path-specification->sexp . search-path-spec->sexp))) #:use-module (guix utils) - - #:use-module (ice-9 match) #:export (%clojure-build-system-modules clojure-build clojure-build-system)) diff --git a/guix/build-system/cmake.scm b/guix/build-system/cmake.scm index 0aabc95b90..09e3ac85db 100644 --- a/guix/build-system/cmake.scm +++ b/guix/build-system/cmake.scm @@ -24,12 +24,10 @@ #:use-module (guix gexp) #:use-module (guix utils) #:use-module (guix monads) - #:use-module (guix derivations) #:use-module (guix search-paths) #:use-module (guix build-system) #:use-module (guix build-system gnu) #:use-module (guix packages) - #:use-module (ice-9 match) #:export (%cmake-build-system-modules cmake-build cmake-build-system)) diff --git a/guix/build-system/copy.scm b/guix/build-system/copy.scm index 6efc2b2766..4091eb7847 100644 --- a/guix/build-system/copy.scm +++ b/guix/build-system/copy.scm @@ -28,7 +28,6 @@ #:use-module (guix build-system) #:use-module (guix build-system gnu) #:use-module (guix packages) - #:use-module (ice-9 match) #:use-module (srfi srfi-1) #:export (%copy-build-system-modules default-glibc diff --git a/guix/build-system/dub.scm b/guix/build-system/dub.scm index 8aa93d5b0f..b4011cdb83 100644 --- a/guix/build-system/dub.scm +++ b/guix/build-system/dub.scm @@ -29,8 +29,6 @@ #:use-module (guix packages) #:use-module (guix build-system) #:use-module (guix build-system gnu) - #:use-module (ice-9 match) - #:use-module (srfi srfi-26) #:export (dub-build-system)) (define (default-ldc) diff --git a/guix/build-system/dune.scm b/guix/build-system/dune.scm index 3f81d21441..afe5b24f22 100644 --- a/guix/build-system/dune.scm +++ b/guix/build-system/dune.scm @@ -25,10 +25,8 @@ #:use-module (guix gexp) #:use-module (guix search-paths) #:use-module (guix build-system) - #:use-module ((guix build-system gnu) #:prefix gnu:) #:use-module ((guix build-system ocaml) #:prefix ocaml:) #:use-module (guix packages) - #:use-module (ice-9 match) #:use-module (srfi srfi-1) #:export (%dune-build-system-modules dune-build diff --git a/guix/build-system/emacs.scm b/guix/build-system/emacs.scm index 3df68789ff..ebf97a5344 100644 --- a/guix/build-system/emacs.scm +++ b/guix/build-system/emacs.scm @@ -28,8 +28,6 @@ #:use-module (guix search-paths) #:use-module (guix build-system) #:use-module (guix build-system gnu) - #:use-module (ice-9 match) - #:use-module (srfi srfi-26) #:export (%emacs-build-system-modules emacs-build emacs-build-system) diff --git a/guix/build-system/font.scm b/guix/build-system/font.scm index a99f76c66b..aac130da4e 100644 --- a/guix/build-system/font.scm +++ b/guix/build-system/font.scm @@ -22,7 +22,6 @@ #:use-module (guix monads) #:use-module (guix utils) #:use-module (guix packages) - #:use-module (guix derivations) #:use-module (guix search-paths) #:use-module (guix build-system) #:use-module (guix build-system gnu) diff --git a/guix/build-system/glib-or-gtk.scm b/guix/build-system/glib-or-gtk.scm index aa9703829b..e956354687 100644 --- a/guix/build-system/glib-or-gtk.scm +++ b/guix/build-system/glib-or-gtk.scm @@ -24,14 +24,12 @@ #:use-module (guix utils) #:use-module (guix gexp) #:use-module (guix monads) - #:use-module (guix derivations) #:use-module (guix search-paths) #:use-module ((guix build glib-or-gtk-build-system) #:select (%gdk-pixbuf-loaders-cache-file)) #:use-module (guix build-system) #:use-module (guix build-system gnu) #:use-module (guix packages) - #:use-module (ice-9 match) #:export (%glib-or-gtk-build-system-modules glib-or-gtk-build glib-or-gtk-cross-build diff --git a/guix/build-system/gnu.scm b/guix/build-system/gnu.scm index e62ee18367..c363c3910f 100644 --- a/guix/build-system/gnu.scm +++ b/guix/build-system/gnu.scm @@ -22,7 +22,6 @@ #:use-module (guix memoization) #:use-module (guix gexp) #:use-module (guix monads) - #:use-module (guix derivations) #:use-module (guix search-paths) #:use-module (guix build-system) #:use-module (guix packages) diff --git a/guix/build-system/guile.scm b/guix/build-system/guile.scm index ffc892260a..1bd292e267 100644 --- a/guix/build-system/guile.scm +++ b/guix/build-system/guile.scm @@ -25,7 +25,6 @@ #:use-module (guix search-paths) #:use-module (guix build-system) #:use-module (guix build-system gnu) - #:use-module (ice-9 match) #:use-module (srfi srfi-26) #:export (%guile-build-system-modules guile-build-system)) @@ -129,6 +128,7 @@ (phases '%standard-phases) (source-directory ".") + (scheme-file-regexp %scheme-file-regexp) not-compiled-file-regexp (compile-flags %compile-flags) (imported-modules %guile-build-system-modules) @@ -154,6 +154,7 @@ #:target #$target #:outputs %outputs #:source-directory #$source-directory + #:scheme-file-regexp #$scheme-file-regexp #:not-compiled-file-regexp #$not-compiled-file-regexp #:compile-flags #$compile-flags #:inputs %build-target-inputs diff --git a/guix/build-system/haskell.scm b/guix/build-system/haskell.scm index dc83512d30..b8858421c2 100644 --- a/guix/build-system/haskell.scm +++ b/guix/build-system/haskell.scm @@ -32,7 +32,6 @@ #:use-module (guix build-system gnu) #:use-module (ice-9 match) #:use-module (srfi srfi-1) - #:use-module (srfi srfi-26) #:export (hackage-uri %haskell-build-system-modules @@ -109,10 +108,7 @@ version REVISION." ,@(standard-packages))) (build-inputs `(("haskell" ,haskell) ,@native-inputs)) - ;; XXX: this is a hack to get around issue #41569. - (outputs (match outputs - (("out") (cons "static" outputs)) - (_ outputs))) + (outputs outputs) (build haskell-build) (arguments (substitute-keyword-arguments diff --git a/guix/build-system/julia.scm b/guix/build-system/julia.scm index 66e7711bcd..b5521e38e4 100644 --- a/guix/build-system/julia.scm +++ b/guix/build-system/julia.scm @@ -29,8 +29,6 @@ #:use-module (guix search-paths) #:use-module (guix build-system) #:use-module (guix build-system gnu) - #:use-module (ice-9 match) - #:use-module (srfi srfi-26) #:export (%julia-build-system-modules julia-build julia-build-system)) diff --git a/guix/build-system/maven.scm b/guix/build-system/maven.scm index 0af5922692..3daff07323 100644 --- a/guix/build-system/maven.scm +++ b/guix/build-system/maven.scm @@ -26,7 +26,6 @@ #:use-module (guix build-system) #:use-module (guix build-system gnu) #:use-module (guix packages) - #:use-module (ice-9 match) #:use-module (srfi srfi-1) #:export (%maven-build-system-modules default-maven diff --git a/guix/build-system/meson.scm b/guix/build-system/meson.scm index b0bf8cb6e6..d7d807f5b6 100644 --- a/guix/build-system/meson.scm +++ b/guix/build-system/meson.scm @@ -30,7 +30,6 @@ #:use-module (guix build-system gnu) #:use-module (guix build-system glib-or-gtk) #:use-module (guix packages) - #:use-module (ice-9 match) #:export (%meson-build-system-modules meson-build-system make-cross-file)) @@ -74,16 +73,9 @@ for TRIPLET." ;; for selecting optimisations, so set it to something ;; arbitrary. (#t "strawberries"))) - (endian . ,(cond ((string-prefix? "powerpc64le-" triplet) "little") - ((string-prefix? "mips64el-" triplet) "little") - ((target-x86-32? triplet) "little") - ((target-x86-64? triplet) "little") - ;; At least in Guix. Aarch64 and 32-bit arm - ;; have a big-endian mode as well. - ((target-arm? triplet) "little") - ((target-ppc32? triplet) "big") - ((target-riscv64? triplet) "little") - (#t (error "meson: unknown architecture")))))) + (endian . ,(if (target-little-endian? triplet) + "little" + "big")))) (define (make-binaries-alist triplet) "Make an associatoin list describing what should go into diff --git a/guix/build-system/minify.scm b/guix/build-system/minify.scm index 7d4745ab32..787235deeb 100644 --- a/guix/build-system/minify.scm +++ b/guix/build-system/minify.scm @@ -26,8 +26,6 @@ #:use-module (guix search-paths) #:use-module (guix build-system) #:use-module (guix build-system gnu) - #:use-module (ice-9 match) - #:use-module (srfi srfi-26) #:export (%minify-build-system-modules minify-build minify-build-system)) diff --git a/guix/build-system/node.scm b/guix/build-system/node.scm index 24bd677bfc..3f73390809 100644 --- a/guix/build-system/node.scm +++ b/guix/build-system/node.scm @@ -29,7 +29,6 @@ #:use-module (guix search-paths) #:use-module (guix build-system) #:use-module (guix build-system gnu) - #:use-module (ice-9 match) #:export (%node-build-system-modules node-build node-build-system)) diff --git a/guix/build-system/ocaml.scm b/guix/build-system/ocaml.scm index 921c1f8629..27d5183640 100644 --- a/guix/build-system/ocaml.scm +++ b/guix/build-system/ocaml.scm @@ -25,7 +25,6 @@ #:use-module (guix build-system) #:use-module (guix build-system gnu) #:use-module (guix packages) - #:use-module (ice-9 match) #:use-module (srfi srfi-1) #:export (%ocaml-build-system-modules package-with-ocaml4.07 diff --git a/guix/build-system/perl.scm b/guix/build-system/perl.scm index 43ec2fdcb6..7c6deb34bf 100644 --- a/guix/build-system/perl.scm +++ b/guix/build-system/perl.scm @@ -22,12 +22,10 @@ #:use-module (guix utils) #:use-module (guix gexp) #:use-module (guix monads) - #:use-module (guix derivations) #:use-module (guix search-paths) #:use-module (guix build-system) #:use-module (guix build-system gnu) #:use-module (guix packages) - #:use-module (ice-9 match) #:export (%perl-build-system-modules perl-build perl-cross-build diff --git a/guix/build-system/pyproject.scm b/guix/build-system/pyproject.scm index 8f3b562ca3..44d6650ba9 100644 --- a/guix/build-system/pyproject.scm +++ b/guix/build-system/pyproject.scm @@ -22,18 +22,14 @@ #:use-module (guix gexp) #:use-module (guix store) #:use-module (guix utils) - #:use-module (guix memoization) #:use-module (guix gexp) #:use-module (guix monads) #:use-module (guix packages) - #:use-module (guix derivations) #:use-module (guix search-paths) #:use-module (guix build-system) #:use-module (guix build-system gnu) #:use-module (guix build-system python) - #:use-module (ice-9 match) #:use-module (srfi srfi-1) - #:use-module (srfi srfi-26) #:export (%pyproject-build-system-modules default-python pyproject-build diff --git a/guix/build-system/python.scm b/guix/build-system/python.scm index c8f04b2298..cca009fb28 100644 --- a/guix/build-system/python.scm +++ b/guix/build-system/python.scm @@ -24,7 +24,6 @@ #:use-module (guix gexp) #:use-module (guix store) #:use-module (guix utils) - #:use-module (guix memoization) #:use-module (guix gexp) #:use-module (guix monads) #:use-module (guix packages) @@ -32,9 +31,7 @@ #:use-module (guix search-paths) #:use-module (guix build-system) #:use-module (guix build-system gnu) - #:use-module (ice-9 match) #:use-module (srfi srfi-1) - #:use-module (srfi srfi-26) #:export (%python-build-system-modules package-with-python2 strip-python2-variant diff --git a/guix/build-system/qt.scm b/guix/build-system/qt.scm index 7e3a54f1f8..cb33212abd 100644 --- a/guix/build-system/qt.scm +++ b/guix/build-system/qt.scm @@ -33,7 +33,6 @@ #:use-module (guix build-system cmake) #:use-module (guix build-system gnu) #:use-module (guix packages) - #:use-module (ice-9 match) #:export (%qt-build-system-modules qt-build qt-build-system)) diff --git a/guix/build-system/r.scm b/guix/build-system/r.scm index 9b360ae581..708b9e18fe 100644 --- a/guix/build-system/r.scm +++ b/guix/build-system/r.scm @@ -27,7 +27,6 @@ #:use-module (guix build-system) #:use-module (guix build-system gnu) #:use-module (ice-9 match) - #:use-module (srfi srfi-26) #:export (%r-build-system-modules r-build r-build-system diff --git a/guix/build-system/rakudo.scm b/guix/build-system/rakudo.scm index 05a4d9c2ad..3b30fdfd0e 100644 --- a/guix/build-system/rakudo.scm +++ b/guix/build-system/rakudo.scm @@ -26,7 +26,6 @@ #:use-module (guix build-system) #:use-module (guix build-system gnu) #:use-module (guix packages) - #:use-module (ice-9 match) #:export (%rakudo-build-system-modules rakudo-build rakudo-build-system)) diff --git a/guix/build-system/rebar.scm b/guix/build-system/rebar.scm index 6ca5abe4d6..de1294ec3f 100644 --- a/guix/build-system/rebar.scm +++ b/guix/build-system/rebar.scm @@ -26,8 +26,6 @@ #:use-module (guix search-paths) #:use-module (guix build-system) #:use-module (guix build-system gnu) - #:use-module (ice-9 match) - #:use-module (srfi srfi-26) #:export (hexpm-uri hexpm-package-url %rebar-build-system-modules diff --git a/guix/build-system/renpy.scm b/guix/build-system/renpy.scm index f1070951ee..3039e3c63b 100644 --- a/guix/build-system/renpy.scm +++ b/guix/build-system/renpy.scm @@ -21,16 +21,13 @@ (define-module (guix build-system renpy) #:use-module (guix store) #:use-module (guix utils) - #:use-module (guix memoization) #:use-module (guix packages) #:use-module (guix gexp) #:use-module (guix monads) #:use-module (guix search-paths) #:use-module (guix build-system) #:use-module (guix build-system gnu) - #:use-module (ice-9 match) #:use-module (srfi srfi-1) - #:use-module (srfi srfi-26) #:export (%renpy-build-system-modules default-renpy renpy-build diff --git a/guix/build-system/ruby.scm b/guix/build-system/ruby.scm index 0aa273b4f4..a3793a9381 100644 --- a/guix/build-system/ruby.scm +++ b/guix/build-system/ruby.scm @@ -23,11 +23,9 @@ #:use-module (guix gexp) #:use-module (guix monads) #:use-module (guix packages) - #:use-module (guix derivations) #:use-module (guix search-paths) #:use-module (guix build-system) #:use-module (guix build-system gnu) - #:use-module (ice-9 match) #:export (rubygems-uri %ruby-build-system-modules ruby-build diff --git a/guix/build-system/scons.scm b/guix/build-system/scons.scm index 9af24d40f8..046ddef740 100644 --- a/guix/build-system/scons.scm +++ b/guix/build-system/scons.scm @@ -25,7 +25,6 @@ #:use-module (guix search-paths) #:use-module (guix build-system) #:use-module (guix build-system gnu) - #:use-module (ice-9 match) #:export (%scons-build-system-modules scons-build scons-build-system)) diff --git a/guix/build-system/texlive.scm b/guix/build-system/texlive.scm index 336e192d83..d970c1beb9 100644 --- a/guix/build-system/texlive.scm +++ b/guix/build-system/texlive.scm @@ -28,7 +28,6 @@ #:use-module (guix build-system) #:use-module (guix build-system gnu) #:use-module (guix svn-download) - #:use-module (ice-9 match) #:export (%texlive-build-system-modules texlive-build texlive-build-system diff --git a/guix/build-system/tree-sitter.scm b/guix/build-system/tree-sitter.scm new file mode 100644 index 0000000000..21c4eb35b2 --- /dev/null +++ b/guix/build-system/tree-sitter.scm @@ -0,0 +1,195 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2022 Pierre Langlois <pierre.langlois@gmx.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 build-system tree-sitter) + #:use-module (guix store) + #:use-module (guix utils) + #:use-module (guix packages) + #:use-module (guix gexp) + #:use-module (guix monads) + #:use-module (guix search-paths) + #:use-module (guix build-system) + #:use-module (guix build-system gnu) + #:use-module (guix build-system node) + #:use-module (ice-9 match) + #:export (%tree-sitter-build-system-modules + tree-sitter-build + tree-sitter-build-system)) + +(define %tree-sitter-build-system-modules + ;; Build-side modules imported by default. + `((guix build tree-sitter-build-system) + ,@%node-build-system-modules)) + +(define* (lower name + #:key source inputs native-inputs outputs system target + #:allow-other-keys + #:rest arguments) + "Return a bag for NAME from the given arguments." + (define private-keywords + `(#:inputs #:native-inputs #:outputs ,@(if target + '() + '(#:target)))) + (define node + (module-ref (resolve-interface '(gnu packages node)) + 'node-lts)) + (define tree-sitter + (module-ref (resolve-interface '(gnu packages tree-sitter)) + 'tree-sitter)) + (define tree-sitter-cli + (module-ref (resolve-interface '(gnu packages tree-sitter)) + 'tree-sitter-cli)) + ;; Grammars depend on each other via JS modules, which we package into a + ;; dedicated js output. + (define grammar-inputs + (map (match-lambda + ((name package) + `(,name ,package "js"))) + inputs)) + (bag + (name name) + (system system) (target target) + (build-inputs `(,@(if source + `(("source" ,source)) + '()) + ("node" ,node) + ("tree-sitter-cli" ,tree-sitter-cli) + ,@native-inputs + ,@(if target '() grammar-inputs) + ;; Keep the standard inputs of 'gnu-build-system'. + ,@(if target + (standard-cross-packages target 'host) + '()) + ,@(standard-packages))) + (host-inputs `(("tree-sitter" ,tree-sitter) + ,@(if target grammar-inputs '()))) + ;; Keep the standard inputs of 'gnu-buid-system'. + (target-inputs (if target + (standard-cross-packages target 'target) + '())) + ;; XXX: this is a hack to get around issue #41569. + (outputs (match outputs + (("out") (cons "js" outputs)) + (_ outputs))) + (build (if target tree-sitter-cross-build tree-sitter-build)) + (arguments (strip-keyword-arguments private-keywords arguments)))) + +(define* (tree-sitter-build name inputs + #:key + source + (phases '%standard-phases) + (grammar-directories '(".")) + (tests? #t) + (outputs '("out" "js")) + (search-paths '()) + (system (%current-system)) + (guile #f) + (imported-modules %tree-sitter-build-system-modules) + (modules '((guix build utils) + (guix build tree-sitter-build-system)))) + (define builder + (with-imported-modules imported-modules + #~(begin + (use-modules #$@(sexp->gexp modules)) + (tree-sitter-build #:name #$name + #:source #+source + #:system #$system + #:phases #$phases + #:tests? #$tests? + #:grammar-directories '#$grammar-directories + #:outputs #$(outputs->gexp outputs) + #:search-paths + '#$(sexp->gexp + (map search-path-specification->sexp + search-paths)) + #:inputs #$(input-tuples->gexp inputs))))) + + (mlet %store-monad ((guile (package->derivation (or guile (default-guile)) + system #:graft? #f))) + (gexp->derivation name builder + #:system system + #:guile-for-build guile))) + +(define* (tree-sitter-cross-build name + #:key + target + build-inputs target-inputs host-inputs + guile source + (phases '%standard-phases) + (grammar-directories '(".")) + (tests? #t) + (outputs '("out" "js")) + (search-paths '()) + (native-search-paths '()) + (system (%current-system)) + (build (nix-system->gnu-triplet system)) + (imported-modules + %tree-sitter-build-system-modules) + (modules + '((guix build utils) + (guix build tree-sitter-build-system)))) + (define builder + (with-imported-modules imported-modules + #~(begin + (use-modules #$@(sexp->gexp modules)) + + (define %build-host-inputs + #+(input-tuples->gexp build-inputs)) + + (define %build-target-inputs + (append #$(input-tuples->gexp host-inputs) + #+(input-tuples->gexp target-inputs))) + + (define %build-inputs + (append %build-host-inputs %build-target-inputs)) + + (tree-sitter-build #:name #$name + #:source #+source + #:system #$system + #:build #$build + #:target #$target + #:phases #$phases + #:tests? #$tests? + #:grammar-directories '#$grammar-directories + #:outputs #$(outputs->gexp outputs) + #:inputs %build-target-inputs + #:native-inputs %build-host-inputs + #:search-paths ' + #$(sexp->gexp + (map search-path-specification->sexp + search-paths)) + #:native-search-paths + '#$(sexp->gexp + (map + search-path-specification->sexp + native-search-paths)))))) + + (mlet %store-monad ((guile (package->derivation (or guile (default-guile)) + system #:graft? #f))) + (gexp->derivation name builder + #:system system + #:target target + #:guile-for-build guile))) + +(define tree-sitter-build-system + (build-system + (name 'tree-sitter) + (description "The Tree-sitter grammar build system") + (lower lower))) + +;;; tree-sitter.scm ends here diff --git a/guix/build-system/trivial.scm b/guix/build-system/trivial.scm index 378ae481b9..e08884baf1 100644 --- a/guix/build-system/trivial.scm +++ b/guix/build-system/trivial.scm @@ -18,12 +18,10 @@ (define-module (guix build-system trivial) #:use-module (guix store) - #:use-module (guix utils) #:use-module (guix gexp) #:use-module (guix monads) #:use-module (guix packages) #:use-module (guix build-system) - #:use-module (ice-9 match) #:export (trivial-build-system)) (define* (lower name diff --git a/guix/build-system/waf.scm b/guix/build-system/waf.scm index 1d520050f6..91b3d0d100 100644 --- a/guix/build-system/waf.scm +++ b/guix/build-system/waf.scm @@ -22,14 +22,11 @@ #:use-module (guix gexp) #:use-module (guix monads) #:use-module (guix packages) - #:use-module (guix derivations) #:use-module (guix search-paths) #:use-module (guix build-system) #:use-module (guix build-system gnu) #:use-module ((guix build-system python) #:select (default-python default-python2)) - #:use-module (ice-9 match) - #:use-module (srfi srfi-26) #:export (%waf-build-system-modules waf-build waf-build-system)) diff --git a/guix/build/android-ndk-build-system.scm b/guix/build/android-ndk-build-system.scm index 3c8f726d1d..0298292ac9 100644 --- a/guix/build/android-ndk-build-system.scm +++ b/guix/build/android-ndk-build-system.scm @@ -18,14 +18,9 @@ (define-module (guix build android-ndk-build-system) #:use-module ((guix build gnu-build-system) #:prefix gnu:) - #:use-module (guix build syscalls) #:use-module (guix build utils) - #:use-module (ice-9 popen) - #:use-module (ice-9 rdelim) - #:use-module (ice-9 ftw) #:use-module (ice-9 format) #:use-module (ice-9 match) - #:use-module (rnrs io ports) #:use-module (srfi srfi-1) #:use-module (srfi srfi-26) #:export (%standard-phases diff --git a/guix/build/chicken-build-system.scm b/guix/build/chicken-build-system.scm index a669822dad..8f9f59cc25 100644 --- a/guix/build/chicken-build-system.scm +++ b/guix/build/chicken-build-system.scm @@ -18,7 +18,6 @@ (define-module (guix build chicken-build-system) #:use-module ((guix build gnu-build-system) #:prefix gnu:) - #:use-module (guix build union) #:use-module (guix build utils) #:use-module (ice-9 match) #:use-module (ice-9 ftw) diff --git a/guix/build/clojure-utils.scm b/guix/build/clojure-utils.scm index c5322141d3..57081d30f7 100644 --- a/guix/build/clojure-utils.scm +++ b/guix/build/clojure-utils.scm @@ -20,7 +20,6 @@ #:use-module (guix build utils) #:use-module (ice-9 ftw) #:use-module (ice-9 match) - #:use-module (ice-9 regex) #:use-module (srfi srfi-1) #:use-module (srfi srfi-8) #:use-module (srfi srfi-26) diff --git a/guix/build/download-nar.scm b/guix/build/download-nar.scm index 867f3c10bb..1b5b5503eb 100644 --- a/guix/build/download-nar.scm +++ b/guix/build/download-nar.scm @@ -18,9 +18,8 @@ (define-module (guix build download-nar) #:use-module (guix build download) - #:use-module (guix build utils) #:use-module ((guix serialization) #:hide (dump-port*)) - #:autoload (zlib) (call-with-gzip-input-port) + #:autoload (lzlib) (call-with-lzip-input-port) #:use-module (guix progress) #:use-module (web uri) #:use-module (srfi srfi-11) @@ -42,52 +41,21 @@ "Return the fallback nar URL for ITEM--e.g., \"/gnu/store/cabbag3…-foo-1.2-checkout\"." ;; Here we hard-code nar URLs without checking narinfos. That's probably OK - ;; though. Use berlin.guix.gnu.org instead of its ci.guix.gnu.org front end to - ;; avoid sending these requests to CDN providers without user consent. + ;; though. ;; TODO: Use HTTPS? The downside is the extra dependency. - (let ((bases '("http://berlin.guix.gnu.org")) + (let ((bases '("http://bordeaux.guix.gnu.org" + "http://ci.guix.gnu.org")) (item (basename item))) - (append (map (cut string-append <> "/nar/gzip/" item) bases) + (append (map (cut string-append <> "/nar/lzip/" item) bases) (map (cut string-append <> "/nar/" item) bases)))) -(define (restore-gzipped-nar port item size) - "Restore the gzipped nar read from PORT, of SIZE bytes (compressed), to +(define (restore-lzipped-nar port item size) + "Restore the lzipped nar read from PORT, of SIZE bytes (compressed), to ITEM." - ;; Since PORT is typically a non-file port (for instance because 'http-get' - ;; returns a delimited port), create a child process so we're back to a file - ;; port that can be passed to 'call-with-gzip-input-port'. - (match (pipe) - ((input . output) - (match (primitive-fork) - (0 - (dynamic-wind - (const #t) - (lambda () - (close-port output) - (close-port port) - (catch #t - (lambda () - (call-with-gzip-input-port input - (cut restore-file <> item))) - (lambda (key . args) - (print-exception (current-error-port) - (stack-ref (make-stack #t) 1) - key args) - (primitive-exit 1)))) - (lambda () - (primitive-exit 0)))) - (child - (close-port input) - (dump-port* port output - #:reporter (progress-reporter/file item size - #:abbreviation - store-path-abbreviation)) - (close-port output) - (newline) - (match (waitpid child) - ((_ . status) - (unless (zero? status) - (error "nar decompression failed" status))))))))) + (call-with-lzip-input-port port + (lambda (decompressed-port) + (restore-file decompressed-port + item)))) (define (download-nar item) "Download and extract the normalized archive for ITEM. Return #t on @@ -109,17 +77,25 @@ success, #f otherwise." (values #f #f))))) (if (not port) (loop rest) - (begin + (let* ((reporter (progress-reporter/file + url + size + (current-error-port) + #:abbreviation nar-uri-abbreviation)) + (port-with-progress + (progress-report-port reporter port + #:download-size size))) (if size (format #t "Downloading from ~a (~,2h MiB)...~%" url (/ size (expt 2 20.))) (format #t "Downloading from ~a...~%" url)) - (if (string-contains url "/gzip") - (restore-gzipped-nar port item size) + (if (string-contains url "/lzip") + (restore-lzipped-nar port-with-progress + item + size) (begin - ;; FIXME: Add progress report. - (restore-file port item) - (close-port port))) + (restore-file port-with-progress + item))) #t)))) (() #f)))) diff --git a/guix/build/gnu-dist.scm b/guix/build/gnu-dist.scm index fce1cd0759..cc48d3bdbf 100644 --- a/guix/build/gnu-dist.scm +++ b/guix/build/gnu-dist.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2013, 2015, 2020 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2013, 2015, 2020, 2023 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2018 Mark H Weaver <mhw@netris.org> ;;; ;;; This file is part of GNU Guix. @@ -52,6 +52,7 @@ (delete 'strip) (replace 'install install-dist) (add-after 'build 'build-dist build) - (delete 'build))) + (delete 'build) + (delete 'install-license-files))) ;don't create 'OUT/share/doc' ;;; gnu-dist.scm ends here diff --git a/guix/build/haskell-build-system.scm b/guix/build/haskell-build-system.scm index ef6cb316ee..0e94cf59a5 100644 --- a/guix/build/haskell-build-system.scm +++ b/guix/build/haskell-build-system.scm @@ -5,6 +5,8 @@ ;;; Copyright © 2018, 2020 Ricardo Wurmus <rekado@elephly.net> ;;; Copyright © 2018 Alex Vong <alexvong1995@gmail.com> ;;; Copyright © 2021 John Kehayias <john.kehayias@protonmail.com> +;;; Copyright © 2022 Simon Tournier <zimon.toutoune@gmail.com> +;;; Copyright © 2022 Philip Munksgaard <philip@munksgaard.me> ;;; ;;; This file is part of GNU Guix. ;;; @@ -97,12 +99,14 @@ and parameters ~s~%" ,@(if tests? '("--enable-tests") '()) - ;; Build and link with shared libraries + ;; Build static and shared libraries. "--enable-shared" - "--enable-executable-dynamic" + "--enable-static" + ;; Link executables statically by default. + "--disable-executable-dynamic" "--ghc-option=-fPIC" - ,(string-append "--ghc-option=-optl=-Wl,-rpath=" (or lib out) - "/lib/$compiler/$pkg-$version") + ;; Ensure static libraries can be used with -Wl,--gc-sections for size. + "--ghc-option=-split-sections" ,@configure-flags))) ;; Cabal errors if GHC_PACKAGE_PATH is set during 'configure', so unset ;; and restore it. @@ -118,8 +122,7 @@ and parameters ~s~%" (setenv "CONFIG_SHELL" "sh")) (run-setuphs "configure" params) - (setenv "GHC_PACKAGE_PATH" ghc-path) - #t)) + (setenv "GHC_PACKAGE_PATH" ghc-path))) (define* (build #:key parallel-build? #:allow-other-keys) "Build a given Haskell package." @@ -130,18 +133,7 @@ and parameters ~s~%" (define* (install #:key outputs #:allow-other-keys) "Install a given Haskell package." - (run-setuphs "copy" '()) - (when (assoc-ref outputs "static") - (let ((static (assoc-ref outputs "static")) - (lib (or (assoc-ref outputs "lib") - (assoc-ref outputs "out")))) - (for-each (lambda (static-lib) - (let* ((subdir (string-drop static-lib (string-length lib))) - (new (string-append static subdir))) - (mkdir-p (dirname new)) - (rename-file static-lib new))) - (find-files lib "\\.a$")))) - #t) + (run-setuphs "copy" '())) (define* (setup-compiler #:key system inputs outputs #:allow-other-keys) "Setup the compiler environment." @@ -175,8 +167,7 @@ and parameters ~s~%" conf-files) (invoke "ghc-pkg" (string-append "--package-db=" %tmp-db-dir) - "recache") - #t)) + "recache"))) (define* (register #:key name system inputs outputs #:allow-other-keys) "Generate the compiler registration and binary package database files for a @@ -215,15 +206,54 @@ given Haskell package." (() #t) ;done ((id . tail) (if (not (vhash-assoc id seen)) - (let ((dep-conf (string-append src "/" id ".conf")) - (dep-conf* (string-append dest "/" id ".conf"))) - (when (not (file-exists? dep-conf)) + (let* ((dep-conf (string-append src "/" id ".conf")) + (dep-conf* (string-append dest "/" id ".conf")) + (dep-conf-exists? (file-exists? dep-conf)) + (dep-conf*-exists? (file-exists? dep-conf*)) + (next-tail (append lst (if dep-conf-exists? (conf-depends dep-conf) '())))) + (unless dep-conf*-exists? + (unless dep-conf-exists? (error (format #f "File ~a does not exist. This usually means the dependency ~a is missing. Was checking conf-file ~a." dep-conf id conf-file))) - (copy-file dep-conf dep-conf*) ;XXX: maybe symlink instead? - (loop (vhash-cons id #t seen) - (append lst (conf-depends dep-conf)))) + (copy-file dep-conf dep-conf*)) ;XXX: maybe symlink instead? + (loop (vhash-cons id #t seen) next-tail)) (loop seen tail)))))) + (define (install-config-file conf-file dest output:doc output:lib) + ;; Copy CONF-FILE to DEST removing reference to OUTPUT:DOC from + ;; OUTPUT:LIB and using install-transitive-deps. + (let* ((contents (call-with-input-file conf-file read-string)) + (id-rx (make-regexp "^id:[ \n\t]+([^ \t\n]+)$" regexp/newline)) + (config-file-name+id + (match:substring (first (list-matches id-rx contents)) 1))) + + (when (or + (and + (string? config-file-name+id) + (string-null? config-file-name+id)) + (not config-file-name+id)) + (error (format #f "The package id for ~a is empty. This is a bug." conf-file))) + + ;; Remove reference to "doc" output from "lib" (or "out") by rewriting the + ;; "haddock-interfaces" field and removing the optional "haddock-html" + ;; field in the generated .conf file. + (when output:doc + (substitute* conf-file + (("^haddock-html: .*") "\n") + (((format #f "^haddock-interfaces: ~a" output:doc)) + (string-append "haddock-interfaces: " output:lib))) + ;; Move the referenced file to the "lib" (or "out") output. + (match (find-files output:doc "\\.haddock$") + ((haddock-file . rest) + (let* ((subdir (string-drop haddock-file (string-length output:doc))) + (new (string-append output:lib subdir))) + (mkdir-p (dirname new)) + (rename-file haddock-file new))) + (_ #f))) + (install-transitive-deps conf-file %tmp-db-dir dest) + (rename-file conf-file + (string-append dest "/" + config-file-name+id ".conf")))) + (let* ((out (assoc-ref outputs "out")) (doc (assoc-ref outputs "doc")) (haskell (assoc-ref inputs "haskell")) @@ -233,7 +263,6 @@ given Haskell package." (config-dir (string-append lib "/ghc-" version "/" name ".conf.d")) - (id-rx (make-regexp "^id:[ \n\t]+([^ \t\n]+)$" regexp/newline)) (config-file (string-append out "/" name ".conf")) (params (list (string-append "--gen-pkg-config=" config-file)))) @@ -241,53 +270,24 @@ given Haskell package." ;; The conf file is created only when there is a library to register. (when (file-exists? config-file) (mkdir-p config-dir) - (let* ((contents (call-with-input-file config-file read-string)) - (config-file-name+id (match:substring (first (list-matches id-rx contents)) 1))) - - (when (or - (and - (string? config-file-name+id) - (string-null? config-file-name+id)) - (not config-file-name+id)) - (error (format #f "The package id for ~a is empty. This is a bug." config-file))) - - ;; Remove reference to "doc" output from "lib" (or "out") by rewriting the - ;; "haddock-interfaces" field and removing the optional "haddock-html" - ;; field in the generated .conf file. - (when doc - (substitute* config-file - (("^haddock-html: .*") "\n") - (((format #f "^haddock-interfaces: ~a" doc)) - (string-append "haddock-interfaces: " lib))) - ;; Move the referenced file to the "lib" (or "out") output. - (match (find-files doc "\\.haddock$") - ((haddock-file . rest) - (let* ((subdir (string-drop haddock-file (string-length doc))) - (new (string-append lib subdir))) - (mkdir-p (dirname new)) - (rename-file haddock-file new))) - (_ #f))) - (install-transitive-deps config-file %tmp-db-dir config-dir) - (rename-file config-file - (string-append config-dir "/" - config-file-name+id ".conf")) - (invoke "ghc-pkg" - (string-append "--package-db=" config-dir) - "recache"))) - #t)) + (if (file-is-directory? config-file) + (for-each (cut install-config-file <> config-dir doc lib) + (find-files config-file)) + (install-config-file config-file config-dir doc lib)) + (invoke "ghc-pkg" + (string-append "--package-db=" config-dir) + "recache")))) (define* (check #:key tests? test-target #:allow-other-keys) "Run the test suite of a given Haskell package." (if tests? (run-setuphs test-target '()) - (format #t "test suite not run~%")) - #t) + (format #t "test suite not run~%"))) (define* (haddock #:key outputs haddock? haddock-flags #:allow-other-keys) "Generate the Haddock documentation of a given Haskell package." (when haddock? - (run-setuphs "haddock" haddock-flags)) - #t) + (run-setuphs "haddock" haddock-flags))) (define* (patch-cabal-file #:key cabal-revision #:allow-other-keys) (when cabal-revision @@ -296,8 +296,7 @@ given Haskell package." ((original) (format #t "replacing ~s with ~s~%" original cabal-revision) (copy-file cabal-revision original)) - (_ (error "Could not find a Cabal file to patch.")))) - #t) + (_ (error "Could not find a Cabal file to patch."))))) (define* (generate-setuphs #:rest empty) "Generate a default Setup.hs if needed." @@ -307,8 +306,7 @@ given Haskell package." (with-output-to-file "Setup.hs" (lambda () (format #t "import Distribution.Simple~%") - (format #t "main = defaultMain~%")))) - #t) + (format #t "main = defaultMain~%"))))) (define %standard-phases (modify-phases gnu:%standard-phases diff --git a/guix/build/linux-module-build-system.scm b/guix/build/linux-module-build-system.scm index 18ccf7cd8b..b93c5eaf93 100644 --- a/guix/build/linux-module-build-system.scm +++ b/guix/build/linux-module-build-system.scm @@ -21,10 +21,6 @@ (define-module (guix build linux-module-build-system) #:use-module ((guix build gnu-build-system) #:prefix gnu:) #:use-module (guix build utils) - #:use-module (ice-9 ftw) - #:use-module (ice-9 match) - #:use-module (srfi srfi-1) - #:use-module (srfi srfi-26) #:export (%standard-phases linux-module-build)) diff --git a/guix/build/svn.scm b/guix/build/svn.scm index 44d77a968f..2d960cb364 100644 --- a/guix/build/svn.scm +++ b/guix/build/svn.scm @@ -22,7 +22,6 @@ (define-module (guix build svn) #:use-module (guix build utils) #:use-module (srfi srfi-34) - #:use-module (ice-9 format) #:export (svn-fetch)) ;;; Commentary: diff --git a/guix/build/syscalls.scm b/guix/build/syscalls.scm index 0358960ff5..df9b9f6ac7 100644 --- a/guix/build/syscalls.scm +++ b/guix/build/syscalls.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2014-2022 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2014-2023 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2015 David Thompson <davet@gnu.org> ;;; Copyright © 2015 Mark H Weaver <mhw@netris.org> ;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com> @@ -1400,7 +1400,8 @@ exception if it's already taken." thunk (lambda () (when port - (unlock-file port)))))) + (unlock-file port) + (delete-file file)))))) (define (call-with-file-lock/no-wait file thunk handler) (let ((port #f)) @@ -1428,7 +1429,8 @@ exception if it's already taken." thunk (lambda () (when port - (unlock-file port)))))) + (unlock-file port) + (delete-file file)))))) (define-syntax-rule (with-file-lock file exp ...) "Wait to acquire a lock on FILE and evaluate EXP in that context." diff --git a/guix/build/tree-sitter-build-system.scm b/guix/build/tree-sitter-build-system.scm new file mode 100644 index 0000000000..4106728bdf --- /dev/null +++ b/guix/build/tree-sitter-build-system.scm @@ -0,0 +1,153 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2022 Pierre Langlois <pierre.langlois@gmx.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 build tree-sitter-build-system) + #:use-module ((guix build node-build-system) #:prefix node:) + #:use-module (guix build json) + #:use-module (guix build utils) + #:use-module (ice-9 match) + #:use-module (ice-9 regex) + #:use-module (srfi srfi-1) + #:export (%standard-phases + tree-sitter-build)) + +;; Commentary: +;; +;; Build procedures for tree-sitter grammar packages. This is the +;; builder-side code, which builds on top of the node build-system. +;; +;; Tree-sitter grammars are written in JavaScript and compiled to a native +;; shared object. The `tree-sitter generate' command invokes `node' in order +;; to evaluate the grammar.js into a grammar.json file, which is then +;; translated into C code. We then compile the C code ourselves. Packages +;; also sometimes add extra manually written C/C++ code. +;; +;; In order to support grammars depending on each other, such as C and C++, +;; JavaScript and TypeScript, this build-system installs the source of the +;; node module in a dedicated "js" output. +;; +;; Code: + +(define* (patch-dependencies #:key inputs #:allow-other-keys) + "Rewrite dependencies in 'package.json'. We remove all runtime dependencies +and replace development dependencies with tree-sitter grammar node modules." + + (define (rewrite package.json) + (map (match-lambda + (("dependencies" @ . _) + '("dependencies" @)) + (("devDependencies" @ . _) + `("devDependencies" @ + ,@(filter-map (match-lambda + ((key . directory) + (let ((node-module + (string-append directory + "/lib/node_modules/" + key))) + (and (directory-exists? node-module) + `(,key . ,node-module))))) + (alist-delete "node" inputs)))) + (other other)) + package.json)) + + (node:with-atomic-json-file-replacement "package.json" + (match-lambda + (('@ . package.json) + (cons '@ (rewrite package.json)))))) + +;; FIXME: The node build-system's configure phase does not support +;; cross-compiling so we re-define it. +(define* (configure #:key native-inputs inputs #:allow-other-keys) + (invoke (search-input-file (or native-inputs inputs) "/bin/npm") + "--offline" "--ignore-scripts" "install")) + +(define* (build #:key grammar-directories #:allow-other-keys) + (for-each (lambda (dir) + (with-directory-excursion dir + ;; Avoid generating binding code for other languages, we do + ;; not support this use-case yet and it relies on running + ;; `node-gyp' to build native addons. + (invoke "tree-sitter" "generate" "--no-bindings"))) + grammar-directories)) + +(define* (check #:key grammar-directories tests? #:allow-other-keys) + (when tests? + (for-each (lambda (dir) + (with-directory-excursion dir + (invoke "tree-sitter" "test"))) + grammar-directories))) + +(define* (install #:key target grammar-directories outputs #:allow-other-keys) + (let ((lib (string-append (assoc-ref outputs "out") + "/lib/tree-sitter"))) + (mkdir-p lib) + (define (compile-language dir) + (with-directory-excursion dir + (let ((lang (assoc-ref (call-with-input-file "src/grammar.json" + read-json) + "name")) + (source-file (lambda (path) + (if (file-exists? path) + path + #f)))) + (apply invoke + `(,(if target + (string-append target "-g++") + "g++") + "-shared" + "-fPIC" + "-fno-exceptions" + "-O2" + "-g" + "-o" ,(string-append lib "/libtree-sitter-" lang ".so") + ;; An additional `scanner.{c,cc}' file is sometimes + ;; provided. + ,@(cond + ((source-file "src/scanner.c") + => (lambda (file) (list "-xc" "-std=c99" file))) + ((source-file "src/scanner.cc") + => (lambda (file) (list file))) + (else '())) + "-xc" "src/parser.c"))))) + (for-each compile-language grammar-directories))) + +(define* (install-js #:key native-inputs inputs outputs #:allow-other-keys) + (invoke (search-input-file (or native-inputs inputs) "/bin/npm") + "--prefix" (assoc-ref outputs "js") + "--global" + "--offline" + "--loglevel" "info" + "--production" + ;; Skip scripts to prevent building bindings via GYP. + "--ignore-scripts" + "install" "../package.tgz")) + +(define %standard-phases + (modify-phases node:%standard-phases + (replace 'patch-dependencies patch-dependencies) + (replace 'configure configure) + (replace 'build build) + (replace 'check check) + (replace 'install install) + (add-after 'install 'install-js install-js))) + +(define* (tree-sitter-build #:key inputs (phases %standard-phases) + #:allow-other-keys #:rest args) + (apply node:node-build #:inputs inputs #:phases phases args)) + +;;; tree-sitter-build-system.scm ends here diff --git a/guix/channels.scm b/guix/channels.scm index 40cbc4bb3a..1ff72b7e72 100644 --- a/guix/channels.scm +++ b/guix/channels.scm @@ -29,8 +29,6 @@ #:use-module (guix base16) #:use-module (guix records) #:use-module (guix gexp) - #:use-module (guix modules) - #:use-module (guix discovery) #:use-module (guix monads) #:use-module (guix profiles) #:use-module (guix packages) @@ -55,8 +53,6 @@ #:use-module (ice-9 format) #:use-module (ice-9 match) #:use-module (ice-9 vlist) - #:use-module ((ice-9 rdelim) #:select (read-string)) - #:use-module ((rnrs bytevectors) #:select (bytevector=?)) #:export (channel channel? channel-name @@ -952,6 +948,10 @@ be used as a profile hook." (backtrace)))) (mkdir #$output)))) + (define channels + (map (compose string->symbol manifest-entry-name) + (manifest-entries manifest))) + (gexp->derivation-in-inferior "guix-package-cache" build profile @@ -960,8 +960,9 @@ be used as a profile hook." ;; instead of failing. #:silent-failure? #t - #:properties '((type . profile-hook) - (hook . package-cache)) + #:properties `((type . profile-hook) + (hook . package-cache) + (channels . ,channels)) #:local-build? #t))) (define %channel-profile-hooks diff --git a/guix/cpio.scm b/guix/cpio.scm index d4a7d5f1e0..876f61ea3c 100644 --- a/guix/cpio.scm +++ b/guix/cpio.scm @@ -170,7 +170,7 @@ using FILE-NAME as its file name." #:size (stat:size st) #:dev (stat:dev st) #:rdev (stat:rdev st) - #:name-size (string-length file-name)))) + #:name-size (string-utf8-length file-name)))) (define* (file->cpio-header* file #:optional (file-name file) @@ -182,7 +182,7 @@ produced in a deterministic fashion." (make-cpio-header #:mode (stat:mode st) #:nlink (stat:nlink st) #:size (stat:size st) - #:name-size (string-length file-name)))) + #:name-size (string-utf8-length file-name)))) (define* (special-file->cpio-header* file device-type @@ -201,7 +201,7 @@ The number of hard links is assumed to be 1." permission-bits) #:nlink 1 #:rdev (device-number device-major device-minor) - #:name-size (string-length file-name))) + #:name-size (string-utf8-length file-name))) (define %trailer "TRAILER!!!") @@ -237,7 +237,7 @@ produces with the '-H newc' option." ;; We're padding the header + following file name + trailing zero, and ;; the header is 110 byte long. - (write-padding (+ 110 1 (string-length file)) port) + (write-padding (+ 110 (string-utf8-length file) 1) port) (case (mode->type (cpio-header-mode header)) ((regular) @@ -246,7 +246,7 @@ produces with the '-H newc' option." (dump-port input port)))) ((symlink) (let ((target (readlink file))) - (put-string port target))) + (put-bytevector port (string->utf8 target)))) ((directory) #t) ((block-special) diff --git a/guix/cvs-download.scm b/guix/cvs-download.scm index 943d971622..22af2461e9 100644 --- a/guix/cvs-download.scm +++ b/guix/cvs-download.scm @@ -61,8 +61,8 @@ "Return a fixed-output derivation that fetches REF, a <cvs-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 guile-zlib - (module-ref (resolve-interface '(gnu packages guile)) 'guile-zlib)) + (define guile-lzlib + (module-ref (resolve-interface '(gnu packages guile)) 'guile-lzlib)) (define guile-json (module-ref (resolve-interface '(gnu packages guile)) 'guile-json-4)) @@ -77,7 +77,7 @@ HASH-ALGO (a symbol). Use NAME as the file name, or a generic name if #f." (define build (with-imported-modules modules (with-extensions (list guile-json gnutls ;for (guix swh) - guile-zlib) + guile-lzlib) #~(begin (use-modules (guix build cvs) (guix build download-nar)) diff --git a/guix/derivations.scm b/guix/derivations.scm index 0bb6a28147..9fec7f4f0b 100644 --- a/guix/derivations.scm +++ b/guix/derivations.scm @@ -41,8 +41,6 @@ #:use-module (guix i18n) #:use-module (guix monads) #:use-module (gcrypt hash) - #:use-module (guix base32) - #:use-module (guix records) #:use-module (guix sets) #:export (<derivation> derivation? diff --git a/guix/discovery.scm b/guix/discovery.scm index 81d4ca600f..0edc7fd1ae 100644 --- a/guix/discovery.scm +++ b/guix/discovery.scm @@ -24,7 +24,6 @@ #:use-module (srfi srfi-1) #:use-module (ice-9 match) #:use-module (ice-9 vlist) - #:use-module (ice-9 ftw) #:export (scheme-files scheme-modules scheme-modules* diff --git a/guix/download.scm b/guix/download.scm index fff54d7a17..561a893eee 100644 --- a/guix/download.scm +++ b/guix/download.scm @@ -387,7 +387,11 @@ file "/" (symbol->string algo) "/" (bytevector->nix-base32-string hash)))) - (list (guix-publish "ci.guix.gnu.org") + (list (guix-publish + ;; bordeaux.guix.gnu.org uses the nar-herder rather than guix + ;; publish, but it supports the same style of requests + "bordeaux.guix.gnu.org") + (guix-publish "ci.guix.gnu.org") (lambda (file algo hash) ;; 'tarballs.nixos.org' supports several algorithms. (string-append "https://tarballs.nixos.org/" diff --git a/guix/ftp-client.scm b/guix/ftp-client.scm index 9cc34cc7ec..c1d99bd75f 100644 --- a/guix/ftp-client.scm +++ b/guix/ftp-client.scm @@ -20,10 +20,8 @@ #:use-module (srfi srfi-1) #:use-module (srfi srfi-9) #:use-module (srfi srfi-11) - #:use-module (srfi srfi-26) #:use-module (srfi srfi-31) #:use-module (ice-9 binary-ports) - #:use-module (rnrs bytevectors) #:use-module (ice-9 match) #:use-module (ice-9 regex) #:use-module (ice-9 rdelim) diff --git a/guix/git-authenticate.scm b/guix/git-authenticate.scm index 419cb85afc..37c69d0880 100644 --- a/guix/git-authenticate.scm +++ b/guix/git-authenticate.scm @@ -35,7 +35,6 @@ #:use-module (guix progress) #:use-module (srfi srfi-1) #:use-module (srfi srfi-11) - #:use-module (srfi srfi-26) #:use-module (srfi srfi-34) #:use-module (srfi srfi-35) #:use-module (rnrs bytevectors) diff --git a/guix/git-download.scm b/guix/git-download.scm index a1566bed4d..027ef47468 100644 --- a/guix/git-download.scm +++ b/guix/git-download.scm @@ -1,8 +1,9 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2014, 2015, 2016, 2017, 2018, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2014-2021, 2023 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2017 Mathieu Lirzin <mthl@gnu.org> ;;; Copyright © 2017 Christopher Baines <mail@cbaines.net> ;;; Copyright © 2020 Jakub Kądziołka <kuba@kadziolka.net> +;;; Copyright © 2023 Simon Tournier <zimon.toutoune@gmail.com> ;;; ;;; This file is part of GNU Guix. ;;; @@ -84,22 +85,24 @@ 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 inputs - ;; When doing 'git clone --recursive', we need sed, grep, etc. to be - ;; available so that 'git submodule' works. - (if (git-reference-recursive? ref) - (standard-packages) + `(("git" ,git) - ;; The 'swh-download' procedure requires tar and gzip. - `(("gzip" ,(module-ref (resolve-interface '(gnu packages compression)) - 'gzip)) - ("tar" ,(module-ref (resolve-interface '(gnu packages base)) - 'tar))))) + ;; When doing 'git clone --recursive', we need sed, grep, etc. to be + ;; available so that 'git submodule' works. + ,@(if (git-reference-recursive? ref) + (standard-packages) + + ;; The 'swh-download' procedure requires tar and gzip. + `(("gzip" ,(module-ref (resolve-interface '(gnu packages compression)) + 'gzip)) + ("tar" ,(module-ref (resolve-interface '(gnu packages base)) + 'tar)))))) (define guile-json (module-ref (resolve-interface '(gnu packages guile)) 'guile-json-4)) - (define guile-zlib - (module-ref (resolve-interface '(gnu packages guile)) 'guile-zlib)) + (define guile-lzlib + (module-ref (resolve-interface '(gnu packages guile)) 'guile-lzlib)) (define gnutls (module-ref (resolve-interface '(gnu packages tls)) 'gnutls)) @@ -120,7 +123,7 @@ HASH-ALGO (a symbol). Use NAME as the file name, or a generic name if #f." (define build (with-imported-modules modules (with-extensions (list guile-json gnutls ;for (guix swh) - guile-zlib) + guile-lzlib) #~(begin (use-modules (guix build git) (guix build utils) @@ -151,7 +154,7 @@ HASH-ALGO (a symbol). Use NAME as the file name, or a generic name if #f." (or (git-fetch (getenv "git url") (getenv "git commit") #$output #:recursive? recursive? - #:git-command (string-append #+git "/bin/git")) + #:git-command "git") (download-nar #$output) ;; As a last resort, attempt to download from Software Heritage. @@ -162,8 +165,24 @@ HASH-ALGO (a symbol). Use NAME as the file name, or a generic name if #f." (parameterize ((%verify-swh-certificate? #f)) (format (current-error-port) "Trying to download from Software Heritage...~%") + (swh-download (getenv "git url") (getenv "git commit") - #$output)))))))) + #$output) + (when (file-exists? + (string-append #$output "/.gitattributes")) + ;; Perform CR/LF conversion and other changes + ;; specificied by '.gitattributes'. + (invoke "git" "-C" #$output "init") + (invoke "git" "-C" #$output "config" "--local" + "user.email" "you@example.org") + (invoke "git" "-C" #$output "config" "--local" + "user.name" "Your Name") + (invoke "git" "-C" #$output "add" ".") + (invoke "git" "-C" #$output "commit" "-am" "init") + (invoke "git" "-C" #$output "read-tree" "--empty") + (invoke "git" "-C" #$output "reset" "--hard") + (delete-file-recursively + (string-append #$output "/.git")))))))))) (mlet %store-monad ((guile (package->derivation guile system))) (gexp->derivation (or name "git-checkout") build diff --git a/guix/git.scm b/guix/git.scm index 95630a5e69..be20cde019 100644 --- a/guix/git.scm +++ b/guix/git.scm @@ -4,6 +4,7 @@ ;;; Copyright © 2021 Kyle Meyer <kyle@kyleam.com> ;;; Copyright © 2021 Marius Bakke <marius@gnu.org> ;;; Copyright © 2022 Maxime Devos <maximedevos@telenet.be> +;;; Copyright © 2023 Tobias Geerinckx-Rice <me@tobias.gr> ;;; ;;; This file is part of GNU Guix. ;;; @@ -22,8 +23,6 @@ (define-module (guix git) #:use-module (git) - #:use-module (git object) - #:use-module (git submodule) #:use-module (guix i18n) #:use-module (guix base32) #:use-module (guix cache) @@ -141,11 +140,6 @@ the 'SSL_CERT_FILE' and 'SSL_CERT_DIR' environment variables." (define total (indexer-progress-total-objects progress)) - (define hundredth - (match (quotient (indexer-progress-total-objects progress) 100) - (0 1) - (x x))) - (define-values (done label) (if (< (indexer-progress-received-objects progress) total) (values (indexer-progress-received-objects progress) @@ -156,14 +150,22 @@ the 'SSL_CERT_FILE' and 'SSL_CERT_DIR' environment variables." (define % (* 100. (/ done total))) - (when (and (< % 100) (zero? (modulo done hundredth))) + ;; TODO: Both should be handled & exposed by the PROGRESS-BAR API instead. + (define width + (max (- (current-terminal-columns) + (string-length label) 7) + 3)) + + (define grain + (match (quotient total (max 100 (* 8 width))) ; assume 1/8 glyph resolution + (0 1) + (x x))) + + (when (and (< % 100) (zero? (modulo done grain))) (erase-current-line (current-error-port)) - (let ((width (max (- (current-terminal-columns) - (string-length label) 7) - 3))) - (format (current-error-port) "~a ~3,d% ~a" + (format (current-error-port) "~a ~3,d% ~a" label (inexact->exact (round %)) - (progress-bar % width))) + (progress-bar % width)) (force-output (current-error-port))) (when (= % 100.) diff --git a/guix/gnu-maintenance.scm b/guix/gnu-maintenance.scm index 0aa70243b5..32712f7218 100644 --- a/guix/gnu-maintenance.scm +++ b/guix/gnu-maintenance.scm @@ -23,15 +23,12 @@ #:use-module (web uri) #:use-module (web client) #:use-module (web response) - #:use-module (sxml simple) #:use-module (ice-9 regex) #:use-module (ice-9 match) #:use-module (srfi srfi-1) #:use-module (srfi srfi-11) #:use-module (srfi srfi-26) - #:use-module (srfi srfi-34) #:use-module (rnrs io ports) - #:use-module (system foreign) #:use-module ((guix http-client) #:hide (open-socket-for-uri)) ;; not required in many cases, so autoloaded to reduce start-up costs. #:autoload (guix download) (%mirrors) diff --git a/guix/graph.scm b/guix/graph.scm index 41219ab67d..aee0021d6c 100644 --- a/guix/graph.scm +++ b/guix/graph.scm @@ -24,7 +24,6 @@ #:use-module (guix sets) #:autoload (guix diagnostics) (formatted-message) #:autoload (guix i18n) (G_) - #:use-module (rnrs io ports) #:use-module (srfi srfi-1) #:use-module (srfi srfi-9) #:use-module (srfi srfi-26) diff --git a/guix/hg-download.scm b/guix/hg-download.scm index 382c34922a..13135082fa 100644 --- a/guix/hg-download.scm +++ b/guix/hg-download.scm @@ -25,7 +25,6 @@ #:use-module (guix records) #:use-module (guix modules) #:use-module (guix packages) - #:autoload (guix build-system gnu) (standard-packages) #:use-module (srfi srfi-34) #:use-module (srfi srfi-35) #:use-module (ice-9 match) @@ -73,8 +72,8 @@ HASH-ALGO (a symbol). Use NAME as the file name, or a generic name if #f." ("tar" ,(module-ref (resolve-interface '(gnu packages base)) 'tar)))) - (define guile-zlib - (module-ref (resolve-interface '(gnu packages guile)) 'guile-zlib)) + (define guile-lzlib + (module-ref (resolve-interface '(gnu packages guile)) 'guile-lzlib)) (define guile-json (module-ref (resolve-interface '(gnu packages guile)) 'guile-json-4)) @@ -91,7 +90,7 @@ HASH-ALGO (a symbol). Use NAME as the file name, or a generic name if #f." (define build (with-imported-modules modules (with-extensions (list guile-json gnutls ;for (guix swh) - guile-zlib) + guile-lzlib) #~(begin (use-modules (guix build hg) (guix build utils) ;for `set-path-environment-variable' diff --git a/guix/import/cabal.scm b/guix/import/cabal.scm index 4410c12500..fe03c30254 100644 --- a/guix/import/cabal.scm +++ b/guix/import/cabal.scm @@ -22,7 +22,6 @@ #:use-module (ice-9 match) #:use-module (ice-9 regex) #:use-module (ice-9 rdelim) - #:use-module (ice-9 receive) #:use-module (srfi srfi-26) #:use-module (srfi srfi-34) #:use-module (srfi srfi-35) diff --git a/guix/import/cpan.scm b/guix/import/cpan.scm index 8972b87080..eeb142a9b8 100644 --- a/guix/import/cpan.scm +++ b/guix/import/cpan.scm @@ -31,10 +31,10 @@ #:use-module (json) #:use-module (gcrypt hash) #:use-module (guix diagnostics) + #:use-module (guix i18n) #:use-module (guix store) #:use-module (guix utils) #:use-module (guix base32) - #:use-module (guix ui) #:use-module ((guix download) #:select (download-to-store url-fetch)) #:use-module ((guix import utils) #:select (factorize-uri)) #:use-module (guix import json) diff --git a/guix/import/cran.scm b/guix/import/cran.scm index c4b36da12b..210cb40ec7 100644 --- a/guix/import/cran.scm +++ b/guix/import/cran.scm @@ -29,12 +29,10 @@ #:use-module ((ice-9 rdelim) #:select (read-string read-line)) #:use-module (srfi srfi-1) #:use-module (srfi srfi-2) - #:use-module (srfi srfi-11) #:use-module (srfi srfi-26) #:use-module (srfi srfi-34) #:use-module (srfi srfi-35) #:use-module (srfi srfi-71) - #:use-module (ice-9 receive) #:use-module (web uri) #:use-module (guix memoization) #:use-module (guix http-client) @@ -52,10 +50,9 @@ #:use-module (guix utils) #:use-module (guix git) #:use-module ((guix build-system r) #:select (cran-uri bioconductor-uri)) - #:use-module (guix ui) #:use-module (guix upstream) #:use-module (guix packages) - #:use-module (gnu packages) + #:use-module (guix sets) #:export (%input-style cran->guix-package @@ -422,6 +419,7 @@ empty list when the FIELD cannot be found." ("libarchive_dev" "libarchive") ("libbz2" "bzip2") ("libexpat" "expat") + ("libjpeg" "libjpeg-turbo") ("liblz4" "lz4") ("liblzma" "xz") ("libzstd" "zstd") @@ -447,6 +445,13 @@ empty list when the FIELD cannot be found." (() #f) (_ #t))) +(define (directory-needs-esbuild? dir) + "Check if the directory DIR contains minified JavaScript files and thus +needs a JavaScript compiler." + (match (find-files dir "\\.min.js$") + (() #f) + (_ #t))) + (define (files-match-pattern? directory regexp . file-patterns) "Return #T if any of the files matching FILE-PATTERNS in the DIRECTORY match the given REGEXP." @@ -462,10 +467,49 @@ the given REGEXP." (else (loop)))))))) (apply find-files directory file-patterns)))) -(define (directory-needs-zlib? dir) - "Return #T if any of the Makevars files in the src directory DIR contain a -zlib linker flag." - (files-match-pattern? dir "-lz" "(Makevars.*|configure.*)")) +(define packages-for-matches + '(("-lcrypto" . "openssl") + ("-lcurl" . "curl") + ("-lgit2" . "libgit2") + ("-lpcre" . "pcre2") + ("-lssh" . "openssh") + ("-lssl" . "openssl") + ("-ltbb" . "tbb") + ("-lz" . "zlib") + ("gsl-config" . "gsl") + ("xml2-config" . "libxml2") + ("CURL_LIBS" . "curl"))) + +(define libraries-pattern + (make-regexp + (string-append "(" + (string-join + (map (compose regexp-quote first) packages-for-matches) "|") + ")"))) + +(define (needed-libraries-in-directory dir) + "Return a list of package names that correspond to libraries that are +referenced in build system files." + (set->list + (fold + (lambda (file packages) + (call-with-input-file file + (lambda (port) + (let loop ((packages packages)) + (let ((line (read-line port))) + (cond + ((eof-object? line) packages) + (else + (loop + (fold (lambda (match acc) + (or (and=> (assoc-ref packages-for-matches + (match:substring match)) + (cut set-insert <> acc)) + acc)) + packages + (list-matches libraries-pattern line)))))))))) + (set) + (find-files dir "(Makevars.in*|configure.*)")))) (define (directory-needs-pkg-config? dir) "Return #T if any of the Makevars files in the src directory DIR reference @@ -477,8 +521,9 @@ the pkg-config tool." "Guess dependencies of R package source in DIR and return two values: a list of package names for INPUTS and another list of names of NATIVE-INPUTS." (values - (if (directory-needs-zlib? dir) '("zlib") '()) + (needed-libraries-in-directory dir) (append + (if (directory-needs-esbuild? dir) '("esbuild") '()) (if (directory-needs-pkg-config? dir) '("pkg-config") '()) (if (directory-needs-fortran? dir) '("gfortran") '())))) @@ -493,8 +538,8 @@ by TARBALL?" (source-dir->dependencies dir))) (source-dir->dependencies source))) -(define (needs-knitr? meta) - (member "knitr" (listify meta "VignetteBuilder"))) +(define (vignette-builders meta) + (map cran-guix-name (listify meta "VignetteBuilder"))) (define* (description->package repository meta #:key (license-prefix identity) (download-source download)) @@ -608,8 +653,7 @@ from the alist META, which was derived from the R package's DESCRIPTION file." ,@(maybe-inputs (map cran-guix-name propagate) 'propagated-inputs) ,@(maybe-inputs `(,@source-native-inputs - ,@(if (needs-knitr? meta) - '("r-knitr") '())) + ,@(vignette-builders meta)) 'native-inputs) (home-page ,(if (string-null? home-page) (string-append base-url name) diff --git a/guix/import/crate.scm b/guix/import/crate.scm index c17d96ef41..514eca2229 100644 --- a/guix/import/crate.scm +++ b/guix/import/crate.scm @@ -23,14 +23,11 @@ (define-module (guix import crate) #:use-module (guix base32) #:use-module (guix build-system cargo) - #:use-module ((guix download) #:prefix download:) #:use-module (gcrypt hash) #:use-module (guix http-client) #:use-module (guix import json) #:use-module (guix import utils) - #:use-module ((guix licenses) #:prefix license:) #:use-module (guix memoization) - #:use-module (guix monads) #:use-module (guix packages) #:use-module (guix upstream) #:use-module (guix utils) diff --git a/guix/import/egg.scm b/guix/import/egg.scm index 90d97909b5..e3bc158475 100644 --- a/guix/import/egg.scm +++ b/guix/import/egg.scm @@ -26,18 +26,14 @@ #:use-module (srfi srfi-71) #:use-module (gcrypt hash) #:use-module (guix git) - #:use-module (guix i18n) #:use-module (guix base32) - #:use-module (guix diagnostics) #:use-module (guix memoization) #:use-module (guix packages) #:use-module (guix upstream) - #:use-module (guix build-system) #:use-module (guix build-system chicken) #:use-module (guix store) #:use-module ((guix download) #:select (download-to-store url-fetch)) #:use-module (guix import utils) - #:use-module ((guix licenses) #:prefix license:) #:export (egg->guix-package egg-recursive-import %egg-updater diff --git a/guix/import/elm.scm b/guix/import/elm.scm index c8fb15343f..508bac5462 100644 --- a/guix/import/elm.scm +++ b/guix/import/elm.scm @@ -18,10 +18,8 @@ (define-module (guix import elm) #:use-module (ice-9 match) - #:use-module (ice-9 regex) #:use-module (ice-9 vlist) #:use-module (srfi srfi-1) - #:use-module (srfi srfi-11) #:use-module (srfi srfi-26) #:use-module (srfi srfi-34) #:use-module (srfi srfi-35) @@ -32,20 +30,11 @@ #:use-module (guix memoization) #:use-module (guix diagnostics) #:use-module (guix i18n) - #:use-module ((guix ui) #:select (display-hint)) - #:use-module ((guix build utils) - #:select ((package-name->name+version - . hyphen-package-name->name+version) - find-files - invoke)) #:use-module (guix import utils) #:use-module (guix git) #:use-module (guix import json) #:autoload (gcrypt hash) (hash-algorithm sha256) #:use-module (json) - #:use-module (guix packages) - #:use-module (guix upstream) - #:use-module ((guix licenses) #:prefix license:) #:use-module (guix build-system elm) #:export (elm-recursive-import %elm-package-registry diff --git a/guix/import/elpa.scm b/guix/import/elpa.scm index f9e9f2de53..f71e758db4 100644 --- a/guix/import/elpa.scm +++ b/guix/import/elpa.scm @@ -34,22 +34,19 @@ #:use-module (srfi srfi-9 gnu) #:use-module (srfi srfi-11) #:use-module (srfi srfi-26) - #:use-module (srfi srfi-34) #:use-module (srfi srfi-35) + #:use-module (guix i18n) #:use-module (guix diagnostics) #:use-module ((guix download) #:select (download-to-store)) #:use-module (guix import utils) #:use-module (guix http-client) #:use-module (guix git) #:use-module (guix hash) - #:use-module ((guix serialization) #:select (write-file)) #:use-module (guix store) - #:use-module (guix ui) #:use-module (guix base32) #:use-module (guix upstream) #:use-module (guix packages) #:use-module (guix memoization) - #:use-module ((guix utils) #:select (call-with-temporary-output-file)) #:export (elpa->guix-package guix-package->elpa-name %elpa-updater diff --git a/guix/import/gem.scm b/guix/import/gem.scm index c8d6cd4d2d..4e2be0f5f8 100644 --- a/guix/import/gem.scm +++ b/guix/import/gem.scm @@ -27,7 +27,6 @@ #:use-module (ice-9 match) #:use-module (srfi srfi-1) #:use-module (json) - #:use-module ((guix download) #:prefix download:) #:use-module (guix import utils) #:use-module (guix import json) #:use-module (guix packages) diff --git a/guix/import/git.scm b/guix/import/git.scm index c15943bd7c..ab51719255 100644 --- a/guix/import/git.scm +++ b/guix/import/git.scm @@ -20,17 +20,14 @@ ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. (define-module (guix import git) - #:use-module (guix build utils) + #:use-module (guix i18n) #:use-module (guix diagnostics) #:use-module (guix git) #:use-module (guix git-download) - #:use-module (guix i18n) #:use-module (guix packages) #:use-module (guix upstream) #:use-module (guix utils) - #:use-module (ice-9 format) #:use-module (ice-9 match) - #:use-module (ice-9 rdelim) #:use-module (ice-9 regex) #:use-module (srfi srfi-1) #:use-module (srfi srfi-26) diff --git a/guix/import/github.scm b/guix/import/github.scm index a1bda5ec43..7409c9a202 100644 --- a/guix/import/github.scm +++ b/guix/import/github.scm @@ -35,13 +35,11 @@ #:use-module ((guix download) #:prefix download:) #:use-module ((guix git-download) #:prefix download:) #:autoload (guix build download) (open-connection-for-uri) - #:use-module (guix import utils) #:use-module (json) #:use-module (guix packages) #:use-module (guix upstream) #:use-module (guix http-client) #:use-module (web uri) - #:use-module (web response) #:export (%github-api %github-updater)) ;; For tests. diff --git a/guix/import/gnome.scm b/guix/import/gnome.scm index 3c5a96fdde..054ae44f7a 100644 --- a/guix/import/gnome.scm +++ b/guix/import/gnome.scm @@ -25,8 +25,6 @@ #:use-module (guix http-client) #:use-module (json) #:use-module (srfi srfi-1) - #:use-module (srfi srfi-11) - #:use-module (srfi srfi-26) #:use-module (srfi srfi-34) #:use-module (web uri) #:use-module (ice-9 match) diff --git a/guix/import/gnu.scm b/guix/import/gnu.scm index cff088f423..fb61332fb8 100644 --- a/guix/import/gnu.scm +++ b/guix/import/gnu.scm @@ -23,19 +23,16 @@ #:use-module (guix gnu-maintenance) #:use-module (guix import utils) #:use-module (guix i18n) - #:use-module (guix utils) #:use-module (guix store) #:use-module (gcrypt hash) #:use-module (guix base32) #:use-module (guix upstream) #:use-module (srfi srfi-1) - #:use-module (srfi srfi-11) #:use-module (srfi srfi-26) #:use-module (srfi srfi-34) #:use-module (srfi srfi-35) #:use-module (web uri) #:use-module (ice-9 match) - #:use-module (ice-9 regex) #:export (gnu->guix-package)) ;;; Commentary: diff --git a/guix/import/go.scm b/guix/import/go.scm index 90d4c8931d..0357e6a1eb 100644 --- a/guix/import/go.scm +++ b/guix/import/go.scm @@ -32,25 +32,20 @@ #:use-module (guix import utils) #:use-module (guix import json) #:use-module (guix packages) - #:use-module ((guix utils) #:select (string-replace-substring)) #:use-module (guix http-client) - #:use-module ((guix licenses) #:prefix license:) #:use-module (guix memoization) #:autoload (htmlprag) (html->sxml) ;from Guile-Lib - #:autoload (guix serialization) (write-file) #:autoload (guix base32) (bytevector->nix-base32-string) #:autoload (guix build utils) (mkdir-p) #:autoload (gcrypt hash) (hash-algorithm sha256) #:use-module (ice-9 format) #:use-module (ice-9 match) #:use-module (ice-9 peg) - #:use-module (ice-9 rdelim) #:use-module (ice-9 receive) #:use-module (ice-9 regex) #:use-module (ice-9 textual-ports) #:use-module ((rnrs io ports) #:select (call-with-port)) #:use-module (srfi srfi-1) - #:use-module (srfi srfi-2) #:use-module (srfi srfi-9) #:use-module (srfi srfi-11) #:use-module (srfi srfi-26) @@ -61,10 +56,7 @@ (if (eq? 'filter s) 'xfilter s))) - #:use-module (web client) - #:use-module (web response) #:use-module (web uri) - #:export (go-module->guix-package go-module->guix-package* go-module-recursive-import)) diff --git a/guix/import/hackage.scm b/guix/import/hackage.scm index 7bc2908405..83ad85f3fe 100644 --- a/guix/import/hackage.scm +++ b/guix/import/hackage.scm @@ -52,7 +52,6 @@ hackage-recursive-import %hackage-updater - guix-package->hackage-name hackage-name->package-name hackage-fetch hackage-source-url @@ -76,6 +75,7 @@ "exceptions" "filepath" "ghc" + "ghc-bignum" "ghc-boot" "ghc-boot-th" "ghc-compact" @@ -126,17 +126,6 @@ version is returned." (string-downcase name) (string-append package-name-prefix (string-downcase name)))) -(define guix-package->hackage-name - (let ((uri-rx (make-regexp "(https?://hackage.haskell.org|mirror://hackage)/package/([^/]+)/.*")) - (name-rx (make-regexp "(.*)-[0-9\\.]+"))) - (lambda (package) - "Given a Guix package name, return the corresponding Hackage name." - (let* ((source-url (and=> (package-source package) origin-uri)) - (name (match:substring (regexp-exec uri-rx source-url) 2))) - (match (regexp-exec name-rx name) - (#f name) - (m (match:substring m 1))))))) - (define (read-cabal-and-hash port) "Read a Cabal file from PORT and return it and its hash in nix-base32 format as two values." @@ -314,6 +303,7 @@ the hash of the Cabal file." (bytevector->nix-base32-string (file-sha256 tarball)) "failed to download tar archive"))))) (build-system haskell-build-system) + (properties '((upstream-name . ,name))) ,@(maybe-inputs 'inputs dependencies) ,@(maybe-inputs 'native-inputs native-dependencies) ,@(maybe-arguments) @@ -370,7 +360,7 @@ respectively." (formatted-message (G_ "~a updater doesn't support updating to a specific version, sorry.") "hackage"))) - (let* ((hackage-name (guix-package->hackage-name package)) + (let* ((hackage-name (package-upstream-name* package)) (cabal-meta (hackage-fetch hackage-name))) (match cabal-meta (#f @@ -378,7 +368,10 @@ respectively." "warning: failed to parse ~a~%" (hackage-cabal-url hackage-name)) #f) - ((_ *** ("version" (version))) + ;; Cabal files have no particular order and while usually the version + ;; as somewhere in the middle it can also be at the beginning, + ;; requiring two pattern. + ((or (_ *** ("version" (version))) (("version" (version)) _ ...)) (let ((url (hackage-uri hackage-name version))) (upstream-source (package (package-name package)) diff --git a/guix/import/hexpm.scm b/guix/import/hexpm.scm index dac5d1756f..628a44ff24 100644 --- a/guix/import/hexpm.scm +++ b/guix/import/hexpm.scm @@ -22,10 +22,6 @@ ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. (define-module (guix import hexpm) - #:use-module (guix base32) - #:use-module ((guix download) #:prefix download:) - #:use-module (gcrypt hash) - #:use-module (guix http-client) #:use-module (json) #:use-module (guix import utils) #:use-module ((guix import json) #:select (json-fetch)) @@ -33,16 +29,11 @@ #:select ((package-name->name+version . hyphen-package-name->name+version) dump-port)) - #:use-module ((guix licenses) #:prefix license:) - #:use-module (guix monads) #:use-module (guix packages) #:use-module (guix upstream) #:use-module (guix utils) #:use-module (ice-9 match) - #:use-module (ice-9 regex) - #:use-module (ice-9 popen) #:use-module (srfi srfi-1) - #:use-module (srfi srfi-2) #:use-module (srfi srfi-26) #:use-module (guix build-system rebar) #:export (hexpm->guix-package diff --git a/guix/import/kde.scm b/guix/import/kde.scm index 3566312eca..0ae457ef3d 100644 --- a/guix/import/kde.scm +++ b/guix/import/kde.scm @@ -20,7 +20,6 @@ (define-module (guix import kde) #:use-module (guix http-client) - #:use-module (guix memoization) #:use-module (guix gnu-maintenance) #:use-module (guix packages) #:use-module (guix upstream) diff --git a/guix/import/minetest.scm b/guix/import/minetest.scm index e5775e2fa9..7e7b6dd6ac 100644 --- a/guix/import/minetest.scm +++ b/guix/import/minetest.scm @@ -19,24 +19,17 @@ (define-module (guix import minetest) #:use-module (ice-9 match) - #:use-module (ice-9 receive) #:use-module (ice-9 threads) #:use-module (ice-9 hash-table) #:use-module (srfi srfi-1) - #:use-module (srfi srfi-2) - #:use-module (srfi srfi-11) - #:use-module (srfi srfi-26) #:use-module (guix diagnostics) #:use-module ((guix packages) #:prefix package:) #:use-module (guix upstream) - #:use-module (guix utils) - #:use-module (guix ui) #:use-module (guix i18n) #:use-module (guix memoization) #:use-module (guix serialization) #:use-module (guix import utils) #:use-module (guix import json) - #:use-module ((gcrypt hash) #:select (open-sha256-port port-sha256)) #:use-module (json) #:use-module (guix base32) #:use-module (guix git) diff --git a/guix/import/opam.scm b/guix/import/opam.scm index 938a88f69d..e336936306 100644 --- a/guix/import/opam.scm +++ b/guix/import/opam.scm @@ -22,23 +22,19 @@ ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. (define-module (guix import opam) - #:use-module (ice-9 ftw) #:use-module (ice-9 match) #:use-module (ice-9 peg) #:use-module ((ice-9 popen) #:select (open-pipe*)) - #:use-module (ice-9 receive) #:use-module (ice-9 textual-ports) - #:use-module (ice-9 vlist) #:use-module (srfi srfi-1) #:use-module (srfi srfi-2) #:use-module ((srfi srfi-26) #:select (cut)) #:use-module ((web uri) #:select (string->uri uri->string)) #:use-module ((guix build utils) #:select (dump-port find-files mkdir-p)) #:use-module (guix build-system) - #:use-module (guix build-system ocaml) + #:use-module (guix i18n) #:use-module (guix diagnostics) #:use-module (guix http-client) - #:use-module (guix ui) #:use-module (guix packages) #:use-module (guix upstream) #:use-module ((guix utils) #:select (cache-directory @@ -49,7 +45,6 @@ recursive-import spdx-string->license url-fetch)) - #:use-module ((guix licenses) #:prefix license:) #:export (opam->guix-package opam-recursive-import %opam-updater diff --git a/guix/import/print.scm b/guix/import/print.scm index 2f54adbd8c..08a484f5f3 100644 --- a/guix/import/print.scm +++ b/guix/import/print.scm @@ -19,12 +19,11 @@ (define-module (guix import print) #:use-module (guix base32) - #:use-module (guix utils) #:use-module (guix licenses) #:use-module (guix packages) + #:use-module ((guix diagnostics) #:select (location-file)) #:use-module (guix search-paths) #:use-module (guix build-system) - #:use-module (gnu packages) #:use-module (srfi srfi-1) #:use-module (srfi srfi-26) #:use-module (guix import utils) diff --git a/guix/import/pypi.scm b/guix/import/pypi.scm index c9aaacbc3f..261fdb46d9 100644 --- a/guix/import/pypi.scm +++ b/guix/import/pypi.scm @@ -36,7 +36,6 @@ #:use-module (ice-9 receive) #:use-module ((ice-9 rdelim) #:select (read-line)) #:use-module (srfi srfi-1) - #:use-module (srfi srfi-11) #:use-module (srfi srfi-26) #:use-module (srfi srfi-34) #:use-module (srfi srfi-35) @@ -51,13 +50,11 @@ find-files invoke)) #:use-module (guix import utils) - #:use-module ((guix download) #:prefix download:) #:use-module (guix import json) #:use-module (json) #:use-module (guix packages) #:use-module (guix upstream) #:use-module ((guix licenses) #:prefix license:) - #:use-module (guix build-system python) #:export (parse-requires.txt parse-wheel-metadata specification->requirement-name diff --git a/guix/import/stackage.scm b/guix/import/stackage.scm index c0284e48a4..735eeb75f7 100644 --- a/guix/import/stackage.scm +++ b/guix/import/stackage.scm @@ -49,7 +49,7 @@ (make-parameter "https://www.stackage.org")) ;; Latest LTS version compatible with current GHC. -(define %default-lts-version "18.14") +(define %default-lts-version "20.5") (define-json-mapping <stackage-lts> make-stackage-lts stackage-lts? @@ -149,7 +149,7 @@ PACKAGE or #f if the package is not included in the Stackage LTS release." (formatted-message (G_ "~a updater doesn't support updating to a specific version, sorry.") "stackage"))) - (let* ((hackage-name (guix-package->hackage-name pkg)) + (let* ((hackage-name (package-upstream-name* pkg)) (version (lts-package-version (packages) hackage-name)) (name-version (hackage-name-version hackage-name version))) (match (and=> name-version hackage-fetch) @@ -173,7 +173,7 @@ PACKAGE or #f if the package is not included in the Stackage LTS release." (false-if-networking-error (let ((packages (stackage-lts-packages (stackage-lts-info-fetch %default-lts-version))) - (hackage-name (guix-package->hackage-name package))) + (hackage-name (package-upstream-name* package))) (find (lambda (package) (string=? (stackage-package-name package) hackage-name)) packages))))) diff --git a/guix/import/test.scm b/guix/import/test.scm index 767dcd5b61..b1ed0b455d 100644 --- a/guix/import/test.scm +++ b/guix/import/test.scm @@ -18,8 +18,6 @@ (define-module (guix import test) #:use-module (srfi srfi-1) - #:use-module (srfi srfi-26) - #:use-module (web uri) #:use-module (guix packages) #:use-module (guix upstream) #:use-module ((guix utils) #:select (version-prefix?)) diff --git a/guix/import/texlive.scm b/guix/import/texlive.scm index 6bf7f92e60..82014ee568 100644 --- a/guix/import/texlive.scm +++ b/guix/import/texlive.scm @@ -35,9 +35,6 @@ #:use-module (guix serialization) #:use-module (guix svn-download) #:use-module (guix import utils) - #:use-module (guix utils) - #:use-module (guix upstream) - #:use-module (guix packages) #:use-module (guix build-system texlive) #:export (files-differ? texlive->guix-package diff --git a/guix/import/utils.scm b/guix/import/utils.scm index 72795d2c61..e1f6519287 100644 --- a/guix/import/utils.scm +++ b/guix/import/utils.scm @@ -39,7 +39,6 @@ #:use-module (guix packages) #:use-module (guix discovery) #:use-module (guix build-system) - #:use-module (guix gexp) #:use-module ((guix i18n) #:select (G_)) #:use-module (guix store) #:use-module (guix download) @@ -198,6 +197,7 @@ thrown." ("CPL-1.0" . license:cpl1.0) ("EPL-1.0" . license:epl1.0) ("EPL-2.0" . license:epl2.0) + ("EUPL-1.1" . license:eupl1.1) ("EUPL-1.2" . license:eupl1.2) ("MIT" . license:expat) ("MIT-0" . license:expat-0) @@ -244,6 +244,7 @@ thrown." ("LGPL-3.0-only" . license:lgpl3) ("LGPL-3.0+" . license:lgpl3+) ("LGPL-3.0-or-later" . license:lgpl3+) + ("LPL-1.02" . license:lpl1.02) ("LPPL-1.0" . license:lppl) ("LPPL-1.1" . license:lppl) ("LPPL-1.2" . license:lppl1.2) diff --git a/guix/ipfs.scm b/guix/ipfs.scm index 31a89888a7..3c25f2a499 100644 --- a/guix/ipfs.scm +++ b/guix/ipfs.scm @@ -18,15 +18,10 @@ (define-module (guix ipfs) #:use-module (json) - #:use-module (guix base64) - #:use-module ((guix build utils) #:select (dump-port)) #:use-module (srfi srfi-1) #:use-module (srfi srfi-11) - #:use-module (srfi srfi-26) #:use-module (rnrs io ports) - #:use-module (rnrs bytevectors) #:use-module (ice-9 match) - #:use-module (ice-9 ftw) #:use-module (web uri) #:use-module (web client) #:use-module (web response) diff --git a/guix/licenses.scm b/guix/licenses.scm index 632c9174df..e7e6ef3545 100644 --- a/guix/licenses.scm +++ b/guix/licenses.scm @@ -75,6 +75,7 @@ knuth lal1.3 lgpl2.0 lgpl2.0+ lgpl2.1 lgpl2.1+ lgpl3 lgpl3+ llgpl + lpl1.02 lppl lppl1.0+ lppl1.1+ lppl1.2 lppl1.2+ lppl1.3 lppl1.3+ lppl1.3a lppl1.3a+ @@ -516,6 +517,11 @@ at URI, which may be a file:// URI pointing the package's tree." "https://opensource.franz.com/preamble.html" "Lisp Lesser General Public License")) +(define lpl1.02 ;Lucent + (license "LPL 1.02" + "https://directory.fsf.org/wiki/License:LPL-1.02" + "https://www.gnu.org/licenses/license-list.html#lucent102")) + (define lppl (license "LPPL (any version)" "https://www.latex-project.org/lppl/lppl-1-0/" @@ -613,7 +619,7 @@ at URI, which may be a file:// URI pointing the package's tree." (define nmap (license "Nmap license" - "https://svn.nmap.org/nmap/COPYING" + "https://svn.nmap.org/nmap/LICENSE" "https://fedoraproject.org/wiki/Licensing/Nmap")) (define ogl-psi1.0 diff --git a/guix/lint.scm b/guix/lint.scm index 8e3976171f..3ed7fd6e4d 100644 --- a/guix/lint.scm +++ b/guix/lint.scm @@ -33,7 +33,6 @@ (define-module (guix lint) #:use-module (guix store) #:autoload (guix base16) (bytevector->base16-string) - #:use-module (guix base32) #:autoload (guix base64) (base64-encode) #:use-module (guix build-system) #:use-module (guix diagnostics) @@ -533,7 +532,8 @@ of a package, and INPUT-NAMES, a list of package specifications such as ;; Emit a warning if some inputs of PACKAGE are likely to should not be ;; an input at all. (let ((input-names '("python-setuptools" - "python-pip"))) + "python-pip" + "python-pre-commit"))) (map (lambda (input) (make-warning package @@ -1863,6 +1863,10 @@ 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)) @@ -1926,10 +1930,7 @@ 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/packages.scm b/guix/packages.scm index 041a872f9d..4c0c194652 100644 --- a/guix/packages.scm +++ b/guix/packages.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2012-2022 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2012-2023 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2014, 2015, 2017, 2018, 2019 Mark H Weaver <mhw@netris.org> ;;; Copyright © 2015 Eric Bavier <bavier@member.fsf.org> ;;; Copyright © 2016 Alex Kost <alezost@gmail.com> @@ -9,6 +9,7 @@ ;;; Copyright © 2021 Chris Marusich <cmmarusich@gmail.com> ;;; Copyright © 2022 Maxime Devos <maximedevos@telenet.be> ;;; Copyright © 2022 jgart <jgart@dismail.de> +;;; Copyright © 2023 Simon Tournier <zimon.toutoune@gmail.com> ;;; ;;; This file is part of GNU Guix. ;;; @@ -51,10 +52,10 @@ #:use-module (ice-9 regex) #:use-module (srfi srfi-1) #:use-module (srfi srfi-9 gnu) - #:use-module (srfi srfi-11) #:use-module (srfi srfi-26) #:use-module (srfi srfi-34) #:use-module (srfi srfi-35) + #:use-module (srfi srfi-71) #:use-module (rnrs bytevectors) #:use-module (web uri) #:autoload (texinfo) (texi-fragment->stexi) @@ -1239,8 +1240,13 @@ input list." (define (package-direct-sources package) "Return all source origins associated with PACKAGE; including origins in -PACKAGE's inputs." - `(,@(or (and=> (package-source package) list) '()) +PACKAGE's inputs and patches." + (define (expand source) + (cons + source + (filter origin? (origin-patches source)))) + + `(,@(or (and=> (package-source package) expand) '()) ,@(filter-map (match-lambda ((_ (? origin? orig) _ ...) orig) @@ -1527,15 +1533,16 @@ package and returns its new name after rewrite." (define* (package-input-rewriting/spec replacements #:key (deep? #t)) "Return a procedure that, given a package, applies the given REPLACEMENTS to all the package graph, including implicit inputs unless DEEP? is false. + REPLACEMENTS is a list of spec/procedures pair; each spec is a package specification such as \"gcc\" or \"guile@2\", and each procedure takes a -matching package and returns a replacement for that package." +matching package and returns a replacement for that package. Matching +packages that have the 'hidden?' property set are not replaced." (define table (fold (lambda (replacement table) (match replacement ((spec . proc) - (let-values (((name version) - (package-name->name+version spec))) + (let ((name version (package-name->name+version spec))) (vhash-cons name (list version proc) table))))) vlist-null replacements)) @@ -1558,7 +1565,8 @@ matching package and returns a replacement for that package." (gensym " package-replacement")) (define (rewrite p) - (if (assq-ref (package-properties p) replacement-property) + (if (or (assq-ref (package-properties p) replacement-property) + (hidden-package? p)) p (match (find-replacement p) (#f p) diff --git a/guix/pki.scm b/guix/pki.scm index c5b2fb9634..93932128cd 100644 --- a/guix/pki.scm +++ b/guix/pki.scm @@ -24,7 +24,6 @@ #:autoload (srfi srfi-1) (delete-duplicates) #:use-module (ice-9 match) #:use-module (ice-9 rdelim) - #:use-module (ice-9 binary-ports) #:export (%public-key-file %private-key-file %acl-file diff --git a/guix/progress.scm b/guix/progress.scm index 4f8e98edc0..33cf6f4a1a 100644 --- a/guix/progress.scm +++ b/guix/progress.scm @@ -166,16 +166,47 @@ INTERVAL (a time-duration object), otherwise does nothing and returns #f." ;; Number of columns of the terminal. (make-parameter 80)) +(define-record-type* <progress-bar-style> + progress-bar-style make-progress-bar-style progress-bar-style? + (start progress-bar-style-start) + (stop progress-bar-style-stop) + (filled progress-bar-style-filled) + (steps progress-bar-style-steps)) + +(define ascii-bar-style + (progress-bar-style + (start #\[) + (stop #\]) + (filled #\#) + (steps '()))) + +(define unicode-bar-style + (progress-bar-style + (start #\x2595) + (stop #\x258f) + (filled #\x2588) + (steps '(#\x258F #\x258E #\x258D #\x258C #\x258B #\x258A #\x2589)))) + (define* (progress-bar % #:optional (bar-width 20)) "Return % as a string representing an ASCII-art progress bar. The total width of the bar is BAR-WIDTH." - (let* ((bar-width (max 3 (- bar-width 2))) - (fraction (/ % 100)) - (filled (inexact->exact (floor (* fraction bar-width)))) - (empty (- bar-width filled))) - (format #f "[~a~a]" - (make-string filled #\#) - (make-string empty #\space)))) + (let* ((bar-style (if (equal? (port-encoding (current-output-port)) "UTF-8") + unicode-bar-style + ascii-bar-style)) + (bar-width (max 3 (- bar-width 2))) + (intermediates (+ (length (progress-bar-style-steps bar-style)) 1)) + (step (inexact->exact (floor (/ (* % bar-width intermediates) 100)))) + (filled (quotient step intermediates)) + (intermediate + (list-ref (cons #f (progress-bar-style-steps bar-style)) + (modulo step intermediates))) + (empty (- bar-width filled (if intermediate 1 0)))) + (simple-format #f "~a~a~a~a~a" + (string (progress-bar-style-start bar-style)) + (make-string filled (progress-bar-style-filled bar-style)) + (if intermediate (string intermediate) "") + (make-string empty #\space) + (string (progress-bar-style-stop bar-style))))) (define (erase-current-line port) "Write an ANSI erase-current-line sequence to PORT to erase the whole line and diff --git a/guix/read-print.scm b/guix/read-print.scm index ccddca732d..515eb7669c 100644 --- a/guix/read-print.scm +++ b/guix/read-print.scm @@ -219,6 +219,27 @@ BLANK-LINE? is true, assume PORT is at the beginning of a new line." (list 'quote (loop #f return))) ((eq? chr #\`) (list 'quasiquote (loop #f return))) + ((eq? chr #\#) + (match (read-char port) + (#\~ (list 'gexp (loop #f return))) + (#\$ (list (match (peek-char port) + (#\@ + (read-char port) ;consume + 'ungexp-splicing) + (_ + 'ungexp)) + (loop #f return))) + (#\+ (list (match (peek-char port) + (#\@ + (read-char port) ;consume + 'ungexp-native-splicing) + (_ + 'ungexp-native)) + (loop #f return))) + (chr + (unread-char chr port) + (unread-char #\# port) + (read port)))) ((eq? chr #\,) (list (match (peek-char port) (#\@ @@ -299,6 +320,7 @@ expressions and blanks that were read." ('unless 2) ('package 1) ('origin 1) + ('channel 1) ('modify-inputs 2) ('modify-phases 2) ('add-after '(((modify-phases) . 3))) @@ -342,7 +364,8 @@ expressions and blanks that were read." ('services '(operating-system)) ('set-xorg-configuration '()) ('services '(home-environment)) - ('home-bash-configuration '(service)))) + ('home-bash-configuration '(service)) + ('introduction '(channel)))) (define (prefix? candidate lst) "Return true if CANDIDATE is a prefix of LST." @@ -527,6 +550,12 @@ FORMAT-VERTICAL-SPACE; a useful value of 'canonicalize-vertical-space'." (pair? tail))) (_ #f))) + (define (starts-with-line-comment? lst) + ;; Return true if LST starts with a line comment. + (match lst + ((x . _) (and (comment? x) (not (comment-margin? x)))) + (_ #f))) + (let loop ((indent indent) (column indent) (delimited? #t) ;true if comes after a delimiter @@ -708,7 +737,8 @@ FORMAT-VERTICAL-SPACE; a useful value of 'canonicalize-vertical-space'." (+ indent 1) (+ column (if delimited? 1 2)))) (newline? (or (newline-form? head context) - (list-of-lists? head tail))) ;'let' bindings + (list-of-lists? head tail) ;'let' bindings + (starts-with-line-comment? tail))) (context (cons head context))) (if overflow? (begin diff --git a/guix/records.scm b/guix/records.scm index 1f097c7108..7d43b064d8 100644 --- a/guix/records.scm +++ b/guix/records.scm @@ -22,7 +22,6 @@ #:use-module (srfi srfi-9) #:use-module (srfi srfi-26) #:use-module (ice-9 match) - #:use-module (ice-9 regex) #:use-module (ice-9 rdelim) #:autoload (system base target) (target-most-positive-fixnum) #:export (define-record-type* diff --git a/guix/remote.scm b/guix/remote.scm index f6adb22846..a58ec2103c 100644 --- a/guix/remote.scm +++ b/guix/remote.scm @@ -32,8 +32,6 @@ #:use-module (srfi srfi-1) #:use-module (srfi srfi-34) #:use-module (srfi srfi-35) - #:use-module (ice-9 format) - #:use-module (ice-9 match) #:export (remote-eval)) ;;; Commentary: diff --git a/guix/rpm.scm b/guix/rpm.scm new file mode 100644 index 0000000000..734aef29c1 --- /dev/null +++ b/guix/rpm.scm @@ -0,0 +1,630 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2023 Maxim Cournoyer <maxim.cournoyer@gmail.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 rpm) + #:autoload (gcrypt hash) (hash-algorithm file-hash md5) + #:use-module (guix build utils) + #:use-module (ice-9 format) + #:use-module (ice-9 match) + #:use-module (ice-9 textual-ports) + #:use-module (rnrs bytevectors) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-9) + #:use-module (srfi srfi-26) + #:use-module (srfi srfi-71) + #:use-module (srfi srfi-171) + #:export (generate-lead + generate-signature + generate-header + assemble-rpm-metadata + + ;; XXX: These are internals, but the inline disabling trick + ;; doesn't work on them. + make-header-entry + header-entry? + header-entry-tag + header-entry-count + header-entry-value + + bytevector->hex-string + + fhs-directory?)) + +;;; Commentary: +;;; +;;; This module provides the building blocks required to construct RPM +;;; archives. It is intended to be importable on the build side, so shouldn't +;;; depend on (guix diagnostics) or other host-side-only modules. +;;; +;;; Code: + +(define (gnu-system-triplet->machine-type triplet) + "Return the machine component of TRIPLET, a GNU system triplet." + (first (string-split triplet #\-))) + +(define (gnu-machine-type->rpm-arch type) + "Return the canonical RPM architecture string, given machine TYPE." + (match type + ("arm" "armv7hl") + ("powerpc" "ppc") + ("powerpc64le" "ppc64le") + (machine machine))) ;unchanged + +(define (gnu-machine-type->rpm-number type) + "Translate machine TYPE to its corresponding RPM integer value." + ;; Refer to the rpmrc.in file in the RPM source for the complete + ;; translation tables. + (match type + ((or "i486" "i586" "i686" "x86_64") 1) + ((? (cut string-prefix? "powerpc" <>)) 5) + ("mips64el" 11) + ((? (cut string-prefix? "arm" <>)) 12) + ("aarch64" 19) + ((? (cut string-prefix? "riscv" <>)) 22) + (_ (error "no RPM number known for machine type" type)))) + +(define (u16-number->u8-list number) + "Return a list of byte values made of NUMBER, a 16 bit unsigned integer." + (let ((bv (uint-list->bytevector (list number) (endianness big) 2))) + (bytevector->u8-list bv))) + +(define (u32-number->u8-list number) + "Return a list of byte values made of NUMBER, a 32 bit unsigned integer." + (let ((bv (uint-list->bytevector (list number) (endianness big) 4))) + (bytevector->u8-list bv))) + +(define (s32-number->u8-list number) + "Return a list of byte values made of NUMBER, a 32 bit signed integer." + (let ((bv (sint-list->bytevector (list number) (endianness big) 4))) + (bytevector->u8-list bv))) + +(define (u8-list->u32-number lst) + "Return the 32 bit unsigned integer corresponding to the 4 bytes in LST." + (bytevector-u32-ref (u8-list->bytevector lst) 0 (endianness big))) + + +;;; +;;; Lead section. +;;; + +;; Refer to the docs/manual/format.md file of the RPM source for the details +;; regarding the binary format of an RPM archive. +(define* (generate-lead name-version #:key (target %host-type)) + "Generate a RPM lead u8-list that uses NAME-VERSION, the name and version +string of the package, and TARGET, a GNU triplet used to derive the target +machine type." + (define machine-type (gnu-system-triplet->machine-type target)) + (define magic (list #xed #xab #xee #xdb)) + (define file-format-version (list 3 0)) ;3.0 + (define type (list 0 0)) ;0 for binary packages + (define arch-number (u16-number->u8-list + (gnu-machine-type->rpm-number machine-type))) + ;; The 66 bytes from 10 to 75 are for the name-version-release string. + (define name + (let ((padding-bytes (make-list (- 66 (string-length name-version)) 0))) + (append (bytevector->u8-list (string->utf8 name-version)) + padding-bytes))) + ;; There is no OS number corresponding to GNU/Hurd (GNU), only Linux, per + ;; rpmrc.in. + (define os-number (list 0 1)) + + ;; For RPM format 3.0, the signature type is 5, which means a "Header-style" + ;; signature. + (define signature-type (list 0 5)) + + (define reserved-bytes (make-list 16 0)) + + (append magic file-format-version type arch-number name + os-number signature-type reserved-bytes)) + + +;;; +;;; Header section. +;;; + +(define header-magic (list #x8e #xad #xe8)) +(define header-version (list 1)) +(define header-reserved (make-list 4 0)) ;4 reserved bytes +;;; Every header starts with 8 bytes made by the header magic number, the +;;; header version and 4 reserved bytes. +(define header-intro (append header-magic header-version header-reserved)) + +;;; Header entry data types. +(define NULL 0) +(define CHAR 1) +(define INT8 2) +(define INT16 3) ;2-bytes aligned +(define INT32 4) ;4-bytes aligned +(define INT64 5) ;8-bytes aligned +(define STRING 6) +(define BIN 7) +(define STRING_ARRAY 8) +(define I18NSTRIN_TYPE 9) + +;;; Header entry tags. +(define-record-type <rpm-tag> + (make-rpm-tag number type) + rpm-tag? + (number rpm-tag-number) + (type rpm-tag-type)) + +;;; The following are internal tags used to identify the data sections. +(define RPMTAG_HEADERSIGNATURES (make-rpm-tag 62 BIN)) ;signature header +(define RPMTAG_HEADERIMMUTABLE (make-rpm-tag 63 BIN)) ;main/data header +(define RPMTAG_HEADERI18NTABLE (make-rpm-tag 100 STRING_ARRAY)) + +;;; Subset of RPM tags from include/rpm/rpmtag.h. +(define RPMTAG_NAME (make-rpm-tag 1000 STRING)) +(define RPMTAG_VERSION (make-rpm-tag 1001 STRING)) +(define RPMTAG_RELEASE (make-rpm-tag 1002 STRING)) +(define RPMTAG_SUMMARY (make-rpm-tag 1004 STRING)) +(define RPMTAG_SIZE (make-rpm-tag 1009 INT32)) +(define RPMTAG_LICENSE (make-rpm-tag 1014 STRING)) +(define RPMTAG_OS (make-rpm-tag 1021 STRING)) +(define RPMTAG_ARCH (make-rpm-tag 1022 STRING)) +(define RPMTAG_PREIN (make-rpm-tag 1023 STRING)) +(define RPMTAG_POSTIN (make-rpm-tag 1024 STRING)) +(define RPMTAG_PREUN (make-rpm-tag 1025 STRING)) +(define RPMTAG_POSTUN (make-rpm-tag 1026 STRING)) +(define RPMTAG_FILESIZES (make-rpm-tag 1028 INT32)) +(define RPMTAG_FILEMODES (make-rpm-tag 1030 INT16)) +(define RPMTAG_FILEDIGESTS (make-rpm-tag 1035 STRING_ARRAY)) +(define RPMTAG_FILELINKTOS (make-rpm-tag 1036 STRING_ARRAY)) +(define RPMTAG_FILEUSERNAME (make-rpm-tag 1039 STRING_ARRAY)) +(define RPMTAG_GROUPNAME (make-rpm-tag 1040 STRING_ARRAY)) +(define RPMTAG_PREFIXES (make-rpm-tag 1098 STRING_ARRAY)) +(define RPMTAG_DIRINDEXES (make-rpm-tag 1116 INT32)) +(define RPMTAG_BASENAMES (make-rpm-tag 1117 STRING_ARRAY)) +(define RPMTAG_DIRNAMES (make-rpm-tag 1118 STRING_ARRAY)) +(define RPMTAG_PAYLOADFORMAT (make-rpm-tag 1124 STRING)) +(define RPMTAG_PAYLOADCOMPRESSOR (make-rpm-tag 1125 STRING)) +(define RPMTAG_LONGFILESIZES (make-rpm-tag 5008 INT64)) +(define RPMTAG_LONGSIZE (make-rpm-tag 5009 INT64)) +;;; The algorithm used to compute the digest of each file, e.g. RPM_HASH_MD5. +(define RPMTAG_FILEDIGESTALGO (make-rpm-tag 5011 INT32)) +;;; RPMTAG_ENCODING specifies the encoding used for strings, e.g. "utf-8". +(define RPMTAG_ENCODING (make-rpm-tag 5062 STRING)) +;;; Compressed payload digest. Its type is a string array, but currently in +;;; practice it is equivalent to STRING, since only the first element is used. +(define RPMTAG_PAYLOADDIGEST (make-rpm-tag 5092 STRING_ARRAY)) +;;; The algorithm used to compute the payload digest, e.g. RPM_HASH_SHA256. +(define RPMTAG_PAYLOADDIGESTALGO (make-rpm-tag 5093 INT32)) +;;; The following are taken from the rpmHashAlgo_e enum in rpmcrypto.h. +(define RPM_HASH_MD5 1) +(define RPM_HASH_SHA256 8) + +;;; Other useful internal definitions. +(define REGION_TAG_COUNT 16) ;number of bytes +(define INT32_MAX (1- (expt 2 32))) ;4294967295 bytes (unsigned) + +(define (rpm-tag->u8-list tag) + "Return the u8 list corresponding to RPM-TAG, a <rpm-tag> object." + (append (u32-number->u8-list (rpm-tag-number tag)) + (u32-number->u8-list (rpm-tag-type tag)))) + +(define-record-type <header-entry> + (make-header-entry tag count value) + header-entry? + (tag header-entry-tag) ;<rpm-tag> + (count header-entry-count) ;number (u32) + (value header-entry-value)) ;string|number|list|... + +(define (entry-type->alignement type) + "Return the byte alignment of TYPE, an RPM header entry type." + (cond ((= INT16 type) 2) + ((= INT32 type) 4) + ((= INT64 type) 8) + (else 1))) + +(define (next-aligned-offset offset alignment) + "Return the next position from OFFSET which satisfies ALIGNMENT." + (if (= 0 (modulo offset alignment)) + offset + (next-aligned-offset (1+ offset) alignment))) + +(define (header-entry->data entry) + "Return the data of ENTRY, a <header-entry> object, as a u8 list." + (let* ((tag (header-entry-tag entry)) + (count (header-entry-count entry)) + (value (header-entry-value entry)) + (number (rpm-tag-number tag)) + (type (rpm-tag-type tag))) + (cond + ((= STRING type) + (unless (string? value) + (error "expected string value for STRING type, got" value)) + (unless (= 1 count) + (error "count must be 1 for STRING type")) + (let ((value (cond ((= (rpm-tag-number RPMTAG_VERSION) number) + ;; Hyphens are not allowed in version strings. + (string-map (match-lambda + (#\- #\+) + (c c)) + value)) + (else value)))) + (append (bytevector->u8-list (string->utf8 value)) + (list 0)))) ;strings must end with null byte + ((= STRING_ARRAY type) + (unless (list? value) + (error "expected a list of strings for STRING_ARRAY type, got" value)) + (unless (= count (length value)) + (error "expected count to be equal to" (length value) 'got count)) + (append-map (lambda (s) + (append (bytevector->u8-list (string->utf8 s)) + (list 0))) ;null byte separated + value)) + ((member type (list INT8 INT16 INT32)) + (if (= 1 count) + (unless (number? value) + (error "expected number value for scalar INT type; got" value)) + (unless (list? value) + (error "expected list value for array INT type; got" value))) + (if (list? value) + (cond ((= INT8 type) value) + ((= INT16 type) (append-map u16-number->u8-list value)) + ((= INT32 type) (append-map u32-number->u8-list value)) + (else (error "unexpected type" type))) + (cond ((= INT8 type) (list value)) + ((= INT16 type) (u16-number->u8-list value)) + ((= INT32 type) (u32-number->u8-list value)) + (else (error "unexpected type" type))))) + ((= BIN type) + (unless (list? value) + (error "expected list value for BIN type; got" value)) + value) + (else (error "unimplemented type" type))))) + +(define (make-header-index+data entries) + "Return the index and data sections as u8 number lists, via multiple values. +An index is composed of four u32 (16 bytes total) quantities, in order: tag, +type, offset and count." + (match (fold (match-lambda* + ((entry (offset . (index . data))) + (let* ((tag (header-entry-tag entry)) + (tag-number (rpm-tag-number tag)) + (tag-type (rpm-tag-type tag)) + (count (header-entry-count entry)) + (data* (header-entry->data entry)) + (alignment (entry-type->alignement tag-type)) + (aligned-offset (next-aligned-offset offset alignment)) + (padding (make-list (- aligned-offset offset) 0))) + (cons (+ aligned-offset (length data*)) + (cons (append index + (u32-number->u8-list tag-number) + (u32-number->u8-list tag-type) + (u32-number->u8-list aligned-offset) + (u32-number->u8-list count)) + (append data padding data*)))))) + '(0 . (() . ())) + entries) + ((offset . (index . data)) + (values index data)))) + +;; Prevent inlining of the variables/procedures accessed by unit tests. +(set! make-header-index+data make-header-index+data) +(set! RPMTAG_ARCH RPMTAG_ARCH) +(set! RPMTAG_LICENSE RPMTAG_LICENSE) +(set! RPMTAG_NAME RPMTAG_NAME) +(set! RPMTAG_OS RPMTAG_OS) +(set! RPMTAG_RELEASE RPMTAG_RELEASE) +(set! RPMTAG_SUMMARY RPMTAG_SUMMARY) +(set! RPMTAG_VERSION RPMTAG_VERSION) + +(define (wrap-in-region-tags header region-tag) + "Wrap HEADER, a header provided as u8-list with REGION-TAG." + (let* ((type (rpm-tag-type region-tag)) + (header-intro (take header 16)) + (header-rest (drop header 16)) + ;; Increment the existing index value to account for the added region + ;; tag index. + (index-length (1+ (u8-list->u32-number + (drop-right (drop header-intro 8) 4)))) ;bytes 8-11 + ;; Increment the data length value to account for the added region + ;; tag data. + (data-length (+ REGION_TAG_COUNT + (u8-list->u32-number + (take-right header-intro 4))))) ;last 4 bytes of intro + (unless (member region-tag (list RPMTAG_HEADERSIGNATURES + RPMTAG_HEADERIMMUTABLE)) + (error "expected RPMTAG_HEADERSIGNATURES or RPMTAG_HEADERIMMUTABLE, got" + region-tag)) + (append (drop-right header-intro 8) ;strip existing index and data lengths + (u32-number->u8-list index-length) + (u32-number->u8-list data-length) + ;; Region tag (16 bytes). + (u32-number->u8-list (rpm-tag-number region-tag)) ;number + (u32-number->u8-list type) ;type + (u32-number->u8-list (- data-length REGION_TAG_COUNT)) ;offset + (u32-number->u8-list REGION_TAG_COUNT) ;count + ;; Immutable region. + header-rest + ;; Region tag trailer (16 bytes). Note: the trailer offset value + ;; is an enforced convention; it has no practical use. + (u32-number->u8-list (rpm-tag-number region-tag)) ;number + (u32-number->u8-list type) ;type + (s32-number->u8-list (* -1 index-length 16)) ;negative offset + (u32-number->u8-list REGION_TAG_COUNT)))) ;count + +(define (bytevector->hex-string bv) + (format #f "~{~2,'0x~}" (bytevector->u8-list bv))) + +(define (files->md5-checksums files) + "Return the MD5 checksums (formatted as hexadecimal strings) for FILES." + (let ((file-md5 (cut file-hash (hash-algorithm md5) <>))) + (map (lambda (f) + (or (and=> (false-if-exception (file-md5 f)) + bytevector->hex-string) + ;; Only regular files (e.g., not directories) can have their + ;; checksum computed. + "")) + files))) + +(define (strip-leading-dot name) + "Remove the leading \".\" from NAME, if present. If a single \".\" is +encountered, translate it to \"/\"." + (match name + ("." "/") ;special case + ((? (cut string-prefix? "." <>)) + (string-drop name 1)) + (x name))) + +;;; An extensive list of required and optional FHS directories, per its 3.0 +;;; revision. +(define %fhs-directories + (list "/bin" "/boot" "/dev" + "/etc" "/etc/opt" "/etc/X11" "/etc/sgml" "/etc/xml" + "/home" "/root" "/lib" "/media" "/mnt" + "/opt" "/opt/bin" "/opt/doc" "/opt/include" + "/opt/info" "/opt/lib" "/opt/man" + "/run" "/sbin" "/srv" "/sys" "/tmp" + "/usr" "/usr/bin" "/usr/include" "/usr/libexec" + "/usr/share" "/usr/share/applications" + "/usr/share/color" "/usr/share/dict" "/usr/share/doc" "/usr/share/games" + "/usr/share/icons" "/usr/share/icons/hicolor" + "/usr/share/icons/hicolor/48x48" + "/usr/share/icons/hicolor/48x48/apps" + "/usr/share/icons/hicolor/scalable" + "/usr/share/icons/hicolor/scalable/apps" + "/usr/share/info" "/usr/share/locale" "/usr/share/man" + "/usr/share/metainfo" "/usr/share/misc" + "/usr/share/nls" "/usr/share/ppd" "/usr/share/sgml" + "/usr/share/terminfo" "/usr/share/tmac" "/usr/share/xml" + "/usr/share/zoneinfo" "/usr/local" "/usr/local/bin" "/usr/local/etc" + "/usr/local/games" "/usr/local/include" "/usr/local/lib" + "/usr/local/man" "/usr/local/sbin" "/usr/local/sbin" "/usr/local/share" + "/usr/local/src" "/var" "/var/account" "/var/backups" + "/var/cache" "/var/cache/fonts" "/var/cache/man" "/var/cache/www" + "/var/crash" "/var/cron" "/var/games" "/var/mail" "/var/msgs" + "/var/lib" "/var/lib/color" "/var/lib/hwclock" "/var/lib/misc" + "/var/local" "/var/lock" "/var/log" "/var/opt" "/var/preserve" + "/var/run" "/var/spool" "/var/spool/lpd" "/var/spool/mqueue" + "/var/spool/news" "/var/spool/rwho" "/var/spool/uucp" + "/var/tmp" "/var/yp")) + +(define (fhs-directory? file-name) + "Predicate to check if FILE-NAME is a known File Hierarchy Standard (FHS) +directory." + (member (strip-leading-dot file-name) %fhs-directories)) + +(define (directory->file-entries directory) + "Return the file lists triplet header entries for the files found under +DIRECTORY." + (with-directory-excursion directory + ;; Skip the initial "." directory, as its name would get concatenated with + ;; the "./" dirname and fail to match "." in the payload. + (let* ((files (cdr (find-files "." #:directories? #t))) + (file-stats (map lstat files)) + (directories + (append (list ".") + (filter-map (match-lambda + ((index . file) + (let ((st (list-ref file-stats index))) + (and (eq? 'directory (stat:type st)) + file)))) + (list-transduce (tenumerate) rcons files)))) + ;; Omit any FHS directories found in FILES to avoid the RPM package + ;; from owning them. This can occur when symlinks directives such + ;; as "/usr/bin/hello -> bin/hello" are used. + (package-files package-file-stats + (unzip2 (reverse + (fold (lambda (file stat res) + (if (fhs-directory? file) + res + (cons (list file stat) res))) + '() files file-stats)))) + + ;; When provided with the index of a file, the directory index must + ;; return the index of the corresponding directory entry. + (dirindexes (map (lambda (d) + (list-index (cut string=? <> d) directories)) + (map dirname package-files))) + ;; The files owned are those appearing in 'basenames'; own them + ;; all. + (basenames (map basename package-files)) + ;; The directory names must end with a trailing "/". + (dirnames (map (compose strip-leading-dot (cut string-append <> "/")) + directories)) + ;; Note: All the file-related entries must have the same length as + ;; the basenames entry. + (symlink-targets (map (lambda (f) + (if (symbolic-link? f) + (readlink f) + "")) ;unused + package-files)) + (file-modes (map stat:mode package-file-stats)) + (file-sizes (map stat:size package-file-stats)) + (file-md5s (files->md5-checksums package-files))) + (let ((basenames-length (length basenames)) + (dirindexes-length (length dirindexes))) + (unless (= basenames-length dirindexes-length) + (error "length mismatch for dirIndexes; expected/actual" + basenames-length dirindexes-length)) + (append + (if (> (apply max file-sizes) INT32_MAX) + (list (make-header-entry RPMTAG_LONGFILESIZES (length file-sizes) + file-sizes) + (make-header-entry RPMTAG_LONGSIZE 1 + (reduce + 0 file-sizes))) + (list (make-header-entry RPMTAG_FILESIZES (length file-sizes) + file-sizes) + (make-header-entry RPMTAG_SIZE 1 (reduce + 0 file-sizes)))) + (list + (make-header-entry RPMTAG_FILEMODES (length file-modes) file-modes) + (make-header-entry RPMTAG_FILEDIGESTS (length file-md5s) file-md5s) + (make-header-entry RPMTAG_FILEDIGESTALGO 1 RPM_HASH_MD5) + (make-header-entry RPMTAG_FILELINKTOS (length symlink-targets) + symlink-targets) + (make-header-entry RPMTAG_FILEUSERNAME basenames-length + (make-list basenames-length "root")) + (make-header-entry RPMTAG_GROUPNAME basenames-length + (make-list basenames-length "root")) + ;; The dirindexes, basenames and dirnames tags form the so-called RPM + ;; "path triplet". + (make-header-entry RPMTAG_DIRINDEXES dirindexes-length dirindexes) + (make-header-entry RPMTAG_BASENAMES basenames-length basenames) + (make-header-entry RPMTAG_DIRNAMES (length dirnames) dirnames))))))) + +(define (make-header entries) + "Return the u8 list of a RPM header containing ENTRIES, a list of +<rpm-entry> objects." + (let* ((entries (sort entries (lambda (x y) + (< (rpm-tag-number (header-entry-tag x)) + (rpm-tag-number (header-entry-tag y)))))) + (count (length entries)) + (index data (make-header-index+data entries))) + (append header-intro ;8 bytes + (u32-number->u8-list count) ;4 bytes + (u32-number->u8-list (length data)) ;4 bytes + ;; Now starts the header index, which can contain up to 32 entries + ;; of 16 bytes each. + index data))) + +(define* (generate-header name version + payload-digest + payload-directory + payload-compressor + #:key + relocatable? + prein-file postin-file + preun-file postun-file + (target %host-type) + (release "0") + (license "N/A") + (summary "RPM archive generated by GNU Guix.") + (os "Linux")) ;see rpmrc.in + "Return the u8 list corresponding to the Header section. PAYLOAD-DIGEST is +the SHA256 checksum string of the compressed payload. PAYLOAD-DIRECTORY is +the directory containing the payload files. PAYLOAD-COMPRESSOR is the name of +the compressor used to compress the CPIO payload, such as \"none\", \"gz\", +\"xz\" or \"zstd\"." + (let* ((rpm-arch (gnu-machine-type->rpm-arch + (gnu-system-triplet->machine-type target))) + (file->string (cut call-with-input-file <> get-string-all)) + (prein-script (and=> prein-file file->string)) + (postin-script (and=> postin-file file->string)) + (preun-script (and=> preun-file file->string)) + (postun-script (and=> postun-file file->string))) + (wrap-in-region-tags + (make-header (append + (list (make-header-entry RPMTAG_HEADERI18NTABLE 1 (list "C")) + (make-header-entry RPMTAG_NAME 1 name) + (make-header-entry RPMTAG_VERSION 1 version) + (make-header-entry RPMTAG_RELEASE 1 release) + (make-header-entry RPMTAG_SUMMARY 1 summary) + (make-header-entry RPMTAG_LICENSE 1 license) + (make-header-entry RPMTAG_OS 1 os) + (make-header-entry RPMTAG_ARCH 1 rpm-arch)) + (directory->file-entries payload-directory) + (if relocatable? + ;; Note: RPMTAG_PREFIXES must not have a trailing + ;; slash, unless it's '/'. This allows installing the + ;; package via 'rpm -i --prefix=/tmp', for example. + (list (make-header-entry RPMTAG_PREFIXES 1 (list "/"))) + '()) + (if prein-script + (list (make-header-entry RPMTAG_PREIN 1 prein-script)) + '()) + (if postin-script + (list (make-header-entry RPMTAG_POSTIN 1 postin-script)) + '()) + (if preun-script + (list (make-header-entry RPMTAG_PREUN 1 preun-script)) + '()) + (if postun-script + (list (make-header-entry RPMTAG_POSTUN 1 postun-script)) + '()) + (if (string=? "none" payload-compressor) + '() + (list (make-header-entry RPMTAG_PAYLOADCOMPRESSOR 1 + payload-compressor))) + (list (make-header-entry RPMTAG_ENCODING 1 "utf-8") + (make-header-entry RPMTAG_PAYLOADFORMAT 1 "cpio") + (make-header-entry RPMTAG_PAYLOADDIGEST 1 + (list payload-digest)) + (make-header-entry RPMTAG_PAYLOADDIGESTALGO 1 + RPM_HASH_SHA256)))) + RPMTAG_HEADERIMMUTABLE))) + + +;;; +;;; Signature section +;;; + +;;; Header sha256 checksum. +(define RPMSIGTAG_SHA256 (make-rpm-tag 273 STRING)) +;;; Uncompressed payload size. +(define RPMSIGTAG_PAYLOADSIZE (make-rpm-tag 1007 INT32)) +;;; Header and compressed payload combined size. +(define RPMSIGTAG_SIZE (make-rpm-tag 1000 INT32)) +;;; Uncompressed payload size (when size > max u32). +(define RPMSIGTAG_LONGARCHIVESIZE (make-rpm-tag 271 INT64)) +;;; Header and compressed payload combined size (when size > max u32). +(define RPMSIGTAG_LONGSIZE (make-rpm-tag 270 INT64)) +;;; Extra space reserved for signatures (typically 32 bytes). +(define RPMSIGTAG_RESERVEDSPACE (make-rpm-tag 1008 BIN)) + +(define (generate-signature header-sha256 + header+compressed-payload-size + ;; uncompressed-payload-size + ) + "Return the u8 list representing a signature header containing the +HEADER-SHA256 (a string) and the PAYLOAD-SIZE, which is the combined size of +the header and compressed payload." + (define size-tag (if (> header+compressed-payload-size INT32_MAX) + RPMSIGTAG_LONGSIZE + RPMSIGTAG_SIZE)) + (wrap-in-region-tags + (make-header (list (make-header-entry RPMSIGTAG_SHA256 1 header-sha256) + (make-header-entry size-tag 1 + header+compressed-payload-size) + ;; (make-header-entry RPMSIGTAG_PAYLOADSIZE 1 + ;; uncompressed-payload-size) + ;; Reserve 32 bytes of extra space in case users would + ;; like to add signatures, as done in rpmGenerateSignature. + (make-header-entry RPMSIGTAG_RESERVEDSPACE 32 + (make-list 32 0)))) + RPMTAG_HEADERSIGNATURES)) + +(define (assemble-rpm-metadata lead signature header) + "Align and append the various u8 list components together, and return the +result as a bytevector." + (let* ((offset (+ (length lead) (length signature))) + (header-offset (next-aligned-offset offset 8)) + (padding (make-list (- header-offset offset) 0))) + ;; The Header is 8-bytes aligned. + (u8-list->bytevector (append lead signature padding header)))) diff --git a/guix/scripts.scm b/guix/scripts.scm index 4de8bc23b3..5d11ce7fe9 100644 --- a/guix/scripts.scm +++ b/guix/scripts.scm @@ -28,7 +28,6 @@ #:use-module (guix monads) #:use-module (guix packages) #:use-module (guix derivations) - #:use-module ((guix profiles) #:select (%profile-directory)) #:autoload (guix describe) (current-profile-date) #:use-module (guix build syscalls) #:use-module (srfi srfi-1) @@ -321,11 +320,11 @@ THRESHOLDS is a pair (ABSOLUTE-THRESHOLD . RELATIVE-THRESHOLD)." absolute-threshold-in-bytes)) (warning (G_ "only ~,1f GiB of free space available on ~a~%") (/ available 1. GiB) (%store-prefix)) - (display-hint (format #f (G_ "Consider deleting old profile + (display-hint (G_ "Consider deleting old profile generations and collecting garbage, along these lines: @example guix gc --delete-generations=1m -@end example\n")))))) +@end example\n"))))) ;;; scripts.scm ends here diff --git a/guix/scripts/archive.scm b/guix/scripts/archive.scm index 3b2bdee835..a7ff1593a6 100644 --- a/guix/scripts/archive.scm +++ b/guix/scripts/archive.scm @@ -18,7 +18,6 @@ ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. (define-module (guix scripts archive) - #:use-module (guix config) #:use-module (guix utils) #:use-module (guix combinators) #:use-module ((guix build utils) #:select (mkdir-p)) diff --git a/guix/scripts/build.scm b/guix/scripts/build.scm index b4437172d7..72a24f91ac 100644 --- a/guix/scripts/build.scm +++ b/guix/scripts/build.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2012-2022 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2012-2023 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2013 Mark H Weaver <mhw@netris.org> ;;; Copyright © 2020 Marius Bakke <mbakke@fastmail.com> ;;; Copyright © 2020 Ricardo Wurmus <rekado@elephly.net> @@ -27,7 +27,6 @@ #:use-module (guix store) #:use-module (guix derivations) #:use-module (guix packages) - #:use-module (guix memoization) #:use-module (guix utils) #:use-module (guix monads) #:use-module (guix gexp) @@ -36,10 +35,8 @@ #:autoload (guix http-client) (http-fetch http-get-error?) #:use-module (ice-9 format) #:use-module (ice-9 match) - #:use-module (ice-9 vlist) #:use-module (srfi srfi-1) #:use-module (srfi srfi-9) - #:use-module (srfi srfi-11) #:use-module (srfi srfi-26) #:use-module (srfi srfi-34) #:use-module (srfi srfi-35) @@ -377,12 +374,12 @@ use '--no-offload' instead~%"))) arg) (if closest (display-hint - (format #f (G_ "Did you mean @code{~a}? + (G_ "Did you mean @code{~a}? Try @option{--list-targets} to view available targets.~%") - closest)) + closest) (display-hint - (format #f (G_ "\ -Try @option{--list-targets} to view available targets.~%")))) + (G_ "\ +Try @option{--list-targets} to view available targets.~%"))) (exit 1)))))))) (define %standard-native-build-options @@ -404,12 +401,12 @@ Try @option{--list-targets} to view available targets.~%")))) arg) (if closest (display-hint - (format #f (G_ "Did you mean @code{~a}? + (G_ "Did you mean @code{~a}? Try @option{--list-systems} to view available system types.~%") - closest)) + closest) (display-hint - (format #f (G_ "\ -Try @option{--list-systems} to view available system types.~%")))) + (G_ "\ +Try @option{--list-systems} to view available system types.~%"))) (exit 1)))))))) diff --git a/guix/scripts/challenge.scm b/guix/scripts/challenge.scm index 620a1762a1..4821e11bf6 100644 --- a/guix/scripts/challenge.scm +++ b/guix/scripts/challenge.scm @@ -24,7 +24,6 @@ #:use-module (guix utils) #:use-module (guix monads) #:use-module (guix base32) - #:use-module (guix packages) #:use-module ((guix progress) #:hide (dump-port*)) #:use-module (guix serialization) #:use-module (guix substitutes) diff --git a/guix/scripts/deploy.scm b/guix/scripts/deploy.scm index ef6f9acc86..14ce736174 100644 --- a/guix/scripts/deploy.scm +++ b/guix/scripts/deploy.scm @@ -26,7 +26,6 @@ #:use-module (guix store) #:use-module (guix gexp) #:use-module (guix ui) - #:use-module (guix utils) #:use-module ((guix status) #:select (with-status-verbosity)) #:use-module (guix diagnostics) #:use-module (guix i18n) diff --git a/guix/scripts/describe.scm b/guix/scripts/describe.scm index 80cd0ce00a..5523aa0ec2 100644 --- a/guix/scripts/describe.scm +++ b/guix/scripts/describe.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2018, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2018, 2019, 2020, 2021, 2023 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2018 Oleg Pykhalov <go.wigust@gmail.com> ;;; Copyright © 2020 Ekaitz Zarraga <ekaitz@elenq.tech> ;;; Copyright © 2021 Simon Tournier <zimon.toutoune@gmail.com> @@ -154,10 +154,10 @@ within a Git checkout." (channel (repository->guix-channel (dirname program)))) (unless channel (report-error (G_ "failed to determine origin~%")) - (display-hint (format #f (G_ "Perhaps this + (display-hint (G_ "Perhaps this @command{guix} command was not obtained with @command{guix pull}? Its version string is ~a.~%") - %guix-version)) + %guix-version) (exit 1)) (match fmt diff --git a/guix/scripts/discover.scm b/guix/scripts/discover.scm index dadade81bb..8970f835c9 100644 --- a/guix/scripts/discover.scm +++ b/guix/scripts/discover.scm @@ -23,7 +23,6 @@ #:use-module (guix scripts) #:use-module (guix ui) #:use-module (guix utils) - #:use-module (guix build syscalls) #:use-module (guix build utils) #:use-module (guix scripts publish) #:use-module (avahi) diff --git a/guix/scripts/download.scm b/guix/scripts/download.scm index 5a91390358..0ab5c8c39c 100644 --- a/guix/scripts/download.scm +++ b/guix/scripts/download.scm @@ -35,11 +35,8 @@ #:use-module (web uri) #:use-module (ice-9 match) #:use-module (srfi srfi-1) - #:use-module (srfi srfi-14) #:use-module (srfi srfi-26) #:use-module (srfi srfi-37) - #:use-module (rnrs bytevectors) - #:use-module (ice-9 binary-ports) #:export (guix-download)) diff --git a/guix/scripts/edit.scm b/guix/scripts/edit.scm index 8e777d1405..5ce2870c5a 100644 --- a/guix/scripts/edit.scm +++ b/guix/scripts/edit.scm @@ -22,7 +22,8 @@ #:use-module (guix ui) #:use-module (guix scripts) #:use-module ((guix scripts build) #:select (%standard-build-options)) - #:use-module (guix utils) + #:use-module ((guix diagnostics) + #:select (location-file location-line)) #:use-module (gnu packages) #:use-module (srfi srfi-1) #:use-module (srfi srfi-37) diff --git a/guix/scripts/environment.scm b/guix/scripts/environment.scm index 46435ae48e..a4939ea63c 100644 --- a/guix/scripts/environment.scm +++ b/guix/scripts/environment.scm @@ -514,6 +514,11 @@ by running 'set' in the shell." (catch #t (lambda () (load-profile profile manifest #:pure? #t) + + ;; Mark the terminal as "unknown" do avoid ANSI escape codes such + ;; as bracketed paste that would mess up the output of the script. + (setenv "TERM" "") + (setenv "GUIX_ENVIRONMENT" profile) (close-fdes controller) (login-tty inferior) @@ -664,8 +669,8 @@ command name." (let ((closest (string-closest executable available #:threshold 12))) (unless (or (not closest) (string=? closest executable)) - (display-hint (format #f (G_ "Did you mean '~a'?~%") - closest))))))))) + (display-hint (G_ "Did you mean '~a'?~%") + closest)))))))) (define* (launch-environment/fork command profile manifest #:key pure? (white-list '())) @@ -767,14 +772,17 @@ WHILE-LIST." (append (override-user-mappings user home - (append user-mappings - ;; Share current working directory, unless asked not to. - (if map-cwd? - (list (file-system-mapping - (source cwd) - (target cwd) - (writable? #t))) - '()))) + (append + ;; Share current working directory, unless asked not to. + (if map-cwd? + (list (file-system-mapping + (source cwd) + (target cwd) + (writable? #t))) + '()) + ;; Add the user mappings *after* the current working directory + ;; so that a user can layer bind mounts on top of it. + user-mappings)) ;; Mappings for the union closure of all inputs. (map (lambda (dir) (file-system-mapping diff --git a/guix/scripts/graph.scm b/guix/scripts/graph.scm index 6847dd1962..c075e0ec29 100644 --- a/guix/scripts/graph.scm +++ b/guix/scripts/graph.scm @@ -20,7 +20,6 @@ (define-module (guix scripts graph) #:use-module (guix ui) #:use-module (guix graph) - #:use-module (guix grafts) #:use-module (guix scripts) #:use-module (guix packages) #:use-module (guix monads) diff --git a/guix/scripts/hash.scm b/guix/scripts/hash.scm index 4e792c6a03..6dc67a2416 100644 --- a/guix/scripts/hash.scm +++ b/guix/scripts/hash.scm @@ -23,18 +23,14 @@ (define-module (guix scripts hash) #:use-module (gcrypt hash) - #:use-module (guix serialization) #:use-module (guix ui) #:use-module (guix hash) #:use-module (guix scripts) #:use-module (guix base16) #:use-module (guix base32) #:autoload (guix base64) (base64-encode) - #:use-module (ice-9 binary-ports) - #:use-module (rnrs files) #:use-module (ice-9 match) #:use-module (srfi srfi-1) - #:use-module (srfi srfi-11) #:use-module (srfi srfi-26) #:use-module (srfi srfi-37) #:autoload (disarchive git-hash) (git-hash-file git-hash-directory) diff --git a/guix/scripts/home.scm b/guix/scripts/home.scm index 1d8aae727e..954bb0045f 100644 --- a/guix/scripts/home.scm +++ b/guix/scripts/home.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2021 Andrew Tropin <andrew@trop.in> +;;; Copyright © 2021, 2023 Andrew Tropin <andrew@trop.in> ;;; Copyright © 2021 Xinglu Chen <public@yoctocell.xyz> ;;; Copyright © 2021 Pierre Langlois <pierre.langlois@gmx.com> ;;; Copyright © 2021 Oleg Pykhalov <go.wigust@gmail.com> @@ -22,9 +22,7 @@ ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. (define-module (guix scripts home) - #:use-module (gnu packages admin) #:use-module ((gnu services) #:hide (delete)) - #:use-module (gnu packages) #:autoload (gnu packages base) (coreutils) #:autoload (gnu packages bash) (bash) #:autoload (gnu packages gnupg) (guile-gcrypt) @@ -409,6 +407,7 @@ immediately. Return the exit status of the process in the container." network?) "Perform ACTION for home environment. " + (ensure-profile-directory) (define println (cut format #t "~a~%" <>)) @@ -473,7 +472,6 @@ ACTION must be one of the sub-commands that takes a home environment declaration as an argument (a file name.) OPTS is the raw alist of options resulting from command-line parsing." (define (ensure-home-environment file-or-exp obj) - (ensure-profile-directory) (unless (home-environment? obj) (leave (G_ "'~a' does not return a home environment~%") file-or-exp)) @@ -572,10 +570,10 @@ argument list and OPTS is the option alist." (cut import-manifest manifest destination <>)) (info (G_ "'~a' populated with all the Home configuration files~%") destination) - (display-hint (format #f (G_ "\ + (display-hint (G_ "\ Run @command{guix home reconfigure ~a/home-configuration.scm} to effectively deploy the home environment described by these files.\n") - destination)))) + destination))) ((describe) (let ((list-installed-regex (assoc-ref opts 'list-installed))) (match (generation-number %guix-home) diff --git a/guix/scripts/home/edit.scm b/guix/scripts/home/edit.scm index a6c05675b3..d039179a10 100644 --- a/guix/scripts/home/edit.scm +++ b/guix/scripts/home/edit.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2022 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2022, 2023 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -40,8 +40,8 @@ '())) (closest (string-closest type available))) (unless (or (not closest) (string=? closest type)) - (display-hint (format #f (G_ "Did you mean @code{~a}?~%") - closest)))) + (display-hint (G_ "Did you mean @code{~a}?~%") + closest))) (exit 1)) diff --git a/guix/scripts/import.scm b/guix/scripts/import.scm index 2bca927d63..f84a964a53 100644 --- a/guix/scripts/import.scm +++ b/guix/scripts/import.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2012-2014, 2020-2022 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2012-2014, 2020-2023 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2014 David Thompson <davet@gnu.org> ;;; Copyright © 2018 Kyle Meyer <kyle@kyleam.com> ;;; Copyright © 2019, 2022 Ricardo Wurmus <rekado@elephly.net> @@ -28,9 +28,6 @@ #:use-module (guix read-print) #:use-module (guix utils) #:use-module (srfi srfi-1) - #:use-module (srfi srfi-11) - #:use-module (srfi srfi-26) - #:use-module (srfi srfi-37) #:use-module (ice-9 format) #:use-module (ice-9 match) #:export (%standard-import-options @@ -106,6 +103,5 @@ Run IMPORTER with ARGS.\n")) (let ((hint (string-closest importer importers #:threshold 3))) (report-error (G_ "~a: invalid importer~%") importer) (when hint - (display-hint - (format #f (G_ "Did you mean @code{~a}?~%") hint))) + (display-hint (G_ "Did you mean @code{~a}?~%") hint)) (exit 1)))))) diff --git a/guix/scripts/offload.scm b/guix/scripts/offload.scm index 578b3b9888..7b76126d35 100644 --- a/guix/scripts/offload.scm +++ b/guix/scripts/offload.scm @@ -39,7 +39,6 @@ #:autoload (guix derivations) (read-derivation-from-file derivation-file-name build-derivations) - #:autoload (guix serialization) (nar-error? nar-error-file) #:autoload (guix nar) (restore-file-set) #:use-module ((guix utils) #:select (%current-system)) #:use-module ((guix build syscalls) @@ -220,7 +219,12 @@ number of seconds after which the connection times out." (session (make-session #:user (build-machine-user machine) #:host (build-machine-name machine) #:port (build-machine-port machine) - #:timeout 10 ;initial timeout (seconds) + ;; Multiple derivations may be offloaded in + ;; parallel, and when there is a large amount + ;; of data to be sent, it can choke lower + ;; bandwidth connections and cause timeouts, so + ;; set it to a large enough value. + #:timeout 30 ;initial timeout (seconds) ;; #:log-verbosity 'protocol #:identity (build-machine-private-key machine) diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm index f65642fb85..0dc9979194 100644 --- a/guix/scripts/pack.scm +++ b/guix/scripts/pack.scm @@ -1,11 +1,11 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2015, 2017-2022 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2015, 2017-2023 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2017, 2018 Ricardo Wurmus <rekado@elephly.net> ;;; Copyright © 2018 Konrad Hinsen <konrad.hinsen@fastmail.net> ;;; Copyright © 2018 Chris Marusich <cmmarusich@gmail.com> ;;; Copyright © 2018 Efraim Flashner <efraim@flashner.co.il> ;;; Copyright © 2020 Tobias Geerinckx-Rice <me@tobias.gr> -;;; Copyright © 2020, 2021, 2022 Maxim Cournoyer <maxim.cournoyer@gmail.com> +;;; Copyright © 2020, 2021, 2022, 2023 Maxim Cournoyer <maxim.cournoyer@gmail.com> ;;; Copyright © 2020 Eric Bavier <bavier@posteo.net> ;;; Copyright © 2022 Alex Griffin <a@ajgrf.com> ;;; @@ -28,7 +28,6 @@ #:use-module (guix scripts) #:use-module (guix ui) #:use-module (guix gexp) - #:use-module ((guix build utils) #:select (%xz-parallel-args)) #:use-module (guix utils) #:use-module (guix store) #:use-module ((guix status) #:select (with-status-verbosity)) @@ -54,7 +53,6 @@ #:use-module ((gnu packages compression) #:hide (zip)) #:use-module (gnu packages guile) #:use-module (gnu packages base) - #:autoload (gnu packages package-management) (guix) #:autoload (gnu packages gnupg) (guile-gcrypt) #:autoload (gnu packages guile) (guile2.0-json guile-json) #:use-module (srfi srfi-1) @@ -67,6 +65,7 @@ self-contained-tarball debian-archive + rpm-archive docker-image squashfs-image @@ -194,104 +193,150 @@ target the profile's @file{bin/env} file: (leave (G_ "~a: invalid symlink specification~%") arg)))) - -;;; -;;; Tarball format. -;;; -(define* (self-contained-tarball/builder profile - #:key (profile-name "guix-profile") - (compressor (first %compressors)) - localstatedir? - (symlinks '()) - (archiver tar) - (extra-options '())) - "Return the G-Expression of the builder used for self-contained-tarball." +(define (set-utf8-locale profile) + "Configure the environment to use the \"en_US.utf8\" locale provided by the +GLIBC-UT8-LOCALES package." + ;; Arrange to not depend on 'glibc-utf8-locales' when using '--bootstrap'. + (and (or (not (profile? profile)) + (profile-locales? profile)) + #~(begin + (setenv "GUIX_LOCPATH" + #+(file-append glibc-utf8-locales "/lib/locale")) + (setlocale LC_ALL "en_US.utf8")))) + +(define* (populate-profile-root profile + #:key (profile-name "guix-profile") + target + localstatedir? + deduplicate? + (symlinks '())) + "Populate the root profile directory with SYMLINKS and a Guix database, when +LOCALSTATEDIR? is set. When DEDUPLICATE? is true, deduplicate the store +items, which relies on hard links." (define database (and localstatedir? (file-append (store-database (list profile)) "/db/db.sqlite"))) - (define set-utf8-locale - ;; Arrange to not depend on 'glibc-utf8-locales' when using '--bootstrap'. - (and (or (not (profile? profile)) - (profile-locales? profile)) - #~(begin - (setenv "GUIX_LOCPATH" - #+(file-append glibc-utf8-locales "/lib/locale")) - (setlocale LC_ALL "en_US.utf8")))) + (define bootstrap? + ;; Whether a '--bootstrap' environment is needed, for testing purposes. + ;; XXX: Infer that from available info. + (and (not database) (not (profile-locales? profile)))) (define (import-module? module) ;; Since we don't use deduplication support in 'populate-store', don't ;; import (guix store deduplication) and its dependencies, which includes - ;; Guile-Gcrypt. That way we can run tests with '--bootstrap'. + ;; Guile-Gcrypt, unless DEDUPLICATE? is #t. This makes it possible to run + ;; tests with '--bootstrap'. (and (not-config? module) - (not (equal? '(guix store deduplication) module)))) + (or deduplicate? (not (equal? '(guix store deduplication) module))))) - (with-imported-modules (source-module-closure - `((guix build pack) - (guix build store-copy) - (guix build utils) - (guix build union) - (gnu build install)) - #:select? import-module?) - #~(begin - (use-modules (guix build pack) - (guix build store-copy) - (guix build utils) - ((guix build union) #:select (relative-file-name)) - (gnu build install) - (srfi srfi-1) - (srfi srfi-26) - (ice-9 match)) + (computed-file "profile-directory" + (with-imported-modules (source-module-closure + `((guix build pack) + (guix build store-copy) + (guix build utils) + (guix build union) + (gnu build install)) + #:select? import-module?) + #~(begin + (use-modules (guix build pack) + (guix build store-copy) + (guix build utils) + ((guix build union) #:select (relative-file-name)) + (gnu build install) + (srfi srfi-1) + (srfi srfi-26) + (ice-9 match)) + + (define symlink->directives + ;; Return "populate directives" to make the given symlink and its + ;; parent directories. + (match-lambda + ((source '-> target) + (let ((target (string-append #$profile "/" target)) + (parent (dirname source))) + ;; Never add a 'directory' directive for "/" so as to + ;; preserve its ownership when extracting the archive (see + ;; below), and also because this would lead to adding the + ;; same entries twice in the tarball. + `(,@(if (string=? parent "/") + '() + `((directory ,parent))) + ;; Use a relative file name for compatibility with + ;; relocatable packs. + (,source -> ,(relative-file-name parent target))))))) + + (define directives + ;; Fully-qualified symlinks. + (append-map symlink->directives '#$symlinks)) - (define %root "root") + ;; Make sure non-ASCII file names are properly handled. + #+(set-utf8-locale profile) - (define symlink->directives - ;; Return "populate directives" to make the given symlink and its - ;; parent directories. - (match-lambda - ((source '-> target) - (let ((target (string-append #$profile "/" target)) - (parent (dirname source))) - ;; Never add a 'directory' directive for "/" so as to - ;; preserve its ownership when extracting the archive (see - ;; below), and also because this would lead to adding the - ;; same entries twice in the tarball. - `(,@(if (string=? parent "/") - '() - `((directory ,parent))) - ;; Use a relative file name for compatibility with - ;; relocatable packs. - (,source -> ,(relative-file-name parent target))))))) + ;; Note: there is not much to gain here with deduplication and there + ;; is the overhead of the '.links' directory, so turn it off by + ;; default. Furthermore GNU tar < 1.30 sometimes fails to extract + ;; tarballs with hard links: + ;; <http://lists.gnu.org/archive/html/bug-tar/2017-11/msg00009.html>. + (populate-store (list "profile") #$output + #:deduplicate? #$deduplicate?) - (define directives - ;; Fully-qualified symlinks. - (append-map symlink->directives '#$symlinks)) + (when #+localstatedir? + (install-database-and-gc-roots #$output #+database #$profile + #:profile-name #$profile-name)) + + ;; Create SYMLINKS. + (for-each (cut evaluate-populate-directive <> #$output) + directives))) + #:local-build? #f + #:guile (if bootstrap? %bootstrap-guile (default-guile)) + #:options (list #:references-graphs `(("profile" ,profile)) + #:target target))) + + +;;; +;;; Tarball format. +;;; +(define* (self-contained-tarball/builder profile + #:key (profile-name "guix-profile") + target + localstatedir? + deduplicate? + symlinks + compressor + archiver) + "Return a GEXP that can build a self-contained tarball." + + (define root (populate-profile-root profile + #:profile-name profile-name + #:target target + #:localstatedir? localstatedir? + #:deduplicate? deduplicate? + #:symlinks symlinks)) + + (with-imported-modules (source-module-closure '((guix build pack) + (guix build utils))) + #~(begin + (use-modules (guix build pack) + (guix build utils)) ;; Make sure non-ASCII file names are properly handled. - #+set-utf8-locale + #+(set-utf8-locale profile) (define tar #+(file-append archiver "/bin/tar")) - ;; Note: there is not much to gain here with deduplication and there - ;; is the overhead of the '.links' directory, so turn it off. - ;; Furthermore GNU tar < 1.30 sometimes fails to extract tarballs - ;; with hard links: - ;; <http://lists.gnu.org/archive/html/bug-tar/2017-11/msg00009.html>. - (populate-store (list "profile") %root #:deduplicate? #f) + (define %root (if #$localstatedir? "." #$root)) - (when #+localstatedir? - (install-database-and-gc-roots %root #+database #$profile - #:profile-name #$profile-name)) + (when #$localstatedir? + ;; Fix the permission of the Guix database file, which was made + ;; read-only when copied to the store in populate-profile-root. + (copy-recursively #$root %root) + (chmod (string-append %root "/var/guix/db/db.sqlite") #o644)) - ;; Create SYMLINKS. - (for-each (cut evaluate-populate-directive <> %root) - directives) - - ;; Create the tarball. (with-directory-excursion %root ;; GNU Tar recurses directories by default. Simply add the whole - ;; current directory, which contains all the generated files so far. + ;; current directory, which contains all the files to be archived. ;; This avoids creating duplicate files in the archives that would ;; be stored as hard links by GNU Tar. (apply invoke tar "-cvf" #$output "." @@ -320,17 +365,16 @@ added to the pack." (warning (G_ "entry point not supported in the '~a' format~%") 'tarball)) - (gexp->derivation - (string-append name ".tar" - (compressor-extension compressor)) - (self-contained-tarball/builder profile - #:profile-name profile-name - #:compressor compressor - #:localstatedir? localstatedir? - #:symlinks symlinks - #:archiver archiver) - #:target target - #:references-graphs `(("profile" ,profile)))) + (gexp->derivation (string-append name ".tar" + (compressor-extension compressor)) + (self-contained-tarball/builder profile + #:profile-name profile-name + #:target target + #:localstatedir? localstatedir? + #:deduplicate? deduplicate? + #:symlinks symlinks + #:compressor compressor + #:archiver archiver))) ;;; @@ -676,18 +720,19 @@ Valid compressors are: ~a~%") compressor-name %valid-compressors))) 'deb)) (define data-tarball - (computed-file (string-append "data.tar" - (compressor-extension compressor)) - (self-contained-tarball/builder - profile - #:profile-name profile-name - #:compressor compressor - #:localstatedir? localstatedir? - #:symlinks symlinks - #:archiver archiver) - #:local-build? #f ;allow offloading - #:options (list #:references-graphs `(("profile" ,profile)) - #:target target))) + (computed-file (string-append "data.tar" (compressor-extension + compressor)) + (self-contained-tarball/builder profile + #:target target + #:profile-name profile-name + #:localstatedir? localstatedir? + #:deduplicate? deduplicate? + #:symlinks symlinks + #:compressor compressor + #:archiver archiver) + #:local-build? #f ;allow offloading + #:options (list #:references-graphs `(("profile" ,profile)) + #:target target))) (define build (with-extensions (list guile-gcrypt) @@ -702,6 +747,7 @@ Valid compressors are: ~a~%") compressor-name %valid-compressors))) (guix build utils) (guix profiles) (ice-9 match) + (ice-9 optargs) (srfi srfi-1)) (define machine-type @@ -762,32 +808,23 @@ Valid compressors are: ~a~%") compressor-name %valid-compressors))) (copy-file #+data-tarball data-tarball-file-name) - (define (keyword-ref lst keyword) - (match (memq keyword lst) - ((_ value . _) value) - (#f #f))) - ;; Generate the control archive. - (define control-file - (keyword-ref '#$extra-options #:control-file)) - - (define postinst-file - (keyword-ref '#$extra-options #:postinst-file)) - - (define triggers-file - (keyword-ref '#$extra-options #:triggers-file)) + (let-keywords '#$extra-options #f + ((control-file #f) + (postinst-file #f) + (triggers-file #f)) - (define control-tarball-file-name - (string-append "control.tar" - #$(compressor-extension compressor))) + (define control-tarball-file-name + (string-append "control.tar" + #$(compressor-extension compressor))) - ;; Write the compressed control tarball. Only the control file is - ;; mandatory (see: 'man deb' and 'man deb-control'). - (if control-file - (copy-file control-file "control") - (call-with-output-file "control" - (lambda (port) - (format port "\ + ;; Write the compressed control tarball. Only the control file is + ;; mandatory (see: 'man deb' and 'man deb-control'). + (if control-file + (copy-file control-file "control") + (call-with-output-file "control" + (lambda (port) + (format port "\ Package: ~a Version: ~a Description: Debian archive generated by GNU Guix. @@ -797,36 +834,196 @@ Priority: optional Section: misc ~%" package-name package-version architecture)))) - (when postinst-file - (copy-file postinst-file "postinst") - (chmod "postinst" #o755)) + (when postinst-file + (copy-file postinst-file "postinst") + (chmod "postinst" #o755)) - (when triggers-file - (copy-file triggers-file "triggers")) + (when triggers-file + (copy-file triggers-file "triggers")) - (define tar (string-append #+archiver "/bin/tar")) + (define tar (string-append #+archiver "/bin/tar")) - (apply invoke tar - `(,@(tar-base-options - #:tar tar - #:compressor #+(and=> compressor compressor-command)) - "-cvf" ,control-tarball-file-name - "control" - ,@(if postinst-file '("postinst") '()) - ,@(if triggers-file '("triggers") '()))) + (apply invoke tar + `(,@(tar-base-options + #:tar tar + #:compressor #+(and=> compressor compressor-command)) + "-cvf" ,control-tarball-file-name + "control" + ,@(if postinst-file '("postinst") '()) + ,@(if triggers-file '("triggers") '()))) - ;; Create the .deb archive using GNU ar. - (invoke (string-append #+binutils "/bin/ar") "-rv" #$output - "debian-binary" - control-tarball-file-name data-tarball-file-name))))) + ;; Create the .deb archive using GNU ar. + (invoke (string-append #+binutils "/bin/ar") "-rv" #$output + "debian-binary" + control-tarball-file-name data-tarball-file-name)))))) - (gexp->derivation (string-append name ".deb") - build - #:target target - #:references-graphs `(("profile" ,profile)))) + (gexp->derivation (string-append name ".deb") build)) ;;; +;;; RPM archive format. +;;; +(define* (rpm-archive name profile + #:key target + (profile-name "guix-profile") + entry-point + (compressor (first %compressors)) + deduplicate? + localstatedir? + (symlinks '()) + archiver + (extra-options '())) + "Return a RPM archive (.rpm) containing a store initialized with the closure +of PROFILE, a derivation. The archive contains /gnu/store. SYMLINKS must be +a list of (SOURCE -> TARGET) tuples denoting symlinks to be added to the pack. +ARCHIVER and ENTRY-POINT are not used. RELOCATABLE?, PREIN-FILE, POSTIN-FILE, +PREUN-FILE and POSTUN-FILE can be provided via EXTRA-OPTIONS." + (when entry-point + (warning (G_ "entry point not supported in the '~a' format~%") 'rpm)) + + (define root (populate-profile-root profile + #:profile-name profile-name + #:target target + #:localstatedir? localstatedir? + #:deduplicate? deduplicate? + #:symlinks symlinks)) + + (define payload + (let* ((raw-cpio-file-name "payload.cpio") + (compressed-cpio-file-name (string-append raw-cpio-file-name + (compressor-extension + compressor)))) + (computed-file compressed-cpio-file-name + (with-imported-modules (source-module-closure + '((guix build utils) + (guix cpio) + (guix rpm))) + #~(begin + (use-modules (guix build utils) + (guix cpio) + (guix rpm) + (srfi srfi-1)) + + ;; Make sure non-ASCII file names are properly handled. + #+(set-utf8-locale profile) + + (define %root (if #$localstatedir? "." #$root)) + + (when #$localstatedir? + ;; Fix the permission of the Guix database file, which was made + ;; read-only when copied to the store in populate-profile-root. + (copy-recursively #$root %root) + (chmod (string-append %root "/var/guix/db/db.sqlite") #o644)) + + (call-with-output-file #$raw-cpio-file-name + (lambda (port) + (with-directory-excursion %root + ;; The first "." entry is discarded. + (write-cpio-archive + (remove fhs-directory? + (cdr (find-files "." #:directories? #t))) + port)))) + (when #+(compressor-command compressor) + (apply invoke (append #+(compressor-command compressor) + (list #$raw-cpio-file-name)))) + (copy-file #$compressed-cpio-file-name #$output))) + #:local-build? #f))) ;allow offloading + + (define build + (with-extensions (list guile-gcrypt) + (with-imported-modules `(((guix config) => ,(make-config.scm)) + ,@(source-module-closure + `((gcrypt hash) + (guix build utils) + (guix profiles) + (guix rpm)) + #:select? not-config?)) + #~(begin + (use-modules (gcrypt hash) + (guix build utils) + (guix profiles) + (guix rpm) + (ice-9 binary-ports) + (ice-9 match) ;for manifest->friendly-name + (ice-9 optargs) + (rnrs bytevectors) + (srfi srfi-1)) + + ;; Make sure non-ASCII file names are properly handled. + #+(set-utf8-locale profile) + + (define machine-type + (and=> (or #$target %host-type) + (lambda (triplet) + (first (string-split triplet #\-))))) + + #$(procedure-source manifest->friendly-name) + + (define manifest (profile-manifest #$profile)) + + (define single-entry ;manifest entry + (match (manifest-entries manifest) + ((entry) + entry) + (_ #f))) + + (define name + (or (and=> single-entry manifest-entry-name) + (manifest->friendly-name manifest))) + + (define version + (or (and=> single-entry manifest-entry-version) "0.0.0")) + + (define lead + (generate-lead (string-append name "-" version) + #:target (or #$target %host-type))) + + (define payload-digest + (bytevector->hex-string (file-sha256 #$payload))) + + (let-keywords '#$extra-options #f ((relocatable? #f) + (prein-file #f) + (postin-file #f) + (preun-file #f) + (postun-file #f)) + + (let ((header (generate-header name version + payload-digest + #$root + #$(compressor-name compressor) + #:target (or #$target %host-type) + #:relocatable? relocatable? + #:prein-file prein-file + #:postin-file postin-file + #:preun-file preun-file + #:postun-file postun-file))) + + (define header-sha256 + (bytevector->hex-string (sha256 (u8-list->bytevector header)))) + + (define payload-size (stat:size (stat #$payload))) + + (define header+compressed-payload-size + (+ (length header) payload-size)) + + (define signature + (generate-signature header-sha256 + header+compressed-payload-size)) + + ;; Serialize the archive components to a file. + (call-with-input-file #$payload + (lambda (in) + (call-with-output-file #$output + (lambda (out) + (put-bytevector out (assemble-rpm-metadata lead + signature + header)) + (sendfile out in payload-size))))))))))) + + (gexp->derivation (string-append name ".rpm") build)) + + +;;; ;;; Compiling C programs. ;;; @@ -1004,12 +1201,10 @@ last resort for relocation." (utf8->string bv))))) (define (runpath file) - ;; Return the RUNPATH of FILE as a list of directories. - (let* ((bv (call-with-input-file file get-bytevector-all)) - (elf (parse-elf bv)) - (dyninfo (elf-dynamic-info elf))) - (or (and=> dyninfo elf-dynamic-info-runpath) - '()))) + ;; Return the "recursive" RUNPATH of FILE as a list of + ;; directories. + (delete-duplicates + (map dirname (file-needed/recursive file)))) (define (elf-loader-compile-flags program) ;; Return the cpp flags defining macros for the ld.so/fakechroot @@ -1158,7 +1353,8 @@ last resort for relocation." `((tarball . ,self-contained-tarball) (squashfs . ,squashfs-image) (docker . ,docker-image) - (deb . ,debian-archive))) + (deb . ,debian-archive) + (rpm . ,rpm-archive))) (define (show-formats) ;; Print the supported pack formats. @@ -1172,18 +1368,22 @@ last resort for relocation." docker Tarball ready for 'docker load'")) (display (G_ " deb Debian archive installable via dpkg/apt")) + (display (G_ " + rpm RPM archive installable via rpm/yum")) (newline)) +(define (required-option symbol) + "Return an SYMBOL option that requires a value." + (option (list (symbol->string symbol)) #t #f + (lambda (opt name arg result . rest) + (apply values + (alist-cons symbol arg result) + rest)))) + (define %deb-format-options - (let ((required-option (lambda (symbol) - (option (list (symbol->string symbol)) #t #f - (lambda (opt name arg result . rest) - (apply values - (alist-cons symbol arg result) - rest)))))) - (list (required-option 'control-file) - (required-option 'postinst-file) - (required-option 'triggers-file)))) + (list (required-option 'control-file) + (required-option 'postinst-file) + (required-option 'triggers-file))) (define (show-deb-format-options) (display (G_ " @@ -1202,6 +1402,32 @@ last resort for relocation." (newline) (exit 0)) +(define %rpm-format-options + (list (required-option 'prein-file) + (required-option 'postin-file) + (required-option 'preun-file) + (required-option 'postun-file))) + +(define (show-rpm-format-options) + (display (G_ " + --help-rpm-format list options specific to the RPM format"))) + +(define (show-rpm-format-options/detailed) + (display (G_ " + --prein-file=FILE + Embed the provided prein script")) + (display (G_ " + --postin-file=FILE + Embed the provided postin script")) + (display (G_ " + --preun-file=FILE + Embed the provided preun script")) + (display (G_ " + --postun-file=FILE + Embed the provided postun script")) + (newline) + (exit 0)) + (define %options ;; Specifications of the command-line options. (cons* (option '(#\h "help") #f #f @@ -1278,7 +1504,12 @@ last resort for relocation." (lambda args (show-deb-format-options/detailed))) + (option '("help-rpm-format") #f #f + (lambda args + (show-rpm-format-options/detailed))) + (append %deb-format-options + %rpm-format-options %transformation-options %standard-build-options %standard-cross-build-options @@ -1296,6 +1527,7 @@ Create a bundle of PACKAGE.\n")) (show-transformation-options-help) (newline) (show-deb-format-options) + (show-rpm-format-options) (newline) (display (G_ " -f, --format=FORMAT build a pack in the given FORMAT")) @@ -1454,6 +1686,16 @@ Create a bundle of PACKAGE.\n")) (process-file-arg opts 'postinst-file) #:triggers-file (process-file-arg opts 'triggers-file))) + ('rpm + (list #:relocatable? relocatable? + #:prein-file + (process-file-arg opts 'prein-file) + #:postin-file + (process-file-arg opts 'postin-file) + #:preun-file + (process-file-arg opts 'preun-file) + #:postun-file + (process-file-arg opts 'postun-file))) (_ '()))) (target (assoc-ref opts 'target)) (bootstrap? (assoc-ref opts 'bootstrap?)) diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm index b9090307ac..f1eef9dfaf 100644 --- a/guix/scripts/package.scm +++ b/guix/scripts/package.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2012-2022 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2012-2023 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2013 Nikita Karetnikov <nikita@karetnikov.org> ;;; Copyright © 2013, 2015 Mark H Weaver <mhw@netris.org> ;;; Copyright © 2014, 2016 Alex Kost <alezost@gmail.com> @@ -38,9 +38,7 @@ #:use-module (guix profiles) #:use-module (guix search-paths) #:autoload (guix import json) (json->scheme-file) - #:use-module (guix monads) #:use-module (guix utils) - #:use-module (guix config) #:use-module (guix scripts) #:use-module (guix scripts build) #:use-module (guix transformations) @@ -48,12 +46,9 @@ manifest-entry-with-provenance) #:autoload (guix channels) (channel-name channel-commit channel->code) #:autoload (guix store roots) (gc-roots user-owned?) - #:use-module ((guix build utils) - #:select (directory-exists? mkdir-p)) #:use-module (ice-9 format) #:use-module (ice-9 match) #:autoload (ice-9 pretty-print) (pretty-print) - #:use-module (ice-9 regex) #:use-module (ice-9 vlist) #:use-module (srfi srfi-1) #:use-module (srfi srfi-11) @@ -322,7 +317,7 @@ of manifest entries, in the context of PROFILE." (settings (search-path-environment-variables entries (list profile) #:kind 'prefix))) (unless (null? settings) - (display-hint (format #f (G_ "Consider setting the necessary environment + (display-hint (G_ "Consider setting the necessary environment variables by running: @example @@ -331,7 +326,7 @@ GUIX_PROFILE=\"~a\" @end example Alternately, see @command{guix package --search-paths -p ~s}.") - profile profile))))) + profile profile)))) ;;; diff --git a/guix/scripts/publish.scm b/guix/scripts/publish.scm index 6307ae54bb..ada81838ac 100644 --- a/guix/scripts/publish.scm +++ b/guix/scripts/publish.scm @@ -23,16 +23,13 @@ (define-module (guix scripts publish) #:use-module ((system repl server) #:prefix repl:) - #:use-module (ice-9 binary-ports) #:use-module (ice-9 format) #:use-module (ice-9 match) #:use-module (ice-9 poll) - #:use-module (ice-9 regex) #:use-module (ice-9 rdelim) #:use-module (ice-9 threads) #:use-module (rnrs bytevectors) #:use-module (srfi srfi-1) - #:use-module (srfi srfi-2) #:use-module (srfi srfi-9) #:use-module (srfi srfi-9 gnu) #:use-module (srfi srfi-19) @@ -50,7 +47,6 @@ #:use-module (guix base32) #:use-module (guix base64) #:use-module (guix config) - #:use-module (guix derivations) #:use-module (gcrypt hash) #:use-module (guix pki) #:use-module (gcrypt pk-crypto) diff --git a/guix/scripts/pull.scm b/guix/scripts/pull.scm index 7b6c58dbc3..cd2e470289 100644 --- a/guix/scripts/pull.scm +++ b/guix/scripts/pull.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2013-2015, 2017-2022 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2013-2015, 2017-2023 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2017 Marius Bakke <mbakke@fastmail.com> ;;; Copyright © 2020, 2021 Tobias Geerinckx-Rice <me@tobias.gr> ;;; @@ -30,7 +30,6 @@ #:use-module (guix packages) #:use-module (guix derivations) #:use-module (guix profiles) - #:use-module (guix gexp) #:use-module (guix memoization) #:use-module (guix monads) #:use-module (guix channels) @@ -45,7 +44,6 @@ #:autoload (gnu packages) (fold-available-packages) #:autoload (guix scripts package) (build-and-use-profile delete-matching-generations) - #:autoload (gnu packages base) (canonical-package) #:autoload (gnu packages bootstrap) (%bootstrap-guile) #:autoload (gnu packages certs) (le-certs) #:use-module (srfi srfi-1) @@ -469,9 +467,9 @@ true, display what would be built without actually building it." ;; Is the 'guix' command previously in $PATH the same as the new ;; one? If the answer is "no", then suggest 'hash guix'. (unless (member guix-command new) - (display-hint (format #f (G_ "After setting @code{PATH}, run + (display-hint (G_ "After setting @code{PATH}, run @command{hash guix} to make sure your shell refers to @file{~a}.") - (first new)))) + (first new))) (return #f)) (return #f))))) diff --git a/guix/scripts/refresh.scm b/guix/scripts/refresh.scm index 6498d73c2b..bc6c24967a 100644 --- a/guix/scripts/refresh.scm +++ b/guix/scripts/refresh.scm @@ -43,15 +43,12 @@ #:use-module (gnu packages) #:use-module ((gnu packages commencement) #:select (%final-inputs)) #:use-module (ice-9 match) - #:use-module (ice-9 regex) - #:use-module (ice-9 vlist) #:use-module (ice-9 format) #:use-module (srfi srfi-1) #:use-module (srfi srfi-9) #:use-module (srfi srfi-26) #:use-module (srfi srfi-37) #:use-module (srfi srfi-71) - #:use-module (ice-9 binary-ports) #:export (guix-refresh)) @@ -101,7 +98,7 @@ (option '(#\r "recursive") #f #f (lambda (opt name arg result) (alist-cons 'recursive? #t result))) - (option '("list-transitive") #f #f + (option '(#\T "list-transitive") #f #f (lambda (opt name arg result) (alist-cons 'list-transitive? #t result))) @@ -159,7 +156,7 @@ specified with `--select'.\n")) (display (G_ " -r, --recursive check the PACKAGE and its inputs for upgrades")) (display (G_ " - --list-transitive list all the packages that PACKAGE depends on")) + -T, --list-transitive list all the packages that PACKAGE depends on")) (newline) (display (G_ " --keyring=FILE use FILE as the keyring of upstream OpenPGP keys")) diff --git a/guix/scripts/repl.scm b/guix/scripts/repl.scm index 787c63d48e..fd23a2b982 100644 --- a/guix/scripts/repl.scm +++ b/guix/scripts/repl.scm @@ -23,10 +23,8 @@ #:use-module (guix scripts) #:use-module (guix repl) #:use-module (srfi srfi-1) - #:use-module (srfi srfi-26) #:use-module (srfi srfi-37) #:use-module (ice-9 match) - #:use-module (rnrs bytevectors) #:autoload (guix describe) (current-profile) #:autoload (system repl repl) (start-repl) #:autoload (system repl server) @@ -211,6 +209,7 @@ call THUNK." ((guile) (save-module-excursion (lambda () + (current-profile) ;populate (%package-module-path); see above (set-user-module) ;; Do not exit repl on SIGINT. ((@@ (ice-9 top-repl) call-with-sigint) diff --git a/guix/scripts/search.scm b/guix/scripts/search.scm index 27b9da5278..307ea410b9 100644 --- a/guix/scripts/search.scm +++ b/guix/scripts/search.scm @@ -24,7 +24,6 @@ #:select (%standard-build-options)) #:use-module (guix scripts) #:use-module (srfi srfi-1) - #:use-module (srfi srfi-26) #:use-module (srfi srfi-37) #:export (guix-search)) diff --git a/guix/scripts/shell.scm b/guix/scripts/shell.scm index 64b5c2e8e9..92bbfb04d0 100644 --- a/guix/scripts/shell.scm +++ b/guix/scripts/shell.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2021-2022 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2021-2023 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -305,16 +305,16 @@ Return the modified OPTS." (report-error (G_ "not loading '~a' because not authorized to do so~%") file) - (display-hint (format #f (G_ "To allow automatic loading of + (display-hint (G_ "To allow automatic loading of @file{~a} when running @command{guix shell}, you must explicitly authorize its directory, like so: @example echo ~a >> ~a @end example\n") - file - (dirname file) - (authorized-directory-file))) + file + (dirname file) + (authorized-directory-file)) (exit 1))))))) diff --git a/guix/scripts/show.scm b/guix/scripts/show.scm index c747eedd21..f6d8256951 100644 --- a/guix/scripts/show.scm +++ b/guix/scripts/show.scm @@ -23,7 +23,6 @@ #:select (%standard-build-options)) #:use-module (guix scripts) #:use-module (srfi srfi-1) - #:use-module (srfi srfi-26) #:use-module (srfi srfi-37) #:export (guix-show)) diff --git a/guix/scripts/style.scm b/guix/scripts/style.scm index fa7175fb16..8e89a58948 100644 --- a/guix/scripts/style.scm +++ b/guix/scripts/style.scm @@ -31,7 +31,6 @@ #:autoload (gnu packages) (specification->package fold-packages) #:use-module (guix scripts) #:use-module ((guix scripts build) #:select (%standard-build-options)) - #:use-module (guix combinators) #:use-module (guix ui) #:use-module (guix packages) #:use-module (guix utils) @@ -42,7 +41,6 @@ #:use-module (ice-9 match) #:use-module (srfi srfi-1) #:use-module (srfi srfi-9) - #:use-module (srfi srfi-26) #:use-module (srfi srfi-34) #:use-module (srfi srfi-37) #:export (guix-style)) diff --git a/guix/scripts/substitute.scm b/guix/scripts/substitute.scm index fedb33019d..109b0c7900 100755 --- a/guix/scripts/substitute.scm +++ b/guix/scripts/substitute.scm @@ -26,7 +26,6 @@ #:use-module (guix store) #:use-module (guix substitutes) #:use-module (guix utils) - #:use-module (guix combinators) #:use-module (guix config) #:use-module (guix records) #:use-module (guix diagnostics) @@ -36,7 +35,6 @@ #:autoload (guix scripts discover) (read-substitute-urls) #:use-module (gcrypt hash) #:use-module (guix base32) - #:use-module (guix base64) #:use-module (guix cache) #:use-module (gcrypt pk-crypto) #:use-module (guix pki) @@ -55,10 +53,8 @@ #:use-module (ice-9 ftw) #:use-module (rnrs bytevectors) #:use-module (srfi srfi-1) - #:use-module (srfi srfi-19) #:use-module (srfi srfi-26) #:use-module (srfi srfi-34) - #:use-module (srfi srfi-35) #:use-module (srfi srfi-71) #:use-module (web uri) #:use-module (guix http-client) diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm index 6fd915cb5e..d7163dd3eb 100644 --- a/guix/scripts/system.scm +++ b/guix/scripts/system.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2014-2022 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2014-2023 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2016 Alex Kost <alezost@gmail.com> ;;; Copyright © 2016, 2017, 2018 Chris Marusich <cmmarusich@gmail.com> ;;; Copyright © 2017, 2019 Mathieu Othacehe <m.othacehe@gmail.com> @@ -55,20 +55,14 @@ #:autoload (guix scripts pull) (channel-commit-hyperlink) #:autoload (guix graph) (export-graph node-type graph-backend-name lookup-backend) - #:use-module (guix scripts graph) #:use-module (guix scripts system reconfigure) #:use-module (guix build utils) #:use-module (guix progress) - #:use-module ((guix build syscalls) #:select (terminal-columns)) #:use-module (gnu build image) #:use-module (gnu build install) #:autoload (gnu build file-systems) (find-partition-by-label find-partition-by-uuid) - #:autoload (gnu build linux-modules) - (device-module-aliases matching-modules) - #:use-module (gnu system linux-initrd) #:use-module (gnu image) - #:use-module (guix platform) #:use-module (gnu system) #:use-module (gnu bootloader) #:use-module (gnu system file-systems) @@ -81,7 +75,6 @@ #:use-module (gnu services shepherd) #:use-module (gnu services herd) #:use-module (srfi srfi-1) - #:use-module (srfi srfi-11) #:use-module (srfi srfi-19) #:use-module (srfi srfi-26) #:use-module (srfi srfi-34) @@ -633,9 +626,9 @@ any, are available. Raise an error if they're not." (G_ "device '~a' not found: ~a~%") device (strerror errno)) (unless (string-prefix? "/" device) - (display-hint (format #f (G_ "If '~a' is a file system + (display-hint (G_ "If '~a' is a file system label, write @code{(file-system-label ~s)} in your @code{device} field.") - device device))))))) + device device)))))) literal) (for-each (lambda (fs) (let ((label (file-system-label->string @@ -1417,8 +1410,7 @@ argument list and OPTS is the option alist." (let ((hint (string-closest arg actions #:threshold 3))) (report-error (G_ "~a: unknown action~%") arg) (when hint - (display-hint - (format #f (G_ "Did you mean @code{~a}?~%") hint))) + (display-hint (G_ "Did you mean @code{~a}?~%") hint)) (exit 1))))) (define (match-pair car) diff --git a/guix/scripts/system/edit.scm b/guix/scripts/system/edit.scm index d966ee0aaa..0afb071650 100644 --- a/guix/scripts/system/edit.scm +++ b/guix/scripts/system/edit.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2022 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2022, 2023 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -39,8 +39,8 @@ '())) (closest (string-closest type available))) (unless (or (not closest) (string=? closest type)) - (display-hint (format #f (G_ "Did you mean @code{~a}?~%") - closest)))) + (display-hint (G_ "Did you mean @code{~a}?~%") + closest))) (exit 1)) diff --git a/guix/scripts/time-machine.scm b/guix/scripts/time-machine.scm index 5179ea035f..d7c71ef705 100644 --- a/guix/scripts/time-machine.scm +++ b/guix/scripts/time-machine.scm @@ -22,7 +22,6 @@ #:use-module (guix ui) #:use-module (guix scripts) #:use-module (guix inferior) - #:use-module (guix channels) #:use-module (guix store) #:use-module (guix status) #:use-module ((guix git) diff --git a/guix/search-paths.scm b/guix/search-paths.scm index 4a8f5131ed..fcbe7b7953 100644 --- a/guix/search-paths.scm +++ b/guix/search-paths.scm @@ -34,6 +34,7 @@ $PATH $GUIX_EXTENSIONS_PATH + $PKG_CONFIG_PATH $SSL_CERT_DIR $SSL_CERT_FILE @@ -83,6 +84,13 @@ (variable "GUIX_EXTENSIONS_PATH") (files '("share/guix/extensions")))) +(define $PKG_CONFIG_PATH + ;; 'PKG_CONFIG_PATH' is used by pkg-config to locate available header files + ;; and libraries, via their .pc files. + (search-path-specification + (variable "PKG_CONFIG_PATH") + (files '("lib/pkgconfig" "lib64/pkgconfig" "share/pkgconfig")))) + ;; Two variables for certificates (info "(guix)X.509 Certificates"), ;; respected by OpenSSL and possibly GnuTLS in the future ;; (https://gitlab.com/gnutls/gnutls/-/merge_requests/1541) diff --git a/guix/self.scm b/guix/self.scm index 93019e1c64..d1dcde34ac 100644 --- a/guix/self.scm +++ b/guix/self.scm @@ -19,7 +19,6 @@ (define-module (guix self) #:use-module (guix config) - #:use-module (guix i18n) #:use-module (guix modules) #:use-module (guix gexp) #:use-module (guix store) diff --git a/guix/serialization.scm b/guix/serialization.scm index 9b888a7d25..9656e5ac2a 100644 --- a/guix/serialization.scm +++ b/guix/serialization.scm @@ -17,7 +17,6 @@ ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. (define-module (guix serialization) - #:use-module (guix combinators) #:use-module (rnrs bytevectors) #:use-module (srfi srfi-1) #:use-module (srfi srfi-26) diff --git a/guix/ssh.scm b/guix/ssh.scm index 1b825a2573..5b35f664d9 100644 --- a/guix/ssh.scm +++ b/guix/ssh.scm @@ -477,7 +477,7 @@ Use SIZES to determine the size of ITEM, which is about to be sent." (define (display-bar %) (erase-current-line port) (format port "~3@a% ~a" - (inexact->exact (round (* 100. (/ sent total)))) + (inexact->exact (round %)) (progress-bar % (- (max (current-terminal-columns) 5) 5))) (force-output port)) diff --git a/guix/status.scm b/guix/status.scm index 2c69f49fb5..d4d3fca026 100644 --- a/guix/status.scm +++ b/guix/status.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2017-2022 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2017-2023 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2018, 2019 Ricardo Wurmus <rekado@elephly.net> ;;; ;;; This file is part of GNU Guix. @@ -22,11 +22,11 @@ #:use-module (guix i18n) #:use-module (guix colors) #:use-module (guix progress) + #:autoload (guix ui) (display-hint) #:autoload (guix build syscalls) (terminal-columns) #:autoload (guix build download) (nar-uri-abbreviation) #:use-module (guix store) #:use-module (guix derivations) - #:use-module (guix memoization) #:use-module (srfi srfi-1) #:use-module (srfi srfi-9) #:use-module (srfi srfi-9 gnu) @@ -526,6 +526,21 @@ substitutes being downloaded." (erase-current-line*) ;erase spinner or progress bar (format port (failure (G_ "build of ~a failed")) drv) (newline port) + (let ((properties (and=> (false-if-exception + (read-derivation-from-file drv)) + derivation-properties))) + (when (and (pair? properties) + (eq? (assq-ref properties 'type) 'profile-hook) + (eq? (assq-ref properties 'hook) 'package-cache)) + (display-hint (G_ "This usually indicates a bug in one of +the channels you are pulling from, or some incompatibility among them. You +can check the build log and report the issue to the channel developers. + +The channels you are pulling from are: ~a.") + (string-join + (map symbol->string + (or (assq-ref properties 'channels) + '(guix))))))) (match (derivation-log-file drv) (#f (format port (failure (G_ "Could not find build log for '~a'.")) diff --git a/guix/store.scm b/guix/store.scm index a36dce416e..f8e77b2cd9 100644 --- a/guix/store.scm +++ b/guix/store.scm @@ -24,7 +24,6 @@ #:use-module (guix utils) #:use-module (guix config) #:use-module (guix deprecation) - #:use-module (guix memoization) #:use-module (guix serialization) #:use-module (guix monads) #:use-module (guix records) @@ -45,7 +44,6 @@ #:use-module (srfi srfi-26) #:use-module (srfi srfi-34) #:use-module (srfi srfi-35) - #:use-module (srfi srfi-39) #:use-module (ice-9 match) #:use-module (ice-9 vlist) #:use-module (ice-9 popen) diff --git a/guix/store/database.scm b/guix/store/database.scm index e664015673..2968f13492 100644 --- a/guix/store/database.scm +++ b/guix/store/database.scm @@ -22,7 +22,6 @@ (define-module (guix store database) #:use-module (sqlite3) #:use-module (guix config) - #:use-module (guix serialization) #:use-module (guix store deduplication) #:use-module (guix base16) #:use-module (guix progress) @@ -36,7 +35,6 @@ #:use-module (srfi srfi-26) #:use-module (rnrs io ports) #:use-module (ice-9 match) - #:use-module (system foreign) #:export (sql-schema %default-database-file store-database-file diff --git a/guix/store/deduplication.scm b/guix/store/deduplication.scm index acb6ffcc4a..129574c073 100644 --- a/guix/store/deduplication.scm +++ b/guix/store/deduplication.scm @@ -28,9 +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 ftw) #:use-module (ice-9 match) #:use-module (guix serialization) #:export (nar-sha256 diff --git a/guix/substitutes.scm b/guix/substitutes.scm index edff84aac3..84c7be83ca 100644 --- a/guix/substitutes.scm +++ b/guix/substitutes.scm @@ -25,26 +25,19 @@ #:use-module (guix utils) #:use-module (guix combinators) #:use-module (guix config) - #:use-module (guix records) #:use-module (guix diagnostics) #:use-module (guix i18n) #:use-module (gcrypt hash) #:use-module (guix base32) - #:use-module (guix base64) #:use-module (guix cache) - #:use-module (gcrypt pk-crypto) - #:use-module (guix pki) #:use-module ((guix build utils) #:select (mkdir-p dump-port)) #:use-module ((guix build download) #:select ((open-connection-for-uri . guix:open-connection-for-uri) resolve-uri-reference)) #:use-module (guix progress) - #:use-module (ice-9 rdelim) - #:use-module (ice-9 regex) #:use-module (ice-9 match) #:use-module (ice-9 format) - #:use-module (ice-9 ftw) #:use-module (ice-9 binary-ports) #:use-module (ice-9 vlist) #:use-module (rnrs bytevectors) @@ -52,8 +45,6 @@ #:use-module (srfi srfi-11) #:use-module (srfi srfi-19) #:use-module (srfi srfi-26) - #:use-module (srfi srfi-34) - #:use-module (srfi srfi-35) #:use-module (web uri) #:use-module (web request) #:use-module (web response) diff --git a/guix/tests/gnupg.scm b/guix/tests/gnupg.scm index 09f02a2b67..0e4573ae4d 100644 --- a/guix/tests/gnupg.scm +++ b/guix/tests/gnupg.scm @@ -21,7 +21,6 @@ #:use-module (guix utils) #:use-module (guix build utils) #:use-module (rnrs io ports) - #:use-module (ice-9 match) #:export (gpg-command gpgconf-command with-fresh-gnupg-setup diff --git a/guix/tests/http.scm b/guix/tests/http.scm index 8f50eaefca..37e5744353 100644 --- a/guix/tests/http.scm +++ b/guix/tests/http.scm @@ -23,7 +23,6 @@ #:use-module (web server http) #:use-module (web response) #:use-module (srfi srfi-11) - #:use-module (srfi srfi-39) #:use-module (ice-9 match) #:export (with-http-server call-with-http-server diff --git a/guix/ui.scm b/guix/ui.scm index 9f81ff3b8e..7540e2194f 100644 --- a/guix/ui.scm +++ b/guix/ui.scm @@ -296,9 +296,22 @@ VARIABLE and return it, or #f if none was found." (define %hint-color (color BOLD CYAN)) -(define* (display-hint message #:optional (port (current-error-port))) - "Display MESSAGE, a l10n message possibly containing Texinfo markup, to -PORT." +(define (texinfo-quote str) + "Quote at signs and braces in STR to obtain its Texinfo represention." + (list->string + (string-fold-right (lambda (chr result) + (if (memq chr '(#\@ #\{ #\})) + (cons* #\@ chr result) + (cons chr result))) + '() + str))) + +(define* (display-hint message + #:key (port (current-error-port)) + #:rest arguments) + "Display MESSAGE, a l10n message possibly containing Texinfo markup and +'format' escape, to PORT. ARGUMENTS is a (possibly empty) list of strings or +other objects that must match the 'format' escapes in MESSAGE." (define colorize (if (color-output? port) (lambda (str) @@ -309,7 +322,16 @@ PORT." (display ;; XXX: We should arrange so that the initial indent is wider. (parameterize ((%text-width (max 15 (- (terminal-columns) 5)))) - (texi->plain-text message)) + (texi->plain-text (match arguments + (() (format #f message)) + (_ (apply format #f message + (map (match-lambda + ((? string? str) + (texinfo-quote str)) + (obj + (texinfo-quote + (object->string obj)))) + arguments)))))) port)) (define* (report-unbound-variable-error args #:key frame) @@ -324,8 +346,8 @@ arguments." (#f (display-hint (G_ "Did you forget a @code{use-modules} form?"))) ((? module? module) - (display-hint (format #f (G_ "Did you forget @code{(use-modules ~a)}?") - (module-name module)))))))) + (display-hint (G_ "Did you forget @code{(use-modules ~a)}?") + (module-name module))))))) (define (check-module-matches-file module file) "Check whether FILE starts with 'define-module MODULE' and print a hint if @@ -334,10 +356,10 @@ it doesn't." ;; definitions and try loading them with 'guix build -L …', so help them ;; diagnose the problem. (define (hint) - (display-hint (format #f (G_ "File @file{~a} should probably start with: + (display-hint (G_ "File @file{~a} should probably start with: @example\n(define-module ~a)\n@end example") - file module))) + file module)) (catch 'system-error (lambda () @@ -663,12 +685,12 @@ interpreted." (name1 (manifest-entry-name (top-most-entry first))) (name2 (manifest-entry-name (top-most-entry second)))) (if (string=? name1 name2) - (display-hint (format #f (G_ "You cannot have two different versions + (display-hint (G_ "You cannot have two different versions or variants of @code{~a} in the same profile.") - name1)) - (display-hint (format #f (G_ "Try upgrading both @code{~a} and @code{~a}, + name1) + (display-hint (G_ "Try upgrading both @code{~a} and @code{~a}, or remove one of them from the profile.") - name1 name2))))) + name1 name2)))) ;; On Guile 3.0, in 'call-with-error-handling' we need to re-raise. To ;; preserve useful backtraces in case of unhandled errors, we want that to @@ -2226,8 +2248,7 @@ found." (format (current-error-port) (G_ "guix: ~a: command not found~%") command) (when hint - (display-hint (format #f (G_ "Did you mean @code{~a}?") - hint))) + (display-hint (G_ "Did you mean @code{~a}?") hint)) (show-guix-usage))))) (file (load file) diff --git a/guix/upstream.scm b/guix/upstream.scm index 4c72388bf3..52fae11832 100644 --- a/guix/upstream.scm +++ b/guix/upstream.scm @@ -48,7 +48,6 @@ #: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 diff --git a/guix/utils.scm b/guix/utils.scm index aca0af4e4b..943d540bfc 100644 --- a/guix/utils.scm +++ b/guix/utils.scm @@ -16,6 +16,7 @@ ;;; Copyright © 2022 Taiju HIGASHI <higashi@taiju.info> ;;; Copyright © 2022 Denis 'GNUtoo' Carikli <GNUtoo@cyberdimension.org> ;;; Copyright © 2022 Antero Mejr <antero@mailbox.org> +;;; Copyright © 2023 Philip McGrath <philip@philipmcgrath.com> ;;; ;;; This file is part of GNU Guix. ;;; @@ -35,10 +36,8 @@ (define-module (guix utils) #:use-module (guix config) #:use-module (srfi srfi-1) - #:use-module (srfi srfi-9) #:use-module (srfi srfi-11) #:use-module (srfi srfi-26) - #:use-module (srfi srfi-39) #:use-module (srfi srfi-71) #:use-module (rnrs io ports) ;need 'port-position' etc. #:use-module ((rnrs bytevectors) #:select (bytevector-u8-set!)) @@ -50,7 +49,6 @@ #:use-module ((guix combinators) #:select (fold2)) #:use-module (guix diagnostics) ;<location>, &error-location, etc. #:use-module (ice-9 format) - #:use-module (ice-9 ftw) #:use-module ((ice-9 iconv) #:prefix iconv:) #:use-module (ice-9 match) #:use-module (ice-9 regex) @@ -104,6 +102,7 @@ target-riscv64? target-mips64el? target-64bit? + target-little-endian? ar-for-target as-for-target cc-for-target @@ -744,6 +743,12 @@ architecture (x86_64)?" (any (cut string-prefix? <> system) '("x86_64" "aarch64" "mips64" "powerpc64" "riscv64"))) +(define* (target-little-endian? #:optional (target (or (%current-target-system) + (%current-system)))) + "Is the architecture of TARGET little-endian?" + ;; At least in Guix. Aarch64 and 32-bit arm have a big-endian mode as well. + (not (target-ppc32? target))) + (define* (ar-for-target #:optional (target (%current-target-system))) (if target (string-append target "-ar") |