From 52eb3db19cb9e5c294c86a8552a4baaa5b473672 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sun, 29 Jan 2023 22:13:53 +0100 Subject: container: Correctly report exit status. * gnu/build/linux-container.scm (container-excursion): Return the raw status value. * tests/containers.scm ("container-excursion, same namespaces"): Add 'status:exit-val' call. * guix/scripts/container/exec.scm (guix-container-exec): Correctly handle the different cases. --- guix/scripts/container/exec.scm | 10 +++++++++- 1 file changed, 9 insertions(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/scripts/container/exec.scm b/guix/scripts/container/exec.scm index 51b616b384..3e70b1d3c2 100644 --- a/guix/scripts/container/exec.scm +++ b/guix/scripts/container/exec.scm @@ -102,4 +102,12 @@ (define (handle-argument arg result) environment) (apply execlp program program program-args))))))) (unless (zero? result) - (leave (G_ "exec failed with status ~d~%") result))))))) + (match (status:exit-val result) + (#f + (if (status:term-sig result) + (leave (G_ "process terminated with signal ~a~%") + (status:term-sig result)) + (leave (G_ "process stopped with signal ~a~%") + (status:stop-sig result)))) + (code + (leave (G_ "process exited with status ~d~%") code))))))))) -- cgit v1.2.3 From 25947bbc3217306742694304fa9b6499f0126c7a Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 30 Jan 2023 16:57:18 +0100 Subject: build-system: Always pass #:graft? #f to 'gexp->derivation'. Fixes . Fixes a bug whereby packages referred via 'ungexp' in package arguments would be "double-grafted": 'gexp->derivation' would first replace those references by references to the grafted package, only to repeat the grafting process on the result. Build systems such as 'gnu', 'cmake', and 'pyproject' were already doing this. Only the rest of them is affected. * guix/build-system/cargo.scm (cargo-build): Pass #:graft? #f to 'gexp->derivation'. * guix/build-system/copy.scm (copy-build): Likewise. * guix/build-system/dune.scm (dune-build): Likewise. * guix/build-system/font.scm (font-build): Likewise. * guix/build-system/guile.scm (guile-build): Likewise. (guile-cross-build): Likewise. * guix/build-system/ocaml.scm (ocaml-build): Likewise. * guix/build-system/ruby.scm (ruby-build): Likewise. * guix/build-system/scons.scm (scons-build): Likewise. * guix/build-system/texlive.scm (texlive-build): Likewise. * guix/build-system/waf.scm (waf-build): Likewise. --- guix/build-system/cargo.scm | 1 + guix/build-system/copy.scm | 1 + guix/build-system/dune.scm | 1 + guix/build-system/font.scm | 1 + guix/build-system/guile.scm | 2 ++ guix/build-system/ocaml.scm | 1 + guix/build-system/ruby.scm | 1 + guix/build-system/scons.scm | 1 + guix/build-system/texlive.scm | 1 + guix/build-system/waf.scm | 1 + 10 files changed, 11 insertions(+) (limited to 'guix') diff --git a/guix/build-system/cargo.scm b/guix/build-system/cargo.scm index 60c35eed07..912400a191 100644 --- a/guix/build-system/cargo.scm +++ b/guix/build-system/cargo.scm @@ -123,6 +123,7 @@ (define builder (gexp->derivation name builder #:system system #:target #f + #:graft? #f #:guile-for-build guile)) (define (package-cargo-inputs p) diff --git a/guix/build-system/copy.scm b/guix/build-system/copy.scm index c98b266561..6efc2b2766 100644 --- a/guix/build-system/copy.scm +++ b/guix/build-system/copy.scm @@ -132,6 +132,7 @@ (define builder #:system system #:target #f #:substitutable? substitutable? + #:graft? #f #:guile-for-build guile))) (define copy-build-system diff --git a/guix/build-system/dune.scm b/guix/build-system/dune.scm index 12100fd8e8..3f81d21441 100644 --- a/guix/build-system/dune.scm +++ b/guix/build-system/dune.scm @@ -157,6 +157,7 @@ (define builder (gexp->derivation name builder #:system system #:target #f + #:graft? #f #:guile-for-build guile)) (define dune-build-system diff --git a/guix/build-system/font.scm b/guix/build-system/font.scm index 74dc80b5db..a99f76c66b 100644 --- a/guix/build-system/font.scm +++ b/guix/build-system/font.scm @@ -112,6 +112,7 @@ (define builder (gexp->derivation name builder #:system system #:target #f + #:graft? #f #:guile-for-build guile))) (define font-build-system diff --git a/guix/build-system/guile.scm b/guix/build-system/guile.scm index 36a88e181a..ffc892260a 100644 --- a/guix/build-system/guile.scm +++ b/guix/build-system/guile.scm @@ -114,6 +114,7 @@ (define builder (gexp->derivation name builder #:system system #:target #f + #:graft? #f #:guile-for-build guile))) (define* (guile-cross-build name @@ -170,6 +171,7 @@ (define %outputs (gexp->derivation name builder #:system system #:target target + #:graft? #f #:guile-for-build guile))) (define guile-build-system diff --git a/guix/build-system/ocaml.scm b/guix/build-system/ocaml.scm index b08985cd4d..921c1f8629 100644 --- a/guix/build-system/ocaml.scm +++ b/guix/build-system/ocaml.scm @@ -310,6 +310,7 @@ (define builder (gexp->derivation name builder #:system system #:target #f + #:graft? #f #:guile-for-build guile)) (define ocaml-build-system diff --git a/guix/build-system/ruby.scm b/guix/build-system/ruby.scm index 342daf7978..0aa273b4f4 100644 --- a/guix/build-system/ruby.scm +++ b/guix/build-system/ruby.scm @@ -114,6 +114,7 @@ (define build (gexp->derivation name build #:system system #:target #f + #:graft? #f #:modules imported-modules #:guile-for-build guile))) diff --git a/guix/build-system/scons.scm b/guix/build-system/scons.scm index 7a02fa8a0f..9af24d40f8 100644 --- a/guix/build-system/scons.scm +++ b/guix/build-system/scons.scm @@ -121,6 +121,7 @@ (define builder (gexp->derivation name builder #:system system #:target #f + #:graft? #f #:guile-for-build guile)) (define scons-build-system diff --git a/guix/build-system/texlive.scm b/guix/build-system/texlive.scm index dbb72cd24a..336e192d83 100644 --- a/guix/build-system/texlive.scm +++ b/guix/build-system/texlive.scm @@ -182,6 +182,7 @@ (define builder (gexp->derivation name builder #:system system #:target #f + #:graft? #f #:substitutable? substitutable? #:guile-for-build guile))) diff --git a/guix/build-system/waf.scm b/guix/build-system/waf.scm index e8cd5520b8..1d520050f6 100644 --- a/guix/build-system/waf.scm +++ b/guix/build-system/waf.scm @@ -111,6 +111,7 @@ (define build (gexp->derivation name build #:system system #:target #f + #:graft? #f #:modules imported-modules #:guile-for-build guile))) -- cgit v1.2.3 From a89aa4523befd8c30d9f13800b4833abbc911ba1 Mon Sep 17 00:00:00 2001 From: Philip McGrath Date: Fri, 3 Feb 2023 20:14:12 -0500 Subject: utils: Add target-little-endian?. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit * guix/utils.scm (target-little-endian?): New function. * guix/build-system/meson.scm (make-machine-alist): Use it. * gnu/packages/chez.scm (nix-system->pbarch-machine-type): Likewise. Signed-off-by: Ludovic Courtès --- gnu/packages/chez.scm | 9 ++++----- guix/build-system/meson.scm | 13 +++---------- guix/utils.scm | 8 ++++++++ 3 files changed, 15 insertions(+), 15 deletions(-) (limited to 'guix') diff --git a/gnu/packages/chez.scm b/gnu/packages/chez.scm index 0d22e2e20f..1f178d2c72 100644 --- a/gnu/packages/chez.scm +++ b/gnu/packages/chez.scm @@ -4,7 +4,7 @@ ;;; Copyright © 2017, 2019 Tobias Geerinckx-Rice ;;; Copyright © 2019 Brett Gilio ;;; Copyright © 2020 Brendan Tildesley -;;; Copyright © 2021, 2022 Philip McGrath +;;; Copyright © 2021, 2022, 2023 Philip McGrath ;;; ;;; This file is part of GNU Guix. ;;; @@ -251,10 +251,9 @@ (define* (nix-system->pbarch-machine-type #:optional (if (target-64bit? system) "64" "32") - ;; missing (guix utils) predicate target-little-endian? - (if (target-ppc32? system) - "b" - "l"))) + (if (target-little-endian? system) + "l" + "b"))) (define* (racket-cs-native-supported-system? #:optional (system diff --git a/guix/build-system/meson.scm b/guix/build-system/meson.scm index b0bf8cb6e6..7d413a991d 100644 --- a/guix/build-system/meson.scm +++ b/guix/build-system/meson.scm @@ -74,16 +74,9 @@ (define (make-machine-alist 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/utils.scm b/guix/utils.scm index aca0af4e4b..774b80cd25 100644 --- a/guix/utils.scm +++ b/guix/utils.scm @@ -16,6 +16,7 @@ ;;; Copyright © 2022 Taiju HIGASHI ;;; Copyright © 2022 Denis 'GNUtoo' Carikli ;;; Copyright © 2022 Antero Mejr +;;; Copyright © 2023 Philip McGrath ;;; ;;; This file is part of GNU Guix. ;;; @@ -104,6 +105,7 @@ (define-module (guix utils) target-riscv64? target-mips64el? target-64bit? + target-little-endian? ar-for-target as-for-target cc-for-target @@ -744,6 +746,12 @@ (define* (target-64bit? #:optional (system (or (%current-target-system) (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") -- cgit v1.2.3 From 3ab8559436356ef89aa60135d3558681d64443ae Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 6 Feb 2023 15:02:34 +0100 Subject: status: Print a hint when a 'package-cache' hook fails to build. * guix/channels.scm (package-cache-file): Add 'channels' to the #:properties list. * guix/status.scm (print-build-event): Upon failure, display a hint when the derivation is a 'package-cache' hook. --- guix/channels.scm | 9 +++++++-- guix/status.scm | 18 +++++++++++++++++- 2 files changed, 24 insertions(+), 3 deletions(-) (limited to 'guix') diff --git a/guix/channels.scm b/guix/channels.scm index 40cbc4bb3a..d44e7a0a3a 100644 --- a/guix/channels.scm +++ b/guix/channels.scm @@ -952,6 +952,10 @@ (define build (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 +964,9 @@ (define build ;; 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/status.scm b/guix/status.scm index 2c69f49fb5..5580c80ea9 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 +;;; Copyright © 2017-2023 Ludovic Courtès ;;; Copyright © 2018, 2019 Ricardo Wurmus ;;; ;;; This file is part of GNU Guix. @@ -22,6 +22,7 @@ (define-module (guix status) #: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) @@ -526,6 +527,21 @@ (define erase-current-line* (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 (format #f (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'.")) -- cgit v1.2.3 From 7d0ebe040d80adcf143656e754a82b569243568c Mon Sep 17 00:00:00 2001 From: Christopher Baines Date: Mon, 6 Feb 2023 16:55:05 +0100 Subject: download: Add bordeaux.guix.gnu.org as a content addressed mirror. bordeaux.guix.gnu.org now provides access to some files by hash. This is done through the nar-herder finding a nar produced by a fixed output derivation for the requested content, and then providing the content stored inside that nar. I've put this new entry at the start of the list, as I think it's more likely to have content than the others. Because bordeaux.guix.gnu.org stores nars indefinitely, my suspicion is that it's going to be able to fulfil more requests than ci.guix.gnu.org, which relies on the file requested being in the store (so the now frequent garbage collection is going to limit the files available). * guix/download.scm (%content-addressed-mirrors): Add bordeaux.guix.gnu.org. Signed-off-by: Christopher Baines --- guix/download.scm | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) (limited to 'guix') 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 @@ (define (guix-publish host) 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/" -- cgit v1.2.3 From a68229b9a0f450db622511adfe00ff7307d745d3 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sun, 12 Feb 2023 01:15:51 +0100 Subject: syscalls: 'with-file-lock' removes lock file upon exit. Fixes . Reported by Ricardo Wurmus . * guix/build/syscalls.scm (call-with-file-lock) (call-with-file-lock/no-wait): Add call to 'delete-file' in unwind handler. --- guix/build/syscalls.scm | 8 +++++--- 1 file changed, 5 insertions(+), 3 deletions(-) (limited to 'guix') 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 +;;; Copyright © 2014-2023 Ludovic Courtès ;;; Copyright © 2015 David Thompson ;;; Copyright © 2015 Mark H Weaver ;;; Copyright © 2017 Mathieu Othacehe @@ -1400,7 +1400,8 @@ (define (call-with-file-lock file thunk) 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 @@ (define (call-with-file-lock/no-wait file thunk handler) 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." -- cgit v1.2.3 From dbd4d2d0707b486f1e2c8659e94e1d3b15e4351e Mon Sep 17 00:00:00 2001 From: Pierre Langlois Date: Fri, 25 Nov 2022 01:57:21 +0000 Subject: build-system: Add tree-sitter-build-system. * guix/build-system/tree-sitter.scm: New module. * guix/build/tree-sitter-build-system.scm: Likewise. * Makefile.am (MODULES): Add them. * doc/guix.texi: Document it. Signed-off-by: Andrew Tropin --- Makefile.am | 2 + doc/guix.texi | 21 +++- guix/build-system/tree-sitter.scm | 195 ++++++++++++++++++++++++++++++++ guix/build/tree-sitter-build-system.scm | 153 +++++++++++++++++++++++++ 4 files changed, 370 insertions(+), 1 deletion(-) create mode 100644 guix/build-system/tree-sitter.scm create mode 100644 guix/build/tree-sitter-build-system.scm (limited to 'guix') diff --git a/Makefile.am b/Makefile.am index a4b6f03b3a..5ce6cc84f4 100644 --- a/Makefile.am +++ b/Makefile.am @@ -178,6 +178,7 @@ MODULES = \ guix/build-system/ruby.scm \ guix/build-system/scons.scm \ guix/build-system/texlive.scm \ + guix/build-system/tree-sitter.scm \ guix/build-system/trivial.scm \ guix/ftp-client.scm \ guix/http-client.scm \ @@ -234,6 +235,7 @@ MODULES = \ guix/build/ruby-build-system.scm \ guix/build/scons-build-system.scm \ guix/build/texlive-build-system.scm \ + guix/build/tree-sitter-build-system.scm \ guix/build/waf-build-system.scm \ guix/build/haskell-build-system.scm \ guix/build/julia-build-system.scm \ diff --git a/doc/guix.texi b/doc/guix.texi index 6c7c918eb0..44e2165a82 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -79,7 +79,7 @@ Copyright @copyright{} 2020 Jack Hill@* Copyright @copyright{} 2020 Naga Malleswari@* Copyright @copyright{} 2020, 2021 Brice Waegeneire@* Copyright @copyright{} 2020 R Veera Kumar@* -Copyright @copyright{} 2020, 2021 Pierre Langlois@* +Copyright @copyright{} 2020, 2021, 2022 Pierre Langlois@* Copyright @copyright{} 2020 pinoaffe@* Copyright @copyright{} 2020 André Batista@* Copyright @copyright{} 2020, 2021 Alexandru-Sergiu Marton@* @@ -9756,6 +9756,25 @@ be specified with the @code{#:node} parameter which defaults to @code{node}. @end defvar +@defvr {Scheme Variable} tree-sitter-build-system + +This variable is exported by @code{(guix build-system tree-sitter)}. It +implements procedures to compile grammars for the +@url{https://tree-sitter.github.io/tree-sitter/, Tree-sitter} parsing +library. It essentially runs @code{tree-sitter generate} to translate +@code{grammar.js} grammars to JSON and then to C. Which it then +compiles to native code. + +Tree-sitter packages may support multiple grammars, so this build system +supports a @code{#:grammar-directories} keyword to specify a list of +locations where a @code{grammar.js} file may be found. + +Grammars sometimes depend on each other, such as C++ depending on C and +TypeScript depending on JavaScript. You may use inputs to declare such +dependencies. + +@end defvr + Lastly, for packages that do not need anything as sophisticated, a ``trivial'' build system is provided. It is trivial in the sense that it provides basically no support: it does not pull any implicit inputs, 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 +;;; +;;; This file is part of GNU Guix. +;;; +;;; GNU Guix is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; GNU Guix is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with GNU Guix. If not, see . + +(define-module (guix build-system 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/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 +;;; +;;; This file is part of GNU Guix. +;;; +;;; GNU Guix is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; GNU Guix is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with GNU Guix. If not, see . + +(define-module (guix build 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 -- cgit v1.2.3 From df5a358f67e729116e8176b8489092cd9e499bf5 Mon Sep 17 00:00:00 2001 From: Tobias Geerinckx-Rice Date: Sun, 12 Feb 2023 01:00:04 +0100 Subject: licenses: Update NPSL (nmap licence). MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit The previous URL does not resolve. The new URL contains an updated licence text (version 0.95 at time of this commit) that is strictly less worse than previous versions, and applies retroactively to older nmaps: “Versions of Nmap released under previous versions of the NPSL may also be used under the NPSL 0.95 terms.” -- * guix/licenses.scm (nmap): Update. --- guix/licenses.scm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/licenses.scm b/guix/licenses.scm index 632c9174df..f7df5826bf 100644 --- a/guix/licenses.scm +++ b/guix/licenses.scm @@ -613,7 +613,7 @@ (define ncsa (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 -- cgit v1.2.3 From 6ce68a7a83a6106da9abaa818e25084e882219b5 Mon Sep 17 00:00:00 2001 From: Ricardo Wurmus Date: Fri, 17 Feb 2023 22:20:45 +0100 Subject: import/cran: Add directory-needs-esbuild?. * guix/import/cran.scm (directory-needs-esbuild?): New procedure. (source-dir->dependencies): Use it. --- guix/import/cran.scm | 8 ++++++++ 1 file changed, 8 insertions(+) (limited to 'guix') diff --git a/guix/import/cran.scm b/guix/import/cran.scm index c4b36da12b..632d632163 100644 --- a/guix/import/cran.scm +++ b/guix/import/cran.scm @@ -447,6 +447,13 @@ (define (directory-needs-fortran? dir) (() #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." @@ -479,6 +486,7 @@ (define (source-dir->dependencies dir) (values (if (directory-needs-zlib? dir) '("zlib") '()) (append + (if (directory-needs-esbuild? dir) '("esbuild") '()) (if (directory-needs-pkg-config? dir) '("pkg-config") '()) (if (directory-needs-fortran? dir) '("gfortran") '())))) -- cgit v1.2.3 From c0507e9f1e358ba7069bc1c7e771730872cfdfeb Mon Sep 17 00:00:00 2001 From: Ricardo Wurmus Date: Fri, 17 Feb 2023 22:21:34 +0100 Subject: import/cran: Add name mapping for libjpeg. * guix/import/cran.scm (transform-sysname): Add mapping from libjpeg to libjpeg-turbo. --- guix/import/cran.scm | 1 + 1 file changed, 1 insertion(+) (limited to 'guix') diff --git a/guix/import/cran.scm b/guix/import/cran.scm index 632d632163..b8cc4f1ef0 100644 --- a/guix/import/cran.scm +++ b/guix/import/cran.scm @@ -422,6 +422,7 @@ (define (transform-sysname sysname) ("libarchive_dev" "libarchive") ("libbz2" "bzip2") ("libexpat" "expat") + ("libjpeg" "libjpeg-turbo") ("liblz4" "lz4") ("liblzma" "xz") ("libzstd" "zstd") -- cgit v1.2.3 From 271c0bfcf2dcea967f9baf02baf179677d179190 Mon Sep 17 00:00:00 2001 From: Ricardo Wurmus Date: Fri, 17 Feb 2023 22:22:42 +0100 Subject: import/cran: Process all vignette builders. * guix/import/cran.scm (needs-knitr?): Remove procedure. (vignette-builders): New procedure. (description->package): Use vignette-builders instead of needs-knitr?. --- guix/import/cran.scm | 7 +++---- 1 file changed, 3 insertions(+), 4 deletions(-) (limited to 'guix') diff --git a/guix/import/cran.scm b/guix/import/cran.scm index b8cc4f1ef0..ebd340ecfa 100644 --- a/guix/import/cran.scm +++ b/guix/import/cran.scm @@ -502,8 +502,8 @@ (define (source->dependencies source 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)) @@ -617,8 +617,7 @@ (define* (description->package repository meta #:key (license-prefix identity) ,@(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) -- cgit v1.2.3 From 049cff91acd3ace275c3f2af97755812af023c6b Mon Sep 17 00:00:00 2001 From: Ricardo Wurmus Date: Fri, 17 Feb 2023 22:25:27 +0100 Subject: import/cran: Add generic way to detect needed libraries. * guix/import/cran.scm (needed-libraries-in-directory): New procedure. (libraries-pattern, packages-for-matches): New variables. --- guix/import/cran.scm | 45 +++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 45 insertions(+) (limited to 'guix') diff --git a/guix/import/cran.scm b/guix/import/cran.scm index ebd340ecfa..75caecb620 100644 --- a/guix/import/cran.scm +++ b/guix/import/cran.scm @@ -55,6 +55,7 @@ (define-module (guix import cran) #:use-module (guix ui) #:use-module (guix upstream) #:use-module (guix packages) + #:use-module (guix sets) #:use-module (gnu packages) #:export (%input-style @@ -475,6 +476,50 @@ (define (directory-needs-zlib? dir) 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 the pkg-config tool." -- cgit v1.2.3 From 8525c2649933f6f8e8e55f5f7c7514b3889b3e9b Mon Sep 17 00:00:00 2001 From: Ricardo Wurmus Date: Fri, 17 Feb 2023 22:26:41 +0100 Subject: import/cran: Remove directory-needs-zlib? in favor of needed-libraries-in-directory. * guix/import/cran.scm (directory-needs-zlib?): Remove procedure. (source-dir->dependencies): Use needed-libraries-in-directory instead of directory-needs-zlib?. --- guix/import/cran.scm | 7 +------ 1 file changed, 1 insertion(+), 6 deletions(-) (limited to 'guix') diff --git a/guix/import/cran.scm b/guix/import/cran.scm index 75caecb620..17c19a2dcf 100644 --- a/guix/import/cran.scm +++ b/guix/import/cran.scm @@ -471,11 +471,6 @@ (define (files-match-pattern? directory regexp . file-patterns) (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") @@ -530,7 +525,7 @@ (define (source-dir->dependencies dir) "Guess dependencies of R package source in DIR and return two values: a list of package names for INPUTS and another list of names of NATIVE-INPUTS." (values - (if (directory-needs-zlib? dir) '("zlib") '()) + (needed-libraries-in-directory dir) (append (if (directory-needs-esbuild? dir) '("esbuild") '()) (if (directory-needs-pkg-config? dir) '("pkg-config") '()) -- cgit v1.2.3 From 189525412e3d803f3f77e15ec4a62aaa57f65a2d Mon Sep 17 00:00:00 2001 From: Julien Lepiller Date: Fri, 3 Feb 2023 12:56:03 +0100 Subject: guix: Show better progress bars. Style provides information on the characters to use before and after the progress bar content (`[` and `]` for the ascii style), as well as the character for filled step (`#` for ascii style). When supported, it provides intermediate steps. This is used for unicode style, to show better precision. * guix/progress.scm (): New record type. (ascii-bar-style, unicode-bar-style): New variables. (progress-bar): Draw progress depending on style. When supported, use unicode style. Fall back to ascii style. --- guix/progress.scm | 45 ++++++++++++++++++++++++++++++++++++++------- 1 file changed, 38 insertions(+), 7 deletions(-) (limited to 'guix') 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 @@ (define current-terminal-columns ;; Number of columns of the terminal. (make-parameter 80)) +(define-record-type* + 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 -- cgit v1.2.3 From 5c099f496f214ccc17ae0fb7c8df63a8e7f46af0 Mon Sep 17 00:00:00 2001 From: Maxim Cournoyer Date: Wed, 1 Feb 2023 09:52:43 -0500 Subject: pack: Use let-keywords instead of keyword-ref. * guix/scripts/pack.scm: (debian-archive): Bind extra-options keyword arguments via let-keywords. --- guix/scripts/pack.scm | 97 +++++++++++++++++++++++---------------------------- 1 file changed, 44 insertions(+), 53 deletions(-) (limited to 'guix') diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm index f65642fb85..e552cb108a 100644 --- a/guix/scripts/pack.scm +++ b/guix/scripts/pack.scm @@ -678,16 +678,15 @@ (define %valid-compressors '("gzip" "xz" "none")) (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))) + (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))) (define build (with-extensions (list guile-gcrypt) @@ -702,6 +701,7 @@ (define build (guix build utils) (guix profiles) (ice-9 match) + (ice-9 optargs) (srfi srfi-1)) (define machine-type @@ -762,32 +762,23 @@ (define data-tarball-file-name (strip-store-file-name (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)) - - (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 "\ + (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))) + + ;; 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,28 +788,28 @@ (define control-tarball-file-name 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 -- cgit v1.2.3 From 68775338a510f84e63657ab09242d79e726fa457 Mon Sep 17 00:00:00 2001 From: Maxim Cournoyer Date: Thu, 2 Feb 2023 13:09:04 -0500 Subject: gexp: computed-file: Honor %guile-for-build. * guix/gexp.scm (computed-file-compiler): Honor %guile-for-build. --- guix/gexp.scm | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) (limited to 'guix') diff --git a/guix/gexp.scm b/guix/gexp.scm index 5f92174a2c..cabf163076 100644 --- a/guix/gexp.scm +++ b/guix/gexp.scm @@ -584,7 +584,8 @@ (define-record-type (options computed-file-options)) ;list of arguments (define* (computed-file name gexp - #:key guile (local-build? #t) (options '())) + #:key guile + (local-build? #t) (options '())) "Return an object representing the store item NAME, a file or directory computed by GEXP. When LOCAL-BUILD? is #t (the default), it ensures the corresponding derivation is built locally. OPTIONS may be used to pass @@ -600,7 +601,8 @@ (define-gexp-compiler (computed-file-compiler (file ) ;; gexp. (match file (($ name gexp guile options) - (mlet %store-monad ((guile (lower-object (or guile (default-guile)) + (mlet %store-monad ((guile (lower-object (or guile (%guile-for-build) + (default-guile)) system #:target #f))) (apply gexp->derivation name gexp #:guile-for-build guile #:system system #:target target options))))) -- cgit v1.2.3 From 68380db4c40a2ee1156349a87254fd7b1f1a52d5 Mon Sep 17 00:00:00 2001 From: Maxim Cournoyer Date: Wed, 1 Feb 2023 15:53:14 -0500 Subject: pack: Extract populate-profile-root from self-contained-tarball/builder. This allows more code to be reused between the various archive writers. * guix/scripts/pack.scm (set-utf8-locale): New top-level procedure, extracted from... (populate-profile-root): New procedure, extracted from... (self-contained-tarball/builder): ... here. Add #:target argument. Call populate-profile-root. [LOCALSTATEDIR?]: Set db.sqlite file permissions. (self-contained-tarball): Call self-contained-tarball/builder with the TARGET argument, and set #:local-build? to #f for the gexp-derivation call. Remove now extraneous #:target and #:references-graphs arguments from the gexp->derivation call. (debian-archive): Call self-contained-tarball/builder with the #:target argument. Fix indentation. Remove now extraneous #:target and #:references-graphs arguments from the gexp->derivation call. --- guix/scripts/pack.scm | 230 +++++++++++++++++++++++++++++--------------------- 1 file changed, 134 insertions(+), 96 deletions(-) (limited to 'guix') diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm index e552cb108a..77425e5b0f 100644 --- a/guix/scripts/pack.scm +++ b/guix/scripts/pack.scm @@ -194,104 +194,144 @@ (define (symlink-spec-option-parser opt name arg result) (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 (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)))) - - (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?) + (or deduplicate? (not (equal? '(guix store deduplication) module))))) + + (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)) + + ;; Make sure non-ASCII file names are properly handled. + #+(set-utf8-locale profile) + + ;; 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: + ;; . + (populate-store (list "profile") #$output + #:deduplicate? #$deduplicate?) + + (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 + #: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 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 %root "root") - - (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)) + (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: - ;; . - (populate-store (list "profile") %root #:deduplicate? #f) - - (when #+localstatedir? - (install-database-and-gc-roots %root #+database #$profile - #:profile-name #$profile-name)) + (define %root (if #$localstatedir? "." #$root)) - ;; Create SYMLINKS. - (for-each (cut evaluate-populate-directive <> %root) - directives) + (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 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 +360,16 @@ (define* (self-contained-tarball name profile (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,13 +715,15 @@ (define %valid-compressors '("gzip" "xz" "none")) 'deb)) (define data-tarball - (computed-file (string-append "data.tar" - (compressor-extension compressor)) + (computed-file (string-append "data.tar" (compressor-extension + compressor)) (self-contained-tarball/builder profile + #:target target #:profile-name profile-name - #:compressor compressor #:localstatedir? localstatedir? + #:deduplicate? deduplicate? #:symlinks symlinks + #:compressor compressor #:archiver archiver) #:local-build? #f ;allow offloading #:options (list #:references-graphs `(("profile" ,profile)) @@ -811,10 +852,7 @@ (define tar (string-append #+archiver "/bin/tar")) "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)) ;;; -- cgit v1.2.3 From 598f4c509bbfec2b983a8ee246cce0a0fe45ec7f Mon Sep 17 00:00:00 2001 From: Maxim Cournoyer Date: Sat, 21 Jan 2023 15:04:09 -0500 Subject: pack: Add RPM format. * guix/rpm.scm: New file. * guix/scripts/pack.scm (rpm-archive): New procedure. (%formats): Register it. (show-formats): Add it. (guix-pack): Register supported extra-options for the rpm format. * tests/pack.scm (rpm-for-tests): New variable. ("rpm archive can be installed/uninstalled"): New test. * tests/rpm.scm: New test. * doc/guix.texi (Invoking guix pack): Document it. --- Makefile.am | 2 + doc/guix.texi | 46 +++- guix/rpm.scm | 623 ++++++++++++++++++++++++++++++++++++++++++++++++++ guix/scripts/pack.scm | 230 ++++++++++++++++++- tests/pack.scm | 57 ++++- tests/rpm.scm | 86 +++++++ 6 files changed, 1031 insertions(+), 13 deletions(-) create mode 100644 guix/rpm.scm create mode 100644 tests/rpm.scm (limited to 'guix') diff --git a/Makefile.am b/Makefile.am index 5ce6cc84f4..8e3815b9c2 100644 --- a/Makefile.am +++ b/Makefile.am @@ -111,6 +111,7 @@ MODULES = \ guix/derivations.scm \ guix/grafts.scm \ guix/repl.scm \ + guix/rpm.scm \ guix/transformations.scm \ guix/inferior.scm \ guix/describe.scm \ @@ -535,6 +536,7 @@ SCM_TESTS = \ tests/pypi.scm \ tests/read-print.scm \ tests/records.scm \ + tests/rpm.scm \ tests/scripts.scm \ tests/search-paths.scm \ tests/services.scm \ diff --git a/doc/guix.texi b/doc/guix.texi index 44e2165a82..05615b9549 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -6896,6 +6896,7 @@ such file or directory'' message. @end quotation @item deb +@cindex Debian, build a .deb package with guix pack This produces a Debian archive (a package with the @samp{.deb} file extension) containing all the specified binaries and symbolic links, that can be installed on top of any dpkg-based GNU(/Linux) distribution. @@ -6912,7 +6913,8 @@ guix pack -f deb -C xz -S /usr/bin/hello=bin/hello hello Because archives produced with @command{guix pack} contain a collection of store items and because each @command{dpkg} package must not have conflicting files, in practice that means you likely won't be able to -install more than one such archive on a given system. +install more than one such archive on a given system. You can +nonetheless pack as many Guix packages as you want in one such archive. @end quotation @quotation Warning @@ -6923,6 +6925,48 @@ shared by other software, such as a Guix installation or other, non-deb packs. @end quotation +@item rpm +@cindex RPM, build an RPM archive with guix pack +This produces an RPM archive (a package with the @samp{.rpm} file +extension) containing all the specified binaries and symbolic links, +that can be installed on top of any RPM-based GNU/Linux distribution. +The RPM format embeds checksums for every file it contains, which the +@command{rpm} command uses to validate the integrity of the archive. + +Advanced RPM-related options are revealed via the +@option{--help-rpm-format} option. These options allow embedding +maintainer scripts that can run before or after the installation of the +RPM archive, for example. + +The RPM format supports relocatable packages via the @option{--prefix} +option of the @command{rpm} command, which can be handy to install an +RPM package to a specific prefix. + +@example +guix pack -f rpm -R -C xz -S /usr/bin/hello=bin/hello hello +@end example + +@example +sudo rpm --install --prefix=/opt /gnu/store/...-hello.rpm +@end example + +@quotation Note +Contrary to Debian packages, conflicting but @emph{identical} files in +RPM packages can be installed simultaneously, which means multiple +@command{guix pack}-produced RPM packages can usually be installed side +by side without any problem. +@end quotation + +@quotation Warning +@command{rpm} assumes ownership of any files contained in the pack, +which means it will remove @file{/gnu/store} upon uninstalling a +Guix-generated RPM package, unless the RPM package was installed with +the @option{--prefix} option of the @command{rpm} command. It is unwise +to install Guix-produced @samp{.rpm} packages on a system where +@file{/gnu/store} is shared by other software, such as a Guix +installation or other, non-rpm packs. +@end quotation + @end table @cindex relocatable binaries diff --git a/guix/rpm.scm b/guix/rpm.scm new file mode 100644 index 0000000000..1cb8326a9b --- /dev/null +++ b/guix/rpm.scm @@ -0,0 +1,623 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2023 Maxim Cournoyer +;;; +;;; This file is part of GNU Guix. +;;; +;;; GNU Guix is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; GNU Guix is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with GNU Guix. If not, see . + +(define-module (guix 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 + (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 object." + (append (u32-number->u8-list (rpm-tag-number tag)) + (u32-number->u8-list (rpm-tag-type tag)))) + +(define-record-type + (make-header-entry tag count value) + header-entry? + (tag header-entry-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 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/color" "/usr/share/dict" "/usr/share/doc" "/usr/share/games" + "/usr/share/info" "/usr/share/locale" "/usr/share/man" "/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 + 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/pack.scm b/guix/scripts/pack.scm index 77425e5b0f..701e41ff1a 100644 --- a/guix/scripts/pack.scm +++ b/guix/scripts/pack.scm @@ -5,7 +5,7 @@ ;;; Copyright © 2018 Chris Marusich ;;; Copyright © 2018 Efraim Flashner ;;; Copyright © 2020 Tobias Geerinckx-Rice -;;; Copyright © 2020, 2021, 2022 Maxim Cournoyer +;;; Copyright © 2020, 2021, 2022, 2023 Maxim Cournoyer ;;; Copyright © 2020 Eric Bavier ;;; Copyright © 2022 Alex Griffin ;;; @@ -67,6 +67,7 @@ (define-module (guix scripts pack) self-contained-tarball debian-archive + rpm-archive docker-image squashfs-image @@ -856,6 +857,166 @@ (define tar (string-append #+archiver "/bin/tar")) ;;; +;;; 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)) + + (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. ;;; @@ -1187,7 +1348,8 @@ (define %formats `((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. @@ -1201,18 +1363,22 @@ (define (show-formats) 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_ " @@ -1231,6 +1397,32 @@ (define (show-deb-format-options/detailed) (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 @@ -1307,7 +1499,12 @@ (define %options (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 @@ -1325,6 +1522,7 @@ (define (show-help) (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")) @@ -1483,6 +1681,16 @@ (define (process-file-arg opts name) (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/tests/pack.scm b/tests/pack.scm index a02924b7d2..734ae1c69b 100644 --- a/tests/pack.scm +++ b/tests/pack.scm @@ -1,7 +1,7 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2017, 2018, 2019, 2020, 2021 Ludovic Courtès ;;; Copyright © 2018 Ricardo Wurmus -;;; Copyright © 2021 Maxim Cournoyer +;;; Copyright © 2021, 2023 Maxim Cournoyer ;;; ;;; This file is part of GNU Guix. ;;; @@ -28,13 +28,16 @@ (define-module (test-pack) #:use-module (guix tests) #:use-module (guix gexp) #:use-module (guix modules) + #:use-module (guix utils) #:use-module (gnu packages) #:use-module ((gnu packages base) #:select (glibc-utf8-locales)) #:use-module (gnu packages bootstrap) + #:use-module ((gnu packages package-management) #:select (rpm)) #:use-module ((gnu packages compression) #:select (squashfs-tools)) #:use-module ((gnu packages debian) #:select (dpkg)) #:use-module ((gnu packages guile) #:select (guile-sqlite3)) #:use-module ((gnu packages gnupg) #:select (guile-gcrypt)) + #:use-module ((gnu packages linux) #:select (fakeroot)) #:use-module (srfi srfi-64)) (define %store @@ -59,6 +62,17 @@ (define %tar-bootstrap %bootstrap-coreutils&co) (define %ar-bootstrap %bootstrap-binutils) +;;; This is a variant of the RPM package configured so that its database can +;;; be created on a writable location readily available inside the build +;;; container ("/tmp"). +(define rpm-for-tests + (package + (inherit rpm) + (arguments (substitute-keyword-arguments (package-arguments rpm) + ((#:configure-flags flags '()) + #~(cons "--localstatedir=/tmp" + (delete "--localstatedir=/var" #$flags))))))) + (test-begin "pack") @@ -355,6 +369,47 @@ (define hard-links (stat "postinst")))))) (assert (file-exists? "triggers")) + (mkdir #$output)))))) + (built-derivations (list check)))) + + (unless store (test-skip 1)) + (test-assertm "rpm archive can be installed/uninstalled" store + (mlet* %store-monad + ((guile (set-guile-for-build (default-guile))) + (profile (profile-derivation (packages->manifest + (list %bootstrap-guile)) + #:hooks '() + #:locales? #f)) + (rpm-pack (rpm-archive "rpm-pack" profile + #:compressor %gzip-compressor + #:symlinks '(("/bin/guile" -> "bin/guile")) + #:extra-options '(#:relocatable? #t))) + (check + (gexp->derivation "check-rpm-pack" + (with-imported-modules (source-module-closure + '((guix build utils))) + #~(begin + (use-modules (guix build utils)) + + (define fakeroot #+(file-append fakeroot "/bin/fakeroot")) + (define rpm #+(file-append rpm-for-tests "/bin/rpm")) + (mkdir-p "/tmp/lib/rpm") + + ;; Install the RPM package. This causes RPM to validate the + ;; signatures, header as well as the file digests, which + ;; makes it a rather thorough test. + (mkdir "test-prefix") + (invoke fakeroot rpm "--install" + (string-append "--prefix=" (getcwd) "/test-prefix") + #$rpm-pack) + + ;; Invoke the installed Guile command. + (invoke "./test-prefix/bin/guile" "--version") + + ;; Uninstall the RPM package. + (invoke fakeroot rpm "--erase" "guile-bootstrap") + + ;; Required so the above is run. (mkdir #$output)))))) (built-derivations (list check))))) diff --git a/tests/rpm.scm b/tests/rpm.scm new file mode 100644 index 0000000000..f40b36fe60 --- /dev/null +++ b/tests/rpm.scm @@ -0,0 +1,86 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2023 Maxim Cournoyer +;;; +;;; This file is part of GNU Guix. +;;; +;;; GNU Guix is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; GNU Guix is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with GNU Guix. If not, see . + +(define-module (test-rpm) + #:use-module (guix rpm) + #:use-module (rnrs bytevectors) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-26) + #:use-module (srfi srfi-64) + #:use-module (srfi srfi-71)) + +;; For white-box testing. +(define-syntax-rule (expose-internal name) + (define name (@@ (guix rpm) name))) + +(expose-internal RPMTAG_ARCH) +(expose-internal RPMTAG_LICENSE) +(expose-internal RPMTAG_NAME) +(expose-internal RPMTAG_OS) +(expose-internal RPMTAG_RELEASE) +(expose-internal RPMTAG_SUMMARY) +(expose-internal RPMTAG_VERSION) +(expose-internal header-entry-count) +(expose-internal header-entry-tag) +(expose-internal header-entry-value) +(expose-internal header-entry?) +(expose-internal make-header) +(expose-internal make-header-entry) +(expose-internal make-header-index+data) + +(test-begin "rpm") + +(test-equal "lead must be 96 bytes long" + 96 + (length (generate-lead "hello-2.12.1"))) + +(define header-entries + (list (make-header-entry RPMTAG_NAME 1 "hello") + (make-header-entry RPMTAG_VERSION 1 "2.12.1") + (make-header-entry RPMTAG_RELEASE 1 "0") + (make-header-entry RPMTAG_SUMMARY 1 + "Hello, GNU world: An example GNU package") + (make-header-entry RPMTAG_LICENSE 1 "GPL 3 or later") + (make-header-entry RPMTAG_OS 1 "Linux") + (make-header-entry RPMTAG_ARCH 1 "x86_64"))) + +(define expected-header-index-length + (* 16 (length header-entries))) ;16 bytes per index entry + +(define expected-header-data-length + (+ (length header-entries) ;to account for null bytes + (fold + 0 (map (compose string-length (cut header-entry-value <>)) + header-entries)))) + +(let ((index data (make-header-index+data header-entries))) + (test-equal "header index" + expected-header-index-length + (length index)) + + ;; This test depends on the fact that only STRING entries are used, and that + ;; they are composed of single byte characters and the delimiting null byte. + (test-equal "header data" + expected-header-data-length + (length data))) + +(test-equal "complete header section" + (+ 16 ;leading magic + count bytes + expected-header-index-length expected-header-data-length) + (length (make-header header-entries))) + +(test-end) -- cgit v1.2.3 From 1fee391a254377aa7d88400eafa24105c5f26486 Mon Sep 17 00:00:00 2001 From: Maxim Cournoyer Date: Tue, 21 Feb 2023 23:37:09 -0500 Subject: pack: Register extra /usr/share sub-directories as FHS. * guix/rpm.scm (%fhs-directories): Add extra FHS directories. They were found to conflict while testing a 'guix pack' built Jami RPM. --- guix/rpm.scm | 9 ++++++++- 1 file changed, 8 insertions(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/rpm.scm b/guix/rpm.scm index 1cb8326a9b..734aef29c1 100644 --- a/guix/rpm.scm +++ b/guix/rpm.scm @@ -393,8 +393,15 @@ (define %fhs-directories "/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/info" "/usr/share/locale" "/usr/share/man" "/usr/share/misc" + "/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" -- cgit v1.2.3 From 5e7b0a7735d9956ee8b8c3763e4ce05e2855606f Mon Sep 17 00:00:00 2001 From: Maxim Cournoyer Date: Wed, 22 Feb 2023 11:36:02 -0500 Subject: pack: Add UTF-8 locales to RPM pack builder. It's necessary as 'generate-header' call ends up calling 'find-files', which could fail to read file names containing non-ascii characters, as spotted in the wild: building /gnu/store/...-jami-rpm-pack.rpm.drv... find-files: ./gnu/store/...-nss-certs-3.81/etc/ssl/certs/NetLock_Arany_=Class_Gold=_F??tan??s??tv??ny.pem: No such file or directory * guix/scripts/pack.scm (rpm-archive): Expand set-utf8-locale helper in the builder gexp. --- guix/scripts/pack.scm | 3 +++ 1 file changed, 3 insertions(+) (limited to 'guix') diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm index 701e41ff1a..51a7b8f185 100644 --- a/guix/scripts/pack.scm +++ b/guix/scripts/pack.scm @@ -945,6 +945,9 @@ (define build (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) -- cgit v1.2.3 From 9aa750776a6c6807fbb6b59d1d36361c4d4f7536 Mon Sep 17 00:00:00 2001 From: Tobias Geerinckx-Rice Date: Sun, 19 Feb 2023 01:00:00 +0100 Subject: ssh: Factor out progress % calculation. * guix/ssh.scm (notify-transfer-progress): Trust its % argument. --- guix/ssh.scm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'guix') 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 @@ (define (notify-transfer-progress item port sizes total 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)) -- cgit v1.2.3 From 98e2a15b1e31689b75f3ded128f1650d0f091436 Mon Sep 17 00:00:00 2001 From: Tobias Geerinckx-Rice Date: Sun, 19 Feb 2023 01:00:00 +0100 Subject: git: Factor out INDEXER-PROGRESS-TOTAL-OBJECTS access. * guix/git.scm (show-progress): Reuse the result of the first call. --- guix/git.scm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/git.scm b/guix/git.scm index 95630a5e69..a1e6b3fa9c 100644 --- a/guix/git.scm +++ b/guix/git.scm @@ -142,7 +142,7 @@ (define total (indexer-progress-total-objects progress)) (define hundredth - (match (quotient (indexer-progress-total-objects progress) 100) + (match (quotient total 100) (0 1) (x x))) -- cgit v1.2.3 From 5d10644371abd54d0edcd638691113f0a92de743 Mon Sep 17 00:00:00 2001 From: Tobias Geerinckx-Rice Date: Sun, 19 Feb 2023 01:00:00 +0100 Subject: git: Make better use of the better progress bar. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Commit 189525412e3d803f3f77e15ec4a62aaa57f65a2d introduced ‘high-resolution’ Unicode progress bars, but these require more granular calls to reach their full potential. * guix/git.scm (show-progress): Derive the number of PROGRESS-BAR updates from its maximum resolution, rather than hard-coding 100. --- guix/git.scm | 26 +++++++++++++++----------- 1 file changed, 15 insertions(+), 11 deletions(-) (limited to 'guix') diff --git a/guix/git.scm b/guix/git.scm index a1e6b3fa9c..4019323327 100644 --- a/guix/git.scm +++ b/guix/git.scm @@ -4,6 +4,7 @@ ;;; Copyright © 2021 Kyle Meyer ;;; Copyright © 2021 Marius Bakke ;;; Copyright © 2022 Maxime Devos +;;; Copyright © 2023 Tobias Geerinckx-Rice ;;; ;;; This file is part of GNU Guix. ;;; @@ -141,11 +142,6 @@ (define (show-progress progress) (define total (indexer-progress-total-objects progress)) - (define hundredth - (match (quotient total 100) - (0 1) - (x x))) - (define-values (done label) (if (< (indexer-progress-received-objects progress) total) (values (indexer-progress-received-objects progress) @@ -156,14 +152,22 @@ (define-values (done label) (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.) -- cgit v1.2.3 From e615aaca28fd6b797e9b41a71096ebe878c89299 Mon Sep 17 00:00:00 2001 From: Andrew Tropin Date: Fri, 24 Feb 2023 16:04:33 +0400 Subject: scripts: home: Move ensure-profile-directory to a better place. The profile directory is usually created by daemon, when user opens a connection. Ideally, we would like to remove ensure-profile-directory call at all, but daemon doesn't handle case with custom $GUIX_STATE_DIRECTORY yet. More information in: * guix/scripts/home.scm (process-action): Move ensure-profile-directory call to the place, where connection to the daemon is already open. Reported-by: wolf --- guix/scripts/home.scm | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) (limited to 'guix') diff --git a/guix/scripts/home.scm b/guix/scripts/home.scm index 1d8aae727e..d86094bc43 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 +;;; Copyright © 2021, 2023 Andrew Tropin ;;; Copyright © 2021 Xinglu Chen ;;; Copyright © 2021 Pierre Langlois ;;; Copyright © 2021 Oleg Pykhalov @@ -409,6 +409,7 @@ (define* (perform-action action he network?) "Perform ACTION for home environment. " + (ensure-profile-directory) (define println (cut format #t "~a~%" <>)) @@ -473,7 +474,6 @@ (define (process-action action args opts) 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)) -- cgit v1.2.3 From 53d718f61b4f59bf240515a8f2000972d3dca7b8 Mon Sep 17 00:00:00 2001 From: Maxim Cournoyer Date: Fri, 24 Feb 2023 21:24:52 -0500 Subject: offload: Increase initial SSH connection timeout. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Fixes . * guix/scripts/offload.scm (open-ssh-session): Increase connection timeout from 10 s to 30 s. Co-authored-by: Ludovic Courtès --- guix/scripts/offload.scm | 7 ++++++- 1 file changed, 6 insertions(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/scripts/offload.scm b/guix/scripts/offload.scm index 578b3b9888..8c6132e7c3 100644 --- a/guix/scripts/offload.scm +++ b/guix/scripts/offload.scm @@ -220,7 +220,12 @@ (define* (open-ssh-session machine #:optional max-silent-time) (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) -- cgit v1.2.3 From 61f691fdfb4846e123e6423ee192142a35bd114d Mon Sep 17 00:00:00 2001 From: Maxim Cournoyer Date: Thu, 23 Feb 2023 23:37:32 -0500 Subject: cpio: Properly handle Unicode characters in file names. Fixes . * guix/cpio.scm (file->cpio-header): Compute the file name length in bytes rather than in characters. (file->cpio-header*, special-file->cpio-header*): Likewise. (write-cpio-archive): Likewise, and write the file name as UTF-8 bytes, not textually, to avoid encoding it as ISO-8859-1. --- guix/cpio.scm | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) (limited to 'guix') 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 @@ (define* (file->cpio-header file #:optional (file-name file) #: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 @@ (define* (file->cpio-header* file (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 @@ (define* (special-file->cpio-header* file 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 @@ (define (dump-file file) ;; 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 @@ (define (dump-file file) (dump-port input port)))) ((symlink) (let ((target (readlink file))) - (put-string port target))) + (put-bytevector port (string->utf8 target)))) ((directory) #t) ((block-special) -- cgit v1.2.3 From 3e3f888dd3d3c06f20e566263f55791dd2316c25 Mon Sep 17 00:00:00 2001 From: Lars-Dominik Braun Date: Sat, 11 Jun 2022 11:02:52 +0200 Subject: import: hackage: Allow version at the beginning of cabal file. Fix a corner case, uncovered by the hedgehog package, which has the version field at the beginning of its cabal file. This causes a pattern match failure. * guix/import/hackage.scm (latest-release): Match version at beginning of expression too. --- guix/import/hackage.scm | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/import/hackage.scm b/guix/import/hackage.scm index 7bc2908405..e915aac58d 100644 --- a/guix/import/hackage.scm +++ b/guix/import/hackage.scm @@ -378,7 +378,10 @@ (define* (latest-release package #:key (version #f)) "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)) -- cgit v1.2.3 From 29d5fb76193b787c4f825af513effb7793301f0c Mon Sep 17 00:00:00 2001 From: zimoun Date: Wed, 6 Apr 2022 21:19:07 +0200 Subject: build: haskell-build-system: Remove trailing #t. * guix/build/haskell-build-system.scm (configure, install, setup-compiler, make-ghc-package-database, install-transitive-deps, check, haddock, patch-cabal-file, generate-setuphs): Delete trailing #t. Signed-off-by: Lars-Dominik Braun --- guix/build/haskell-build-system.scm | 25 +++++++++---------------- 1 file changed, 9 insertions(+), 16 deletions(-) (limited to 'guix') diff --git a/guix/build/haskell-build-system.scm b/guix/build/haskell-build-system.scm index ef6cb316ee..e2e5904dce 100644 --- a/guix/build/haskell-build-system.scm +++ b/guix/build/haskell-build-system.scm @@ -5,6 +5,7 @@ ;;; Copyright © 2018, 2020 Ricardo Wurmus ;;; Copyright © 2018 Alex Vong ;;; Copyright © 2021 John Kehayias +;;; Copyright © 2022 Simon Tournier ;;; ;;; This file is part of GNU Guix. ;;; @@ -118,8 +119,7 @@ (define* (configure #:key outputs inputs tests? (configure-flags '()) (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." @@ -140,8 +140,7 @@ (define* (install #:key outputs #:allow-other-keys) (new (string-append static subdir))) (mkdir-p (dirname new)) (rename-file static-lib new))) - (find-files lib "\\.a$")))) - #t) + (find-files lib "\\.a$"))))) (define* (setup-compiler #:key system inputs outputs #:allow-other-keys) "Setup the compiler environment." @@ -175,8 +174,7 @@ (define (make-ghc-package-database system inputs outputs) 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 @@ -273,21 +271,18 @@ (define (install-transitive-deps conf-file src dest) config-file-name+id ".conf")) (invoke "ghc-pkg" (string-append "--package-db=" config-dir) - "recache"))) - #t)) + "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 +291,7 @@ (define* (patch-cabal-file #:key cabal-revision #:allow-other-keys) ((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 +301,7 @@ (define* (generate-setuphs #:rest empty) (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 -- cgit v1.2.3 From 3455a004ec78a8c8a579b74da8039fbcd36cea73 Mon Sep 17 00:00:00 2001 From: Philip Munksgaard Date: Wed, 6 Apr 2022 21:19:08 +0200 Subject: build: haskell-build-system: Support multiple libraries. Fixes . The patch handles correctly the multiple registration of some package using their own internal sub-libraries. It allows to call 'install-transitive-deps' multiple times and deals with packages requiring a multiple registration. * guix/build/haskell-build-system.scm (register)[install-transitive-deps]: Guard also the destination direction. [install-config-file]: New procedure. Co-Authored-by: zimoun . Signed-off-by: Lars-Dominik Braun --- guix/build/haskell-build-system.scm | 87 +++++++++++++++++++++---------------- 1 file changed, 49 insertions(+), 38 deletions(-) (limited to 'guix') diff --git a/guix/build/haskell-build-system.scm b/guix/build/haskell-build-system.scm index e2e5904dce..fb4aba28ea 100644 --- a/guix/build/haskell-build-system.scm +++ b/guix/build/haskell-build-system.scm @@ -6,6 +6,7 @@ ;;; Copyright © 2018 Alex Vong ;;; Copyright © 2021 John Kehayias ;;; Copyright © 2022 Simon Tournier +;;; Copyright © 2022 Philip Munksgaard ;;; ;;; This file is part of GNU Guix. ;;; @@ -215,13 +216,50 @@ (define (install-transitive-deps conf-file src dest) (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)) + (unless (file-exists? dep-conf*) + (unless (file-exists? dep-conf) (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) + (append lst (conf-depends dep-conf))))) (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")) @@ -231,7 +269,6 @@ (define (install-transitive-deps conf-file src dest) (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)))) @@ -239,39 +276,13 @@ (define (install-transitive-deps conf-file src dest) ;; 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"))))) + (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." -- cgit v1.2.3 From eb42d18180dbd80ac5545422fbdd8e49889423a1 Mon Sep 17 00:00:00 2001 From: Lars-Dominik Braun Date: Sun, 8 May 2022 13:55:07 +0200 Subject: import: stackage: Update to release 20.5. * guix/import/stackage.scm (%default-lts-version): Update to 20.5. --- guix/import/stackage.scm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/import/stackage.scm b/guix/import/stackage.scm index c0284e48a4..9462e70791 100644 --- a/guix/import/stackage.scm +++ b/guix/import/stackage.scm @@ -49,7 +49,7 @@ (define %stackage-url (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 make-stackage-lts stackage-lts? -- cgit v1.2.3 From 84549dcf380b1ed7712816a1ff1bfe9688c1d9a7 Mon Sep 17 00:00:00 2001 From: Lars-Dominik Braun Date: Wed, 4 Jan 2023 09:37:25 +0100 Subject: import: hackage: Add upstream-name property. * guix/import/hackage.scm (hackage-module->sexp): Add property upstream-name to imported package. * tests/hackage.scm (match-ghc-foo): Add upstream-name property. (match-ghc-foo-6): Ditto. (match-ghc-elif): Ditto. (match-ghc-foo-revision): Ditto. (match-ghc-foo-import): Ditto. --- guix/import/hackage.scm | 1 + tests/hackage.scm | 5 +++++ 2 files changed, 6 insertions(+) (limited to 'guix') diff --git a/guix/import/hackage.scm b/guix/import/hackage.scm index e915aac58d..9e305cf080 100644 --- a/guix/import/hackage.scm +++ b/guix/import/hackage.scm @@ -314,6 +314,7 @@ (define (maybe-arguments) (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) diff --git a/tests/hackage.scm b/tests/hackage.scm index ad2ee4b7f9..8eea818ebd 100644 --- a/tests/hackage.scm +++ b/tests/hackage.scm @@ -201,6 +201,7 @@ (define-package-matcher match-ghc-foo ('base32 (? string? hash))))) ('build-system 'haskell-build-system) + ('properties '(quote ((upstream-name . "foo")))) ('inputs ('list 'ghc-http)) ('home-page "http://test.org") ('synopsis (? string?)) @@ -241,6 +242,7 @@ (define-package-matcher match-ghc-foo-6 ('base32 (? string? hash))))) ('build-system 'haskell-build-system) + ('properties '(quote ((upstream-name . "foo")))) ('inputs ('list 'ghc-b 'ghc-http)) ('native-inputs ('list 'ghc-haskell-gi)) ('home-page "http://test.org") @@ -471,6 +473,7 @@ (define-package-matcher match-ghc-elif ('base32 (? string? hash))))) ('build-system 'haskell-build-system) + ('properties '(quote ((upstream-name . "foo")))) ('inputs ('list 'ghc-c)) ('home-page "http://test.org") ('synopsis (? string?)) @@ -520,6 +523,7 @@ (define-package-matcher match-ghc-foo-revision ('base32 (? string? hash))))) ('build-system 'haskell-build-system) + ('properties '(quote ((upstream-name . "foo")))) ('inputs ('list 'ghc-http)) ('arguments ('quasiquote @@ -610,6 +614,7 @@ (define-package-matcher match-ghc-foo-import ('base32 (? string? hash))))) ('build-system 'haskell-build-system) + ('properties '(quote ((upstream-name . "foo")))) ('inputs ('list 'ghc-http)) ('home-page "http://test.org") ('synopsis (? string?)) -- cgit v1.2.3 From d06ae5301351bf4af71dcebd6dd85b4546e1b677 Mon Sep 17 00:00:00 2001 From: Lars-Dominik Braun Date: Wed, 4 Jan 2023 09:37:26 +0100 Subject: import: hackage: Use upstream-name property. * guix/import/hackage.scm (guix-package->hackage-name): Removed. (latest-release): Use package-upstream-name* instead. * guix/import/stackage.scm (latest-lts-release): Ditto. (stackage-lts-package?): Ditto. --- guix/import/hackage.scm | 14 +------------- guix/import/stackage.scm | 4 ++-- 2 files changed, 3 insertions(+), 15 deletions(-) (limited to 'guix') diff --git a/guix/import/hackage.scm b/guix/import/hackage.scm index 9e305cf080..2f901af47b 100644 --- a/guix/import/hackage.scm +++ b/guix/import/hackage.scm @@ -52,7 +52,6 @@ (define-module (guix import hackage) hackage-recursive-import %hackage-updater - guix-package->hackage-name hackage-name->package-name hackage-fetch hackage-source-url @@ -126,17 +125,6 @@ (define (hackage-name->package-name name) (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." @@ -371,7 +359,7 @@ (define* (latest-release package #:key (version #f)) (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 diff --git a/guix/import/stackage.scm b/guix/import/stackage.scm index 9462e70791..735eeb75f7 100644 --- a/guix/import/stackage.scm +++ b/guix/import/stackage.scm @@ -149,7 +149,7 @@ (define latest-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 @@ (define (stackage-lts-package? package) (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))))) -- cgit v1.2.3 From b0fc911b5b287ef66f3c607bd0d13ad67fbf72a7 Mon Sep 17 00:00:00 2001 From: Lars-Dominik Braun Date: Fri, 6 Jan 2023 10:11:28 +0100 Subject: import: haskell: Add new internal library for GHC 9.2. * guix/import/hackage.scm (ghc-standard-libraries): Add ghc-bignum. --- guix/import/hackage.scm | 1 + 1 file changed, 1 insertion(+) (limited to 'guix') diff --git a/guix/import/hackage.scm b/guix/import/hackage.scm index 2f901af47b..83ad85f3fe 100644 --- a/guix/import/hackage.scm +++ b/guix/import/hackage.scm @@ -75,6 +75,7 @@ (define ghc-standard-libraries "exceptions" "filepath" "ghc" + "ghc-bignum" "ghc-boot" "ghc-boot-th" "ghc-compact" -- cgit v1.2.3 From 39c97cf3d03e2a5f7929654ecf92e92ab03bb953 Mon Sep 17 00:00:00 2001 From: Lars-Dominik Braun Date: Fri, 6 Jan 2023 12:46:26 +0100 Subject: build: haskell-build-system: Process all transitive dependencies. A bug caused install-transitive-deps to stop looping if a dependency file already existed in the target directory. For Haskell packages with multiple libraries (like attoparsec) this resulted in missing dependencies and error messages like this: The following packages are broken because other packages they depend on are missing. These broken packages must be rebuilt before they can be used. installed package attoparsec-0.14.4 is broken due to missing package scientific-0.3.7.0-9XG3zUjXOw970JFcruv0cZ See . * guix/build/haskell-build-system.scm (register): Unconditionally loop over all tails. --- guix/build/haskell-build-system.scm | 16 +++++++++------- 1 file changed, 9 insertions(+), 7 deletions(-) (limited to 'guix') diff --git a/guix/build/haskell-build-system.scm b/guix/build/haskell-build-system.scm index fb4aba28ea..72e12ba746 100644 --- a/guix/build/haskell-build-system.scm +++ b/guix/build/haskell-build-system.scm @@ -214,14 +214,16 @@ (define (install-transitive-deps conf-file src dest) (() #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"))) - (unless (file-exists? dep-conf*) - (unless (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) -- cgit v1.2.3 From 9262c14d73b4b216bb9c1f76fb6b3a9709da1de3 Mon Sep 17 00:00:00 2001 From: Lars-Dominik Braun Date: Fri, 20 Jan 2023 16:57:27 +0100 Subject: build: haskell-build-system: Remove unused linker flags. They were inserted as-is, without expandind variables into binaries. * guix/build/haskell-build-system.scm (configure): Remove --ghc-option. --- guix/build/haskell-build-system.scm | 2 -- 1 file changed, 2 deletions(-) (limited to 'guix') diff --git a/guix/build/haskell-build-system.scm b/guix/build/haskell-build-system.scm index 72e12ba746..759d3c5d17 100644 --- a/guix/build/haskell-build-system.scm +++ b/guix/build/haskell-build-system.scm @@ -103,8 +103,6 @@ (define* (configure #:key outputs inputs tests? (configure-flags '()) "--enable-shared" "--enable-executable-dynamic" "--ghc-option=-fPIC" - ,(string-append "--ghc-option=-optl=-Wl,-rpath=" (or lib out) - "/lib/$compiler/$pkg-$version") ,@configure-flags))) ;; Cabal errors if GHC_PACKAGE_PATH is set during 'configure', so unset ;; and restore it. -- cgit v1.2.3 From 4bb40b098d81e70ebaf86250cb0162bb285ef6ca Mon Sep 17 00:00:00 2001 From: Lars-Dominik Braun Date: Sun, 29 Jan 2023 18:43:05 +0100 Subject: build-system: haskell: Drop default "static" output. * guix/build-system/haskell.scm (lower): Pass outputs to lowered bag. * guix/build/haskell-build-system.scm (install): Remove static library moving code. * gnu/packages/haskell-check.scm (ghc-hunit): Remove "static" output. * gnu/packages/haskell-crypto.scm (ghc-crypto-api-tests): Likewise. * gnu/packages/haskell-xyz.scm (ghc-case-insensitive): Likewise. (ghc-cmdargs): Likewise. (ghc-conduit): Likewise. (ghc-fgl): Likewise. (ghc-haskell-src-exts): Likewise. (ghc-lib-parser): Likewise. (ghc-mono-traversable): Likewise. (ghc-parallel): Likewise. (ghc-paths): Likewise. (ghc-profunctors): Likewise. (ghc-tf-random): Likewise. (ghc-vector): Likewise. --- gnu/packages/haskell-check.scm | 2 +- gnu/packages/haskell-crypto.scm | 1 - gnu/packages/haskell-xyz.scm | 24 ++++++++++++------------ guix/build-system/haskell.scm | 5 +---- guix/build/haskell-build-system.scm | 12 +----------- 5 files changed, 15 insertions(+), 29 deletions(-) (limited to 'guix') diff --git a/gnu/packages/haskell-check.scm b/gnu/packages/haskell-check.scm index 6b7fe878e2..23727fc0b8 100644 --- a/gnu/packages/haskell-check.scm +++ b/gnu/packages/haskell-check.scm @@ -629,7 +629,7 @@ (define-public ghc-hunit (package (name "ghc-hunit") (version "1.6.2.0") - (outputs '("out" "static" "doc")) + (outputs '("out" "doc")) (source (origin (method url-fetch) diff --git a/gnu/packages/haskell-crypto.scm b/gnu/packages/haskell-crypto.scm index 0046e0481a..42e2a15709 100644 --- a/gnu/packages/haskell-crypto.scm +++ b/gnu/packages/haskell-crypto.scm @@ -141,7 +141,6 @@ (define-public ghc-crypto-api-tests "0w3j43jdrlj28jryp18hc6q84nkl2yf4vs1hhgrsk7gb9kfyqjpl")))) (build-system haskell-build-system) (properties '((upstream-name . "crypto-api-tests"))) - (outputs '("out" "static" "doc")) (inputs (list ghc-test-framework-quickcheck2 ghc-crypto-api ghc-cereal diff --git a/gnu/packages/haskell-xyz.scm b/gnu/packages/haskell-xyz.scm index 03d670fa92..475db5c275 100644 --- a/gnu/packages/haskell-xyz.scm +++ b/gnu/packages/haskell-xyz.scm @@ -1395,7 +1395,7 @@ (define-public ghc-case-insensitive (package (name "ghc-case-insensitive") (version "1.2.1.0") - (outputs '("out" "static" "doc")) + (outputs '("out" "doc")) (source (origin (method url-fetch) @@ -1993,7 +1993,7 @@ (define-public ghc-cmdargs "0xfabq187n1vqrnnm4ciprpl0dcjq97rksyjnpcniwva9rffmn7p")))) (build-system haskell-build-system) (properties '((upstream-name . "cmdargs"))) - (outputs '("out" "static" "doc")) + (outputs '("out" "doc")) (home-page "http://community.haskell.org/~ndm/cmdargs/") (synopsis "Command line argument processing") @@ -2171,7 +2171,7 @@ (define-public ghc-conduit "18izjgff4pmrknc8py06yvg3g6x27nx0rzmlwjxcflwm5v4szpw4")))) (build-system haskell-build-system) (properties '((upstream-name . "conduit"))) - (outputs '("out" "static" "doc")) + (outputs '("out" "doc")) (inputs (list ghc-exceptions ghc-lifted-base @@ -3855,7 +3855,7 @@ (define-public ghc-fgl (package (name "ghc-fgl") (version "5.7.0.3") - (outputs '("out" "static" "doc")) + (outputs '("out" "doc")) (source (origin (method url-fetch) @@ -4958,7 +4958,7 @@ (define-public ghc-haskell-src-exts "01bcrxs9af4yqpclw43aijmsd1g19qhyzb47blz7vzwz2r3k11b7")))) (build-system haskell-build-system) (properties '((upstream-name . "haskell-src-exts"))) - (outputs '("out" "static" "doc")) + (outputs '("out" "doc")) (inputs (list cpphs ghc-happy ghc-pretty-show)) (native-inputs @@ -6349,7 +6349,7 @@ (define-public ghc-lib-parser "1xh8rm5lwbh96g4v34whkcbb1yjsyvx3rwwycj30lrglhqk7f4c4")))) (build-system haskell-build-system) (properties '((upstream-name . "ghc-lib-parser"))) - (outputs '("out" "static" "doc")) ; documentation is 39M + (outputs '("out" "doc")) ; documentation is 39M (native-inputs (list ghc-alex ghc-happy)) (home-page "https://github.com/digital-asset/ghc-lib") (synopsis "The GHC API, decoupled from GHC versions") @@ -7314,7 +7314,7 @@ (define-public ghc-mono-traversable "1dvlp7r7r1lc3fxkwaz68f1nffg83240q8a989x24x1x67rj1clq")))) (build-system haskell-build-system) (properties '((upstream-name . "mono-traversable"))) - (outputs '("out" "static" "doc")) + (outputs '("out" "doc")) (inputs (list ghc-unordered-containers ghc-hashable ghc-vector ghc-vector-algorithms ghc-split)) (native-inputs (list ghc-hspec ghc-hunit ghc-quickcheck ghc-foldl)) @@ -8320,7 +8320,7 @@ (define-public ghc-parallel (package (name "ghc-parallel") (version "3.2.2.0") - (outputs '("out" "static" "doc")) + (outputs '("out" "doc")) (source (origin (method url-fetch) @@ -8480,7 +8480,7 @@ (define-public ghc-paths (package (name "ghc-paths") (version "0.1.0.12") - (outputs '("out" "static" "doc")) + (outputs '("out" "doc")) (source (origin (method url-fetch) @@ -9118,7 +9118,7 @@ (define-public ghc-profunctors "0an9v003ivxmjid0s51qznbjhd5fsa1dkcfsrhxllnjja1xmv5b5")))) (build-system haskell-build-system) (properties '((upstream-name . "profunctors"))) - (outputs '("out" "static" "doc")) + (outputs '("out" "doc")) (inputs (list ghc-base-orphans ghc-bifunctors @@ -11894,7 +11894,7 @@ (define-public ghc-tf-random (package (name "ghc-tf-random") (version "0.5") - (outputs '("out" "static" "doc")) + (outputs '("out" "doc")) (source (origin (method url-fetch) @@ -13163,7 +13163,7 @@ (define-public ghc-vector (package (name "ghc-vector") (version "0.12.3.1") - (outputs '("out" "static" "doc")) + (outputs '("out" "doc")) (source (origin (method url-fetch) diff --git a/guix/build-system/haskell.scm b/guix/build-system/haskell.scm index dc83512d30..a37b3a938c 100644 --- a/guix/build-system/haskell.scm +++ b/guix/build-system/haskell.scm @@ -109,10 +109,7 @@ (define (cabal-revision->origin cabal-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/haskell-build-system.scm b/guix/build/haskell-build-system.scm index 759d3c5d17..d77f55da19 100644 --- a/guix/build/haskell-build-system.scm +++ b/guix/build/haskell-build-system.scm @@ -129,17 +129,7 @@ (define* (build #:key parallel-build? #:allow-other-keys) (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$"))))) + (run-setuphs "copy" '())) (define* (setup-compiler #:key system inputs outputs #:allow-other-keys) "Setup the compiler environment." -- cgit v1.2.3 From dc3e22f4d5d7aa94fef9e380a3d2c0d71143ced9 Mon Sep 17 00:00:00 2001 From: Lars-Dominik Braun Date: Sun, 29 Jan 2023 18:50:10 +0100 Subject: build: haskell-build-system: Build static executables by default. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit This is the only way to get reasonably small binaries that don’t pull in a ton of ghc-* packages. * guix/build/haskell-build-system.scm (configure): Explicitly add --enable-static and --disable-executable-dynamic, as well as -split-sections to configure flags. --- guix/build/haskell-build-system.scm | 8 ++++++-- 1 file changed, 6 insertions(+), 2 deletions(-) (limited to 'guix') diff --git a/guix/build/haskell-build-system.scm b/guix/build/haskell-build-system.scm index d77f55da19..0e94cf59a5 100644 --- a/guix/build/haskell-build-system.scm +++ b/guix/build/haskell-build-system.scm @@ -99,10 +99,14 @@ (define* (configure #:key outputs inputs tests? (configure-flags '()) ,@(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" + ;; 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. -- cgit v1.2.3 From fee1d08f0dd183ef78bcb9f1534d7b9e7f1df7ac Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 27 Feb 2023 15:35:54 +0100 Subject: pack: Make sure tests can run without a world rebuild. Commit 68380db4c40a2ee1156349a87254fd7b1f1a52d5 moved from 'gexp->derivation', which as a side effect, would lead tests to require a "world rebuild"--specifically, they'd have to build (default-guile). This was mitigated by 68775338a510f84e63657ab09242d79e726fa457, but that change introduced another regression. * guix/scripts/pack.scm (populate-profile-root): Define 'bootstrap?'. Pass #:guile to 'computed-file', with a value depending on 'bootstrap?'. * tests/pack.scm ("self-contained-tarball + localstatedir") ("docker-image + localstatedir", "squashfs-image + localstatedir") ("deb archive with symlinks and control files") ("rpm archive can be installed/uninstalled"): Use a record instead of a derivation. --- guix/scripts/pack.scm | 8 +++++++- tests/pack.scm | 40 ++++++++++++++++++++-------------------- 2 files changed, 27 insertions(+), 21 deletions(-) (limited to 'guix') diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm index 51a7b8f185..eb41eb5563 100644 --- a/guix/scripts/pack.scm +++ b/guix/scripts/pack.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2015, 2017-2022 Ludovic Courtès +;;; Copyright © 2015, 2017-2023 Ludovic Courtès ;;; Copyright © 2017, 2018 Ricardo Wurmus ;;; Copyright © 2018 Konrad Hinsen ;;; Copyright © 2018 Chris Marusich @@ -220,6 +220,11 @@ (define database (file-append (store-database (list profile)) "/db/db.sqlite"))) + (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 @@ -287,6 +292,7 @@ (define directives (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))) diff --git a/tests/pack.scm b/tests/pack.scm index 734ae1c69b..87187bb62c 100644 --- a/tests/pack.scm +++ b/tests/pack.scm @@ -138,10 +138,10 @@ (define bin (test-assertm "self-contained-tarball + localstatedir" store (mlet* %store-monad ((guile (set-guile-for-build (default-guile))) - (profile (profile-derivation (packages->manifest - (list %bootstrap-guile)) - #:hooks '() - #:locales? #f)) + (profile -> (profile + (content (packages->manifest (list %bootstrap-guile))) + (hooks '()) + (locales? #f))) (tarball (self-contained-tarball "tar-pack" profile #:localstatedir? #t)) (check (gexp->derivation "check-tarball" @@ -210,10 +210,10 @@ (define file (test-assertm "docker-image + localstatedir" store (mlet* %store-monad ((guile (set-guile-for-build (default-guile))) - (profile (profile-derivation (packages->manifest - (list %bootstrap-guile)) - #:hooks '() - #:locales? #f)) + (profile -> (profile + (content (packages->manifest (list %bootstrap-guile))) + (hooks '()) + (locales? #f))) (tarball (docker-image "docker-pack" profile #:symlinks '(("/bin/Guile" -> "bin/guile")) #:localstatedir? #t)) @@ -250,10 +250,10 @@ (define bin (test-assertm "squashfs-image + localstatedir" store (mlet* %store-monad ((guile (set-guile-for-build (default-guile))) - (profile (profile-derivation (packages->manifest - (list %bootstrap-guile)) - #:hooks '() - #:locales? #f)) + (profile -> (profile + (content (packages->manifest (list %bootstrap-guile))) + (hooks '()) + (locales? #f))) (image (squashfs-image "squashfs-pack" profile #:symlinks '(("/bin" -> "bin")) #:localstatedir? #t)) @@ -288,10 +288,10 @@ (define bin (test-assertm "deb archive with symlinks and control files" store (mlet* %store-monad ((guile (set-guile-for-build (default-guile))) - (profile (profile-derivation (packages->manifest - (list %bootstrap-guile)) - #:hooks '() - #:locales? #f)) + (profile -> (profile + (content (packages->manifest (list %bootstrap-guile))) + (hooks '()) + (locales? #f))) (deb (debian-archive "deb-pack" profile #:compressor %gzip-compressor @@ -376,10 +376,10 @@ (define hard-links (test-assertm "rpm archive can be installed/uninstalled" store (mlet* %store-monad ((guile (set-guile-for-build (default-guile))) - (profile (profile-derivation (packages->manifest - (list %bootstrap-guile)) - #:hooks '() - #:locales? #f)) + (profile -> (profile + (content (packages->manifest (list %bootstrap-guile))) + (hooks '()) + (locales? #f))) (rpm-pack (rpm-archive "rpm-pack" profile #:compressor %gzip-compressor #:symlinks '(("/bin/guile" -> "bin/guile")) -- cgit v1.2.3 From a516a0ba934c78a9ed317846362dbab8d0d788a8 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 27 Feb 2023 14:39:22 +0100 Subject: gexp: computed-file: Do not honor %guile-for-build. This reverts commit 68775338a510f84e63657ab09242d79e726fa457. Fixes . (%guile-for-build) is a derivation for a specific system, whereas (default-guile) is a system-independent package. It's crucial to preserve this distinction. See discussion at . * guix/gexp.scm (computed-file-compiler): Honor (default-guile), not (%guile-for-build). --- guix/gexp.scm | 6 ++---- 1 file changed, 2 insertions(+), 4 deletions(-) (limited to 'guix') diff --git a/guix/gexp.scm b/guix/gexp.scm index cabf163076..5f92174a2c 100644 --- a/guix/gexp.scm +++ b/guix/gexp.scm @@ -584,8 +584,7 @@ (define-record-type (options computed-file-options)) ;list of arguments (define* (computed-file name gexp - #:key guile - (local-build? #t) (options '())) + #:key guile (local-build? #t) (options '())) "Return an object representing the store item NAME, a file or directory computed by GEXP. When LOCAL-BUILD? is #t (the default), it ensures the corresponding derivation is built locally. OPTIONS may be used to pass @@ -601,8 +600,7 @@ (define-gexp-compiler (computed-file-compiler (file ) ;; gexp. (match file (($ name gexp guile options) - (mlet %store-monad ((guile (lower-object (or guile (%guile-for-build) - (default-guile)) + (mlet %store-monad ((guile (lower-object (or guile (default-guile)) system #:target #f))) (apply gexp->derivation name gexp #:guile-for-build guile #:system system #:target target options))))) -- cgit v1.2.3 From 96739561b87db592716431953cfbbb614e8ff87a Mon Sep 17 00:00:00 2001 From: Simon Tournier Date: Fri, 17 Feb 2023 15:56:27 +0100 Subject: scripts: repl: Extend REPL %load-path with all channels. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Fixes . Reported by 宋文武 . * guix/scripts/repl.scm (define-command): Before starting the REPL, call 'current-profile' to populate (%package-module-path). Signed-off-by: Ludovic Courtès --- guix/scripts/repl.scm | 1 + 1 file changed, 1 insertion(+) (limited to 'guix') diff --git a/guix/scripts/repl.scm b/guix/scripts/repl.scm index 787c63d48e..0b978ae35f 100644 --- a/guix/scripts/repl.scm +++ b/guix/scripts/repl.scm @@ -211,6 +211,7 @@ (define script ((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) -- cgit v1.2.3 From 43c36c5c9f7a31649eb059fd16ed82bde20da3fc Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 24 Feb 2023 11:15:45 +0100 Subject: ui: 'display-hint' quotes extra arguments for Texinfo. Fixes . Previously, common practice was to splice arbitrary strings (user names, file names, etc.) into Texinfo snippets passed to 'display-hint'. This is unsafe in the general case because at signs and braces need to be escaped to produced valid Texinfo. This commit addresses that. * guix/ui.scm (texinfo-quote): New procedure. (display-hint): When ARGUMENTS is non-empty, pass it to 'texinfo-quote' and call 'format'. (report-unbound-variable-error, check-module-matches-file) (display-collision-resolution-hint, run-guix-command): Remove explicit 'format' call; pass 'format' arguments as extra arguments to 'display-hint'. * gnu/services/monitoring.scm (zabbix-front-end-config): Likewise. * guix/scripts.scm (warn-about-disk-space): Likewise. * guix/scripts/build.scm (%standard-cross-build-options) (%standard-native-build-options): Likewise. * guix/scripts/describe.scm (display-checkout-info): Likewise. * guix/scripts/environment.scm (suggest-command-name): Likewise. * guix/scripts/home.scm (process-command): Likewise. * guix/scripts/home/edit.scm (service-type-not-found): Likewise. * guix/scripts/import.scm (guix-import): Likewise. * guix/scripts/package.scm (display-search-path-hint): Likewise. * guix/scripts/pull.scm (build-and-install): Likewise. * guix/scripts/shell.scm (auto-detect-manifest): Likewise. * guix/scripts/system.scm (check-file-system-availability): Likewise. (guix-system): Likewise. * guix/scripts/system/edit.scm (service-type-not-found): Likewise. * guix/status.scm (print-build-event): Likewise. --- gnu/services/monitoring.scm | 6 ++++-- guix/scripts.scm | 4 ++-- guix/scripts/build.scm | 18 ++++++++-------- guix/scripts/describe.scm | 6 +++--- guix/scripts/environment.scm | 4 ++-- guix/scripts/home.scm | 4 ++-- guix/scripts/home/edit.scm | 6 +++--- guix/scripts/import.scm | 5 ++--- guix/scripts/package.scm | 6 +++--- guix/scripts/pull.scm | 6 +++--- guix/scripts/shell.scm | 10 ++++----- guix/scripts/system.scm | 9 ++++---- guix/scripts/system/edit.scm | 6 +++--- guix/status.scm | 10 ++++----- guix/ui.scm | 49 +++++++++++++++++++++++++++++++------------- 15 files changed, 85 insertions(+), 64 deletions(-) (limited to 'guix') diff --git a/gnu/services/monitoring.scm b/gnu/services/monitoring.scm index 44e2e8886c..bbf8b10f8b 100644 --- a/gnu/services/monitoring.scm +++ b/gnu/services/monitoring.scm @@ -662,9 +662,11 @@ (define (zabbix-front-end-config config) (string-append "trim(file_get_contents('" db-secret-file "'));\n")) (begin - (display-hint (format #f (G_ "~a:~a:~a: ~a: + (display-hint (G_ "~a:~a:~a: ~a: Consider using @code{db-secret-file} instead of @code{db-password} for better -security.") file line column 'zabbix-front-end-configuration)) +security.") + file line column + 'zabbix-front-end-configuration) (format #f "'~a';~%" db-password)))) " // Schema name. Used for IBM DB2 and PostgreSQL. diff --git a/guix/scripts.scm b/guix/scripts.scm index 4de8bc23b3..395df864a3 100644 --- a/guix/scripts.scm +++ b/guix/scripts.scm @@ -321,11 +321,11 @@ (define GiB (expt 2 30)) 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/build.scm b/guix/scripts/build.scm index b4437172d7..6a4a32fc0a 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 +;;; Copyright © 2012-2023 Ludovic Courtès ;;; Copyright © 2013 Mark H Weaver ;;; Copyright © 2020 Marius Bakke ;;; Copyright © 2020 Ricardo Wurmus @@ -377,12 +377,12 @@ (define %standard-cross-build-options 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 +404,12 @@ (define %standard-native-build-options 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/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 +;;; Copyright © 2018, 2019, 2020, 2021, 2023 Ludovic Courtès ;;; Copyright © 2018 Oleg Pykhalov ;;; Copyright © 2020 Ekaitz Zarraga ;;; Copyright © 2021 Simon Tournier @@ -154,10 +154,10 @@ (define (display-checkout-info fmt) (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/environment.scm b/guix/scripts/environment.scm index 46435ae48e..44cfcb4f76 100644 --- a/guix/scripts/environment.scm +++ b/guix/scripts/environment.scm @@ -664,8 +664,8 @@ (define not-dot? (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 '())) diff --git a/guix/scripts/home.scm b/guix/scripts/home.scm index d86094bc43..8ff8182a79 100644 --- a/guix/scripts/home.scm +++ b/guix/scripts/home.scm @@ -572,10 +572,10 @@ (define-syntax-rule (with-store* store exp ...) (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 +;;; Copyright © 2022, 2023 Ludovic Courtès ;;; ;;; This file is part of GNU Guix. ;;; @@ -40,8 +40,8 @@ (define (service-type-not-found type) '())) (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..fe1d7a8dda 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 +;;; Copyright © 2012-2014, 2020-2023 Ludovic Courtès ;;; Copyright © 2014 David Thompson ;;; Copyright © 2018 Kyle Meyer ;;; Copyright © 2019, 2022 Ricardo Wurmus @@ -106,6 +106,5 @@ (define-command (guix-import . args) (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/package.scm b/guix/scripts/package.scm index b9090307ac..945e2f2cca 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 +;;; Copyright © 2012-2023 Ludovic Courtès ;;; Copyright © 2013 Nikita Karetnikov ;;; Copyright © 2013, 2015 Mark H Weaver ;;; Copyright © 2014, 2016 Alex Kost @@ -322,7 +322,7 @@ (define (display-search-path-hint entries 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 +331,7 @@ (define (display-search-path-hint entries profile) @end example Alternately, see @command{guix package --search-paths -p ~s}.") - profile profile))))) + profile profile)))) ;;; diff --git a/guix/scripts/pull.scm b/guix/scripts/pull.scm index 7b6c58dbc3..2be8de3b9c 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 +;;; Copyright © 2013-2015, 2017-2023 Ludovic Courtès ;;; Copyright © 2017 Marius Bakke ;;; Copyright © 2020, 2021 Tobias Geerinckx-Rice ;;; @@ -469,9 +469,9 @@ (define guix-command ;; 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/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 +;;; Copyright © 2021-2023 Ludovic Courtès ;;; ;;; This file is part of GNU Guix. ;;; @@ -305,16 +305,16 @@ (define disallow-implicit-load? (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/system.scm b/guix/scripts/system.scm index 6fd915cb5e..c0bc295c00 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 +;;; Copyright © 2014-2023 Ludovic Courtès ;;; Copyright © 2016 Alex Kost ;;; Copyright © 2016, 2017, 2018 Chris Marusich ;;; Copyright © 2017, 2019 Mathieu Othacehe @@ -633,9 +633,9 @@ (define (file-system-location* fs) (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 +1417,7 @@ (define (parse-sub-command arg result) (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 +;;; Copyright © 2022, 2023 Ludovic Courtès ;;; ;;; This file is part of GNU Guix. ;;; @@ -39,8 +39,8 @@ (define (service-type-not-found type) '())) (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/status.scm b/guix/status.scm index 5580c80ea9..a192cd789a 100644 --- a/guix/status.scm +++ b/guix/status.scm @@ -533,15 +533,15 @@ (define erase-current-line* (when (and (pair? properties) (eq? (assq-ref properties 'type) 'profile-hook) (eq? (assq-ref properties 'hook) 'package-cache)) - (display-hint (format #f (G_ "This usually indicates a bug in one of + (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)))))))) + (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/ui.scm b/guix/ui.scm index 9f81ff3b8e..b6c3bd04ba 100644 --- a/guix/ui.scm +++ b/guix/ui.scm @@ -296,9 +296,22 @@ (define (modulestring + (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 @@ (define colorize (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 + (() 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 @@ (define* (report-unbound-variable-error args #:key frame) (#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 @@ (define (check-module-matches-file module file) ;; 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 @@ (define (top-most-entry entry) (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 @@ (define module (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) -- cgit v1.2.3