diff options
Diffstat (limited to 'guix')
48 files changed, 396 insertions, 95 deletions
diff --git a/guix/build-system/android-ndk.scm b/guix/build-system/android-ndk.scm index 047f884b19..aa7cc06279 100644 --- a/guix/build-system/android-ndk.scm +++ b/guix/build-system/android-ndk.scm @@ -31,7 +31,6 @@ (define %android-ndk-build-system-modules ;; Build-side modules imported by default. `((guix build android-ndk-build-system) - (guix build syscalls) ,@%gnu-build-system-modules)) (define* (android-ndk-build name inputs diff --git a/guix/build-system/ant.scm b/guix/build-system/ant.scm index cfb033f6a5..e191fd3c99 100644 --- a/guix/build-system/ant.scm +++ b/guix/build-system/ant.scm @@ -43,7 +43,6 @@ (guix build maven plugin) (guix build maven pom) (guix build java-utils) - (guix build syscalls) ,@%gnu-build-system-modules)) (define (default-jdk) diff --git a/guix/build-system/dub.scm b/guix/build-system/dub.scm index b4011cdb83..951c084398 100644 --- a/guix/build-system/dub.scm +++ b/guix/build-system/dub.scm @@ -59,7 +59,6 @@ (define %dub-build-system-modules ;; Build-side modules imported by default. `((guix build dub-build-system) - (guix build syscalls) ,@%gnu-build-system-modules)) (define* (dub-build name inputs diff --git a/guix/build-system/zig.scm b/guix/build-system/zig.scm new file mode 100644 index 0000000000..16b8a712cc --- /dev/null +++ b/guix/build-system/zig.scm @@ -0,0 +1,124 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2023 Ekaitz Zarraga <ekaitz@elenq.tech> +;;; +;;; This file is part of GNU Guix. +;;; +;;; GNU Guix is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; GNU Guix is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. + +(define-module (guix build-system zig) + #:use-module (guix search-paths) + #:use-module (guix store) + #:use-module (guix utils) + #:use-module (guix gexp) + #:use-module (guix monads) + #:use-module (guix packages) + #:use-module (guix build-system) + #:use-module (guix build-system gnu) + #:use-module (ice-9 match) + #:use-module (srfi srfi-26) + #:export (zig-build-system)) + + +(define (default-zig) + "Return the default zig package." + ;; Lazily resolve the binding to avoid a circular dependency. + (let ((zig (resolve-interface '(gnu packages zig)))) + (module-ref zig 'zig))) + +(define %zig-build-system-modules + ;; Build-side modules imported by default. + `((guix build zig-build-system) + (guix build syscalls) + ,@%gnu-build-system-modules)) + +(define* (zig-build name inputs + #:key + source + (tests? #t) + (test-target #f) + (zig-build-flags ''()) + (zig-test-flags ''()) + (zig-release-type #f) + (phases '%standard-phases) + (outputs '("out")) + (search-paths '()) + (system (%current-system)) + (guile #f) + (imported-modules %zig-build-system-modules) + (modules '((guix build zig-build-system) + (guix build utils)))) + "Build SOURCE using Zig, and with INPUTS." + (define builder + (with-imported-modules imported-modules + #~(begin + (use-modules #$@(sexp->gexp modules)) + (zig-build #:name #$name + #:source #+source + #:system #$system + #:test-target #$test-target + #:zig-build-flags #$zig-build-flags + #:zig-test-flags #$zig-test-flags + #:zig-release-type #$zig-release-type + #:tests? #$tests? + #:phases #$phases + #: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* (lower name + #:key source inputs native-inputs outputs system target + (zig (default-zig)) + #:allow-other-keys + #:rest arguments) + "Return a bag for NAME." + + (define private-keywords + '(#:target #:zig #:inputs #:native-inputs #:outputs)) + + ;; TODO: support cross-compilation + ;; It's as simple as adding some build flags to `zig-build-flags` + ;; -Dtarget=aarch64-linux-musl, for example. + (and (not target) + (bag + (name name) + (system system) + (target target) + (host-inputs `(,@(if source + `(("source" ,source)) + '()) + ,@inputs + + ;; Keep the standard inputs of 'gnu-build-system' + ;; TODO: do we need this? + ,@(standard-packages))) + (build-inputs `(("zig" ,zig) + ,@native-inputs)) + (outputs outputs) + (build zig-build) + (arguments (strip-keyword-arguments private-keywords arguments))))) + +(define zig-build-system + (build-system + (name 'zig) + (description + "Zig build system, to build Zig packages") + (lower lower))) diff --git a/guix/build/cargo-build-system.scm b/guix/build/cargo-build-system.scm index fbba554e9b..505c0b4b01 100644 --- a/guix/build/cargo-build-system.scm +++ b/guix/build/cargo-build-system.scm @@ -111,6 +111,13 @@ Cargo.toml file present at its root." (define (rust-package? name) (string-prefix? "rust-" name)) +(define* (check-for-pregenerated-files #:rest _) + "Check the source code for files which are known to generally be bundled +libraries or executables." + (let ((pregenerated-files (find-files "." "\\.(a|dll|dylib|exe|lib)$"))) + (when (not (null-list? pregenerated-files)) + (error "Possible pre-generated files found:" pregenerated-files)))) + (define* (configure #:key inputs (vendor-dir "guix-vendor") #:allow-other-keys) @@ -224,10 +231,10 @@ directory = '" port) (for-each (lambda (file) (make-file-writable file) - ;; Strip the hash and replace '.tar.gz' with '.crate'. + ;; Strip the hash and rust prefix and replace '.tar.gz' with '.crate'. (rename-file file (string-append (string-drop-right - (string-drop file 35) + (string-drop file 40) (string-length ".tar.gz")) ".crate"))) (find-files "." "\\.tar\\.gz$")))) @@ -235,7 +242,32 @@ directory = '" port) ;;error: invalid inclusion of reserved file name Cargo.toml.orig in package source (when (file-exists? "Cargo.toml.orig") (delete-file "Cargo.toml.orig")) - (apply invoke `("cargo" "package" ,@cargo-package-flags)))) + (apply invoke `("cargo" "package" ,@cargo-package-flags)) + + ;; Then unpack the crate, reset the timestamp of all contained files, and + ;; repack them. This is necessary to ensure that they are reproducible. + (with-directory-excursion "target/package" + (for-each + (lambda (crate) + (invoke "tar" "xf" crate) + (delete-file crate) + ;; Some of the crate names have underscores, so we need to + ;; search the current directory to find the unpacked crate. + (let ((dir + (car (scandir "." + (lambda (file) + (and (not (member file '("." ".."))) + (not (string-suffix? ".crate" file)))))))) + ;; XXX: copied from (gnu build install) + (for-each (lambda (file) + (let ((s (lstat file))) + (unless (eq? (stat:type s) 'symlink) + (utime file 0 0 0 0)))) + (find-files dir #:directories? #t)) + (apply invoke "tar" "czf" (string-append dir ".crate") + (find-files dir #:directories? #t)) + (delete-file-recursively dir))) + (find-files "." "\\.crate$"))))) (format #t "Not installing cargo sources, skipping `cargo package`.~%")) #t) @@ -285,7 +317,8 @@ directory = '" port) (replace 'check check) (replace 'install install) (add-after 'build 'package package) - (add-after 'unpack 'unpack-rust-crates unpack-rust-crates) + (add-after 'unpack 'check-for-pregenerated-files check-for-pregenerated-files) + (add-after 'check-for-pregenerated-files 'unpack-rust-crates unpack-rust-crates) (add-after 'patch-generated-file-shebangs 'patch-cargo-checksums patch-cargo-checksums))) (define* (cargo-build #:key inputs (phases %standard-phases) diff --git a/guix/build/syscalls.scm b/guix/build/syscalls.scm index d947b010d3..b845b8aab9 100644 --- a/guix/build/syscalls.scm +++ b/guix/build/syscalls.scm @@ -836,7 +836,8 @@ fdatasync(2) on the underlying file descriptor." (define-syntax fsword ;fsword_t (identifier-syntax long)) -(define linux? (string-contains %host-type "linux-gnu")) +(define musl-libc? (string-contains %host-type "linux-musl")) +(define linux? (string-contains %host-type "linux-")) (define-syntax define-statfs-flags (syntax-rules (linux hurd) @@ -905,7 +906,7 @@ fdatasync(2) on the underlying file descriptor." (spare (array fsword 4))) (define statfs - (let ((proc (syscall->procedure int "statfs64" '(* *)))) + (let ((proc (syscall->procedure int (if musl-libc? "statfs" "statfs64") '(* *)))) (lambda (file) "Return a <file-system> data structure describing the file system mounted at FILE." @@ -1232,7 +1233,7 @@ system to PUT-OLD." (define (readdir-procedure name-field-offset sizeof-dirent-header read-dirent-header) - (let ((proc (syscall->procedure '* "readdir64" '(*)))) + (let ((proc (syscall->procedure '* (if musl-libc? "readdir" "readdir64") '(*)))) (lambda* (directory #:optional (pointer->string pointer->string/utf-8)) (let ((ptr (proc directory))) (and (not (null-pointer? ptr)) @@ -1244,7 +1245,7 @@ system to PUT-OLD." (define readdir* ;; Decide at run time which one must be used. - (if (string-contains %host-type "linux-gnu") + (if linux? (readdir-procedure (c-struct-field-offset %struct-dirent-header/linux name) sizeof-dirent-header/linux @@ -1664,7 +1665,7 @@ bytevector BV at INDEX." (error "unsupported socket address" sockaddr))))) (define write-socket-address! - (if (string-contains %host-type "linux-gnu") + (if linux? write-socket-address!/linux write-socket-address!/hurd)) @@ -1696,7 +1697,7 @@ bytevector BV at INDEX." (vector family))))) (define read-socket-address - (if (string-contains %host-type "linux-gnu") + (if linux? read-socket-address/linux read-socket-address/hurd)) diff --git a/guix/build/zig-build-system.scm b/guix/build/zig-build-system.scm new file mode 100644 index 0000000000..d414ebfb17 --- /dev/null +++ b/guix/build/zig-build-system.scm @@ -0,0 +1,100 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2023 Ekaitz Zarraga <ekaitz@elenq.tech> +;;; +;;; This file is part of GNU Guix. +;;; +;;; GNU Guix is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; GNU Guix is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. + +(define-module (guix build zig-build-system) + #:use-module ((guix build gnu-build-system) #:prefix gnu:) + #:use-module (guix build utils) + #:use-module (ice-9 popen) + #:use-module (ice-9 rdelim) + #:use-module (ice-9 ftw) + #:use-module (ice-9 format) + #:use-module (ice-9 match) + #:use-module (rnrs io ports) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-26) + #:export (%standard-phases + zig-build)) + +;; Interesting guide here: +;; https://github.com/riverwm/river/blob/master/PACKAGING.md +(define global-cache-dir "zig-cache") + +(define* (set-cc #:rest args) + ;; TODO: Zig needs the gcc-toolchain in order to find the libc. + ;; we need to think about how to solve this in the build system + ;; directly: --libc + (setenv "CC" "gcc")) + +(define* (set-zig-global-cache-dir #:rest args) + (setenv "ZIG_GLOBAL_CACHE_DIR" global-cache-dir)) + +(define* (build #:key + zig-build-flags + zig-release-type ;; "safe", "fast" or "small" empty for a + ;; debug build" + #:allow-other-keys) + "Build a given Zig package." + + (setenv "DESTDIR" "out") + (let ((call `("zig" "build" + "--prefix" "" ;; Don't add /usr + "--prefix-lib-dir" "lib" + "--prefix-exe-dir" "bin" + "--prefix-include-dir" "include" + ,@(if zig-release-type + (list (string-append "-Drelease-" zig-release-type)) + '()) + ,@zig-build-flags))) + (format #t "running: ~s~%" call) + (apply invoke call))) + +(define* (check #:key tests? + zig-test-flags + #:allow-other-keys) + "Run all the tests" + (when tests? + (let ((old-destdir (getenv "DESTDIR"))) + (setenv "DESTDIR" "test-out") ;; Avoid colisions with the build output + (let ((call `("zig" "build" "test" + ,@zig-test-flags))) + (format #t "running: ~s~%" call) + (apply invoke call)) + (if old-destdir + (setenv "DESTDIR" old-destdir) + (unsetenv "DESTDIR"))))) + +(define* (install #:key inputs outputs #:allow-other-keys) + "Install a given Zig package." + (let ((out (assoc-ref outputs "out"))) + (copy-recursively "out" out))) + +(define %standard-phases + (modify-phases gnu:%standard-phases + (delete 'bootstrap) + (delete 'configure) + (add-before 'build 'set-zig-global-cache-dir set-zig-global-cache-dir) + (add-before 'build 'set-cc set-cc) + (replace 'build build) + (replace 'check check) + (replace 'install install))) + + +(define* (zig-build #:key inputs (phases %standard-phases) + #:allow-other-keys #:rest args) + "Build the given Zig package, applying all of PHASES in order." + (apply gnu:gnu-build #:inputs inputs #:phases phases args)) diff --git a/guix/import/crate.scm b/guix/import/crate.scm index 6e10ebb5d4..43823d006e 100644 --- a/guix/import/crate.scm +++ b/guix/import/crate.scm @@ -5,6 +5,7 @@ ;;; Copyright © 2021 Nicolas Goaziou <mail@nicolasgoaziou.fr> ;;; Copyright © 2022 Hartmut Goebel <h.goebel@crazy-compilers.com> ;;; Copyright © 2023 Simon Tournier <zimon.toutoune@gmail.com> +;;; Copyright © 2023 Efraim Flashner <efraim@flashner.co.il> ;;; ;;; This file is part of GNU Guix. ;;; @@ -82,6 +83,7 @@ (match-lambda ('null #f) ((? string? str) str))) + (yanked? crate-version-yanked? "yanked") ;boolean (links crate-version-links)) ;alist ;; Crate dependency. Each dependency (each edge in the graph) is annotated as @@ -255,13 +257,16 @@ look up the development dependencs for the given crate." (and (not (null-list? versions)) (semver->string (last versions))))) - ;; find the highest version of a crate that fulfills the semver <range> + ;; Find the highest version of a crate that fulfills the semver <range> + ;; and hasn't been yanked. (define (find-crate-version crate range) (let* ((semver-range (string->semver-range range)) (versions (sort (filter (lambda (entry) - (semver-range-contains? semver-range (first entry))) + (and + (not (crate-version-yanked? (second entry))) + (semver-range-contains? semver-range (first entry)))) (map (lambda (ver) (list (string->semver (crate-version-number ver)) ver)) diff --git a/guix/import/opam.scm b/guix/import/opam.scm index e67146e593..86e82cde59 100644 --- a/guix/import/opam.scm +++ b/guix/import/opam.scm @@ -379,8 +379,10 @@ file names. Return a 'package' sexp or #f on failure." (synopsis ,(metadata-ref opam-content "synopsis")) (description ,(and=> (metadata-ref opam-content "description") beautify-description)) - (license ,(spdx-string->license - (metadata-ref opam-content "license")))) + (license ,(match (metadata-ref opam-content "license") + ((('string-pat strs) ...) + `(list ,@(map spdx-string->license strs))) + ((? string? str) (spdx-string->license str))))) (filter (lambda (name) (not (member name '("dune" "jbuilder")))) diff --git a/guix/scripts/archive.scm b/guix/scripts/archive.scm index e32f22ec99..2b5a55a23f 100644 --- a/guix/scripts/archive.scm +++ b/guix/scripts/archive.scm @@ -119,7 +119,7 @@ Export/import one or more packages from/to the store.\n")) ;; Specifications of the command-line options. (cons* (option '(#\h "help") #f #f (lambda args - (show-help) + (leave-on-EPIPE (show-help)) (exit 0))) (option '(#\V "version") #f #f (lambda args diff --git a/guix/scripts/build.scm b/guix/scripts/build.scm index 72a24f91ac..05f022a92e 100644 --- a/guix/scripts/build.scm +++ b/guix/scripts/build.scm @@ -477,7 +477,7 @@ Build the given PACKAGE-OR-DERIVATION and return their output paths.\n")) ;; Specifications of the command-line options. (cons* (option '(#\h "help") #f #f (lambda args - (show-help) + (leave-on-EPIPE (show-help)) (exit 0))) (option '(#\V "version") #f #f (lambda args diff --git a/guix/scripts/challenge.scm b/guix/scripts/challenge.scm index 4821e11bf6..01e2f9a2b2 100644 --- a/guix/scripts/challenge.scm +++ b/guix/scripts/challenge.scm @@ -467,7 +467,7 @@ Challenge the substitutes for PACKAGE... provided by one or more servers.\n")) (define %options (list (option '(#\h "help") #f #f (lambda args - (show-help) + (leave-on-EPIPE (show-help)) (exit 0))) (option '(#\V "version") #f #f (lambda args diff --git a/guix/scripts/container.scm b/guix/scripts/container.scm index 2369437043..70637bca29 100644 --- a/guix/scripts/container.scm +++ b/guix/scripts/container.scm @@ -57,7 +57,7 @@ Build and manipulate Linux containers.\n")) (format (current-error-port) (G_ "guix container: missing action~%"))) ((or ("-h") ("--help")) - (show-help) + (leave-on-EPIPE (show-help)) (exit 0)) ((or ("-V") ("--version")) (show-version-and-exit "guix container")) diff --git a/guix/scripts/copy.scm b/guix/scripts/copy.scm index 07357af420..67975ac1a9 100644 --- a/guix/scripts/copy.scm +++ b/guix/scripts/copy.scm @@ -150,7 +150,7 @@ Copy ITEMS to or from the specified host over SSH.\n")) (option '(#\h "help") #f #f (lambda args - (show-help) + (leave-on-EPIPE (show-help)) (exit 0))) (option '(#\V "version") #f #f (lambda args diff --git a/guix/scripts/deploy.scm b/guix/scripts/deploy.scm index 14ce736174..4b1a603049 100644 --- a/guix/scripts/deploy.scm +++ b/guix/scripts/deploy.scm @@ -68,7 +68,7 @@ Perform the deployment specified by FILE.\n")) (define %options (cons* (option '(#\h "help") #f #f (lambda args - (show-help) + (leave-on-EPIPE (show-help)) (exit 0))) (option '(#\V "version") #f #f (lambda args diff --git a/guix/scripts/describe.scm b/guix/scripts/describe.scm index 5523aa0ec2..6d451dc902 100644 --- a/guix/scripts/describe.scm +++ b/guix/scripts/describe.scm @@ -74,7 +74,7 @@ result))) (option '(#\h "help") #f #f (lambda args - (show-help) + (leave-on-EPIPE (show-help)) (exit 0))) (option '(#\V "version") #f #f (lambda args diff --git a/guix/scripts/discover.scm b/guix/scripts/discover.scm index 8970f835c9..32bf6085a5 100644 --- a/guix/scripts/discover.scm +++ b/guix/scripts/discover.scm @@ -50,7 +50,7 @@ Discover Guix related services using Avahi.\n")) (alist-cons 'cache arg result))) (option '(#\h "help") #f #f (lambda _ - (show-help) + (leave-on-EPIPE (show-help)) (exit 0))) (option '(#\V "version") #f #f (lambda _ diff --git a/guix/scripts/download.scm b/guix/scripts/download.scm index 0ab5c8c39c..0441d3fead 100644 --- a/guix/scripts/download.scm +++ b/guix/scripts/download.scm @@ -143,7 +143,7 @@ and 'base16' ('hex' and 'hexadecimal' can be used as well).\n")) (option '(#\h "help") #f #f (lambda args - (show-help) + (leave-on-EPIPE (show-help)) (exit 0))) (option '(#\V "version") #f #f (lambda args diff --git a/guix/scripts/edit.scm b/guix/scripts/edit.scm index 5ce2870c5a..ff2d529bcf 100644 --- a/guix/scripts/edit.scm +++ b/guix/scripts/edit.scm @@ -37,7 +37,7 @@ %standard-build-options) (option '(#\h "help") #f #f (lambda args - (show-help) + (leave-on-EPIPE (show-help)) (exit 0))) (option '(#\V "version") #f #f (lambda args diff --git a/guix/scripts/gc.scm b/guix/scripts/gc.scm index 6068f5fe3f..58af827617 100644 --- a/guix/scripts/gc.scm +++ b/guix/scripts/gc.scm @@ -132,7 +132,7 @@ current one." ;; Specification of the command-line options. (list (option '(#\h "help") #f #f (lambda args - (show-help) + (leave-on-EPIPE (show-help)) (exit 0))) (option '(#\V "version") #f #f (lambda args diff --git a/guix/scripts/git.scm b/guix/scripts/git.scm index 4436d8a6e0..abbad076cd 100644 --- a/guix/scripts/git.scm +++ b/guix/scripts/git.scm @@ -56,7 +56,7 @@ Operate on Git repositories.\n")) (format (current-error-port) (G_ "guix git: missing sub-command~%"))) ((or ("-h") ("--help")) - (show-help) + (leave-on-EPIPE (show-help)) (exit 0)) ((or ("-V") ("--version")) (show-version-and-exit "guix git")) diff --git a/guix/scripts/graph.scm b/guix/scripts/graph.scm index c075e0ec29..6740858d8b 100644 --- a/guix/scripts/graph.scm +++ b/guix/scripts/graph.scm @@ -510,7 +510,7 @@ package modules, while attempting to retain user package modules." %standard-build-options) (option '(#\h "help") #f #f (lambda args - (show-help) + (leave-on-EPIPE (show-help)) (exit 0))) (option '(#\V "version") #f #f (lambda args diff --git a/guix/scripts/hash.scm b/guix/scripts/hash.scm index 6dc67a2416..7197d3965c 100644 --- a/guix/scripts/hash.scm +++ b/guix/scripts/hash.scm @@ -153,7 +153,7 @@ use '--serializer=nar' instead~%"))) (alist-delete 'serializer result)))) (option '(#\h "help") #f #f (lambda args - (show-help) + (leave-on-EPIPE (show-help)) (exit 0))) (option '(#\V "version") #f #f (lambda args diff --git a/guix/scripts/home.scm b/guix/scripts/home.scm index e0800bc062..b4c82d275f 100644 --- a/guix/scripts/home.scm +++ b/guix/scripts/home.scm @@ -164,7 +164,7 @@ Some ACTIONS support additional ARGS.\n")) ;; Specification of the command-line options. (cons* (option '(#\h "help") #f #f (lambda args - (show-help) + (leave-on-EPIPE (show-help)) (exit 0))) (option '(#\n "dry-run") #f #f (lambda (opt name arg result) diff --git a/guix/scripts/import.scm b/guix/scripts/import.scm index 4ddd8d46a1..1e8ffd25ec 100644 --- a/guix/scripts/import.scm +++ b/guix/scripts/import.scm @@ -78,7 +78,7 @@ Run IMPORTER with ARGS.\n")) (format (current-error-port) (G_ "guix import: missing importer name~%"))) ((or ("-h") ("--help")) - (show-help) + (leave-on-EPIPE (show-help)) (exit 0)) ((or ("-V") ("--version")) (show-version-and-exit "guix import")) diff --git a/guix/scripts/install.scm b/guix/scripts/install.scm index 63e625f266..504dbc9a6f 100644 --- a/guix/scripts/install.scm +++ b/guix/scripts/install.scm @@ -52,7 +52,7 @@ This is an alias for 'guix package -i'.\n")) ;; Specification of the command-line options. (cons* (option '(#\h "help") #f #f (lambda args - (show-help) + (leave-on-EPIPE (show-help)) (exit 0))) (option '(#\V "version") #f #f (lambda args diff --git a/guix/scripts/lint.scm b/guix/scripts/lint.scm index 9920c3ee62..ee3de51fb1 100644 --- a/guix/scripts/lint.scm +++ b/guix/scripts/lint.scm @@ -159,7 +159,7 @@ run the checkers on all packages.\n")) %standard-build-options) (option '(#\h "help") #f #f (lambda args - (show-help) + (leave-on-EPIPE (show-help)) (exit 0))) (option '(#\l "list-checkers") #f #f (lambda (opt name arg result) diff --git a/guix/scripts/locate.scm b/guix/scripts/locate.scm index 79af533fd9..ae64f46896 100644 --- a/guix/scripts/locate.scm +++ b/guix/scripts/locate.scm @@ -196,10 +196,15 @@ SELECT version FROM SchemaVersion ORDER BY version DESC LIMIT 1;" ;; System-wide database file name. (string-append %localstatedir "/cache/guix/locate/db.sqlite")) -(define (suitable-database create?) +(define (file-age stat) + "Return the age of the file denoted by STAT in seconds." + (- (current-time) (stat:mtime stat))) + +(define (suitable-database create? age-update-threshold) "Return a suitable database file. When CREATE? is true, the returned database will be opened for writing; otherwise, return the most recent one, -user or system." +user or system. Do not return the system database if it is older than +AGE-UPDATE-THRESHOLD seconds." (if (zero? (getuid)) system-database-file (if create? @@ -207,10 +212,13 @@ user or system." (let ((system (stat system-database-file #f)) (user (stat user-database-file #f))) (if user - (if (and system (> (stat:mtime system) (stat:mtime user))) + (if (and system + (> (stat:mtime system) (stat:mtime user)) + (< (file-age system) age-update-threshold)) system-database-file user-database-file) - (if system + (if (and system + (< (file-age system) age-update-threshold)) system-database-file user-database-file)))))) @@ -543,7 +551,7 @@ Locate FILE and return the list of packages that contain it.\n")) (define %options (list (option '(#\h "help") #f #f - (lambda args (show-help) (exit 0))) + (lambda args (leave-on-EPIPE (show-help)) (exit 0))) (option '(#\V "version") #f #f (lambda (opt name arg result) (show-version-and-exit "guix locate"))) @@ -595,10 +603,6 @@ Locate FILE and return the list of packages that contain it.\n")) ;; database. (* 9 30 (* 24 60 60))) - (define (file-age stat) - ;; Return true if TIME denotes an "old" time. - (- (current-time) (stat:mtime stat))) - (with-error-handling (let* ((opts (parse-command-line args %options (list %default-options) @@ -610,7 +614,7 @@ Locate FILE and return the list of packages that contain it.\n")) (clear? (assoc-ref opts 'clear?)) (update? (assoc-ref opts 'update?)) (glob? (assoc-ref opts 'glob?)) - (database ((assoc-ref opts 'database) update?)) + (database ((assoc-ref opts 'database) update? age-update-threshold)) (method (assoc-ref opts 'method)) (files (reverse (filter-map (match-lambda (('argument . arg) arg) diff --git a/guix/scripts/offload.scm b/guix/scripts/offload.scm index 7b76126d35..137e3b5fe3 100644 --- a/guix/scripts/offload.scm +++ b/guix/scripts/offload.scm @@ -868,11 +868,12 @@ machine." (("--version") (show-version-and-exit "guix offload")) (("--help") - (format #t (G_ "Usage: guix offload SYSTEM MAX-SILENT-TIME \ + (leave-on-EPIPE + (format #t (G_ "Usage: guix offload SYSTEM MAX-SILENT-TIME \ PRINT-BUILD-TRACE? BUILD-TIMEOUT Process build offload requests written on the standard input, possibly offloading builds to the machines listed in '~a'.~%") - %machine-file) + %machine-file)) (display (G_ " This tool is meant to be used internally by 'guix-daemon'.\n")) (show-bug-report-information)) diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm index 01995c48b7..bdbea49910 100644 --- a/guix/scripts/pack.scm +++ b/guix/scripts/pack.scm @@ -507,7 +507,7 @@ added to the pack." image is a tarball conforming to the Docker Image Specification, compressed with COMPRESSOR. It can be passed to 'docker load'. If TARGET is true, it must a be a GNU triplet and it is used to derive the architecture metadata in -the image." +the image. EXTRA-OPTIONS may contain the IMAGE-TAG keyword argument." (define database (and localstatedir? (file-append (store-database (list profile)) @@ -531,7 +531,7 @@ the image." (guix build utils) (guix profiles) (guix search-paths) (srfi srfi-1) (srfi srfi-19) - (ice-9 match)) + (ice-9 match) (ice-9 optargs)) #$(procedure-source manifest->friendly-name) @@ -560,23 +560,30 @@ the image." (setenv "PATH" #+(file-append archiver "/bin")) - (build-docker-image #$output - (map store-info-item - (call-with-input-file "profile" - read-reference-graph)) - #$profile - #:repository (manifest->friendly-name - (profile-manifest #$profile)) - #:database #+database - #:system (or #$target %host-type) - #:environment environment - #:entry-point - #$(and entry-point - #~(list (string-append #$profile "/" - #$entry-point))) - #:extra-files directives - #:compressor #+(compressor-command compressor) - #:creation-time (make-time time-utc 0 1)))))) + (let-keywords '#$extra-options #f + ((image-tag #f)) + (build-docker-image #$output + (map store-info-item + (call-with-input-file "profile" + read-reference-graph)) + #$profile + #:repository + (or image-tag + (manifest->friendly-name + (profile-manifest #$profile))) + #:database #+database + #:system (or #$target %host-type) + #:environment environment + #:entry-point + #$(and entry-point + #~(list + (string-append #$profile "/" + #$entry-point))) + #:extra-files directives + #:compressor + #+(compressor-command compressor) + #:creation-time + (make-time time-utc 0 1))))))) (gexp->derivation (string-append name ".tar" (compressor-extension compressor)) @@ -1287,6 +1294,20 @@ last resort for relocation." (alist-cons symbol arg result) rest)))) +(define %docker-format-options + (list (required-option 'image-tag))) + +(define (show-docker-format-options) + (display (G_ " + --help-docker-format list options specific to the docker format"))) + +(define (show-docker-format-options/detailed) + (display (G_ " + --image-tag=NAME + Use the given NAME for the Docker image repository")) + (newline) + (exit 0)) + (define %deb-format-options (list (required-option 'control-file) (required-option 'postinst-file) @@ -1339,7 +1360,7 @@ last resort for relocation." ;; Specifications of the command-line options. (cons* (option '(#\h "help") #f #f (lambda args - (show-help) + (leave-on-EPIPE (show-help)) (exit 0))) (option '(#\V "version") #f #f (lambda args @@ -1407,6 +1428,10 @@ last resort for relocation." (lambda (opt name arg result) (alist-cons 'bootstrap? #t result))) + (option '("help-docker-format") #f #f + (lambda args + (show-docker-format-options/detailed))) + (option '("help-deb-format") #f #f (lambda args (show-deb-format-options/detailed))) @@ -1415,7 +1440,8 @@ last resort for relocation." (lambda args (show-rpm-format-options/detailed))) - (append %deb-format-options + (append %docker-format-options + %deb-format-options %rpm-format-options %transformation-options %standard-build-options @@ -1433,6 +1459,7 @@ Create a bundle of PACKAGE.\n")) (newline) (show-transformation-options-help) (newline) + (show-docker-format-options) (show-deb-format-options) (show-rpm-format-options) (newline) @@ -1586,6 +1613,9 @@ Create a bundle of PACKAGE.\n")) manifest))) (pack-format (assoc-ref opts 'format)) (extra-options (match pack-format + ('docker + (list #:image-tag + (assoc-ref opts 'image-tag))) ('deb (list #:control-file (process-file-arg opts 'control-file) diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm index ab1968b62d..a489e06e73 100644 --- a/guix/scripts/package.scm +++ b/guix/scripts/package.scm @@ -504,7 +504,7 @@ Install, remove, or upgrade packages in a single transaction.\n")) ;; Specification of the command-line options. (cons* (option '(#\h "help") #f #f (lambda args - (show-help) + (leave-on-EPIPE (show-help)) (exit 0))) (option '(#\V "version") #f #f (lambda args diff --git a/guix/scripts/processes.scm b/guix/scripts/processes.scm index 3db5603286..4a855c8c7c 100644 --- a/guix/scripts/processes.scm +++ b/guix/scripts/processes.scm @@ -313,7 +313,7 @@ List the current Guix sessions and their processes.")) (define %options (list (option '(#\h "help") #f #f (lambda args - (show-help) + (leave-on-EPIPE (show-help)) (exit 0))) (option '(#\V "version") #f #f (lambda args diff --git a/guix/scripts/publish.scm b/guix/scripts/publish.scm index ada81838ac..4457be1fce 100644 --- a/guix/scripts/publish.scm +++ b/guix/scripts/publish.scm @@ -160,7 +160,7 @@ usage." (define %options (list (option '(#\h "help") #f #f (lambda _ - (show-help) + (leave-on-EPIPE (show-help)) (exit 0))) (option '(#\V "version") #f #f (lambda _ diff --git a/guix/scripts/pull.scm b/guix/scripts/pull.scm index 1904a6913a..58d3cd7e83 100644 --- a/guix/scripts/pull.scm +++ b/guix/scripts/pull.scm @@ -201,7 +201,7 @@ Download and deploy the latest version of Guix.\n")) (option '(#\h "help") #f #f (lambda args - (show-help) + (leave-on-EPIPE (show-help)) (exit 0))) (option '(#\V "version") #f #f (lambda args diff --git a/guix/scripts/refresh.scm b/guix/scripts/refresh.scm index 46bf310d5f..d858ed07cb 100644 --- a/guix/scripts/refresh.scm +++ b/guix/scripts/refresh.scm @@ -144,7 +144,7 @@ (option '(#\h "help") #f #f (lambda args - (show-help) + (leave-on-EPIPE (show-help)) (exit 0))) (option '(#\V "version") #f #f (lambda args diff --git a/guix/scripts/remove.scm b/guix/scripts/remove.scm index a46ad04d56..be073878c5 100644 --- a/guix/scripts/remove.scm +++ b/guix/scripts/remove.scm @@ -49,7 +49,7 @@ This is an alias for 'guix package -r'.\n")) ;; Specification of the command-line options. (cons* (option '(#\h "help") #f #f (lambda args - (show-help) + (leave-on-EPIPE (show-help)) (exit 0))) (option '(#\V "version") #f #f (lambda args diff --git a/guix/scripts/repl.scm b/guix/scripts/repl.scm index fd23a2b982..cb71e59b05 100644 --- a/guix/scripts/repl.scm +++ b/guix/scripts/repl.scm @@ -42,7 +42,7 @@ (define %options (list (option '(#\h "help") #f #f (lambda args - (show-help) + (leave-on-EPIPE (show-help)) (exit 0))) (option '(#\V "version") #f #f (lambda args diff --git a/guix/scripts/search.scm b/guix/scripts/search.scm index 307ea410b9..e6deb710b1 100644 --- a/guix/scripts/search.scm +++ b/guix/scripts/search.scm @@ -47,7 +47,7 @@ This is an alias for 'guix package -s'.\n")) ;; Specification of the command-line options. (list (option '(#\h "help") #f #f (lambda args - (show-help) + (leave-on-EPIPE (show-help)) (exit 0))) (option '(#\V "version") #f #f (lambda args diff --git a/guix/scripts/shell.scm b/guix/scripts/shell.scm index 83888eee1d..10ea110fee 100644 --- a/guix/scripts/shell.scm +++ b/guix/scripts/shell.scm @@ -26,6 +26,7 @@ #:autoload (guix transformations) (options->transformation transformation-option-key? show-transformation-options-help) + #:autoload (guix grafts) (%graft?) #:use-module (guix scripts) #:use-module (guix packages) #:use-module (guix profiles) @@ -115,7 +116,7 @@ interactive shell in that environment.\n")) (append (list (option '(#\h "help") #f #f (lambda args - (show-help) + (leave-on-EPIPE (show-help)) (exit 0))) (option '(#\V "version") #f #f (lambda args @@ -354,6 +355,7 @@ performed--e.g., because the package cache is not authoritative." ;; be insufficient: <https://lwn.net/Articles/866582/>. (sha256 (string->utf8 (string-append primary-key ":" system ":" + (if (%graft?) "" "ungrafted:") (number->string (stat:dev stat)) ":" (number->string (stat:ino stat)))))))))) @@ -366,6 +368,7 @@ is a list of package specs. Return #f if caching is not possible." (bytevector->base32-string (sha256 (string->utf8 (string-append primary-key ":" system ":" + (if (%graft?) "" "ungrafted:") (object->string specs)))))))) (define (profile-cached-gc-root opts) diff --git a/guix/scripts/show.scm b/guix/scripts/show.scm index f6d8256951..14b72cb75a 100644 --- a/guix/scripts/show.scm +++ b/guix/scripts/show.scm @@ -46,7 +46,7 @@ This is an alias for 'guix package --show='.\n")) ;; Specification of the command-line options. (list (option '(#\h "help") #f #f (lambda args - (show-help) + (leave-on-EPIPE (show-help)) (exit 0))) (option '(#\V "version") #f #f (lambda args diff --git a/guix/scripts/size.scm b/guix/scripts/size.scm index 48b8ecc881..d26ed98388 100644 --- a/guix/scripts/size.scm +++ b/guix/scripts/size.scm @@ -278,7 +278,7 @@ Report the size of the PACKAGE or STORE-ITEM, with its dependencies.\n")) %standard-build-options) (option '(#\h "help") #f #f (lambda args - (show-help) + (leave-on-EPIPE (show-help)) (exit 0))) (option '(#\V "version") #f #f (lambda args diff --git a/guix/scripts/style.scm b/guix/scripts/style.scm index 4920a8d969..145cd09881 100644 --- a/guix/scripts/style.scm +++ b/guix/scripts/style.scm @@ -547,7 +547,7 @@ bailing out~%")) (option '(#\h "help") #f #f (lambda args - (show-help) + (leave-on-EPIPE (show-help)) (exit 0))) (option '(#\l "list-stylings") #f #f (lambda args diff --git a/guix/scripts/substitute.scm b/guix/scripts/substitute.scm index 8b1f7d6fda..126f0f9c69 100755 --- a/guix/scripts/substitute.scm +++ b/guix/scripts/substitute.scm @@ -813,7 +813,7 @@ default value." ((or ("-V") ("--version")) (show-version-and-exit "guix substitute")) ((or ("-h") ("--help") ()) - (show-help) + (leave-on-EPIPE (show-help)) (exit 0)) (_ #t)) diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm index 547387d5e1..f85b663d64 100644 --- a/guix/scripts/system.scm +++ b/guix/scripts/system.scm @@ -1064,7 +1064,7 @@ Some ACTIONS support additional ARGS.\n")) ;; Specifications of the command-line options. (cons* (option '(#\h "help") #f #f (lambda args - (show-help) + (leave-on-EPIPE (show-help)) (exit 0))) (option '(#\V "version") #f #f (lambda args diff --git a/guix/scripts/time-machine.scm b/guix/scripts/time-machine.scm index 3ecf735acb..f31fae7435 100644 --- a/guix/scripts/time-machine.scm +++ b/guix/scripts/time-machine.scm @@ -107,7 +107,7 @@ Execute COMMAND ARGS... in an older version of Guix.\n")) (alist-cons 'authenticate-channels? #f result))) (option '(#\h "help") #f #f (lambda args - (show-help) + (leave-on-EPIPE (show-help)) (exit 0))) (option '(#\V "version") #f #f (lambda args diff --git a/guix/scripts/upgrade.scm b/guix/scripts/upgrade.scm index beb59cbe6f..1a5e8088cb 100644 --- a/guix/scripts/upgrade.scm +++ b/guix/scripts/upgrade.scm @@ -56,7 +56,7 @@ This is an alias for 'guix package -u'.\n")) ;; Specification of the command-line options. (cons* (option '(#\h "help") #f #f (lambda args - (show-help) + (leave-on-EPIPE (show-help)) (exit 0))) (option '(#\V "version") #f #f (lambda args diff --git a/guix/scripts/weather.scm b/guix/scripts/weather.scm index dc27f81984..140df3435f 100644 --- a/guix/scripts/weather.scm +++ b/guix/scripts/weather.scm @@ -360,7 +360,7 @@ Report the availability of substitutes.\n")) (define %options (cons* (option '(#\h "help") #f #f (lambda args - (show-help) + (leave-on-EPIPE (show-help)) (exit 0))) (option '(#\V "version") #f #f (lambda args diff --git a/guix/ui.scm b/guix/ui.scm index 6f2d4fe245..e3bf07212f 100644 --- a/guix/ui.scm +++ b/guix/ui.scm @@ -552,19 +552,20 @@ See the \"Application Setup\" section in the manual, for more info.\n")) (define* (show-version-and-exit #:optional (command (car (command-line)))) "Display version information for COMMAND and `(exit 0)'." - (simple-format #t "~a (~a) ~a~%" - command %guix-package-name %guix-version) - (format #t "Copyright ~a 2023 ~a" - ;; TRANSLATORS: Translate "(C)" to the copyright symbol - ;; (C-in-a-circle), if this symbol is available in the user's - ;; locale. Otherwise, do not translate "(C)"; leave it as-is. */ - (G_ "(C)") - (G_ "the Guix authors\n")) - (display (G_"\ + (leave-on-EPIPE + (simple-format #t "~a (~a) ~a~%" + command %guix-package-name %guix-version) + (format #t "Copyright ~a 2023 ~a" + ;; TRANSLATORS: Translate "(C)" to the copyright symbol + ;; (C-in-a-circle), if this symbol is available in the user's + ;; locale. Otherwise, do not translate "(C)"; leave it as-is. */ + (G_ "(C)") + (G_ "the Guix authors\n")) + (display (G_"\ License GPLv3+: GNU GPL version 3 or later <http://gnu.org/licenses/gpl.html> This is free software: you are free to change and redistribute it. There is NO WARRANTY, to the extent permitted by law. -")) +"))) (exit 0)) (define (show-bug-report-information) |