diff options
author | Christopher Baines <mail@cbaines.net> | 2023-03-02 10:37:28 +0000 |
---|---|---|
committer | Christopher Baines <mail@cbaines.net> | 2023-03-02 10:55:08 +0000 |
commit | 7df09ee0ab3e7962ef27859ce87e06a323059284 (patch) | |
tree | d81334f742ddcb9a1ee63961ca6410922980af1c /guix/scripts | |
parent | 2ac51ec99b58b50c08ba719a8c7e9dba0330b065 (diff) | |
parent | af95f2d8f98eb2c8c64954bb2fd0b70838899174 (diff) |
Merge remote-tracking branch 'savannah/master' into core-updates
Conflicts:
gnu/local.mk
gnu/packages/autotools.scm
gnu/packages/cmake.scm
gnu/packages/gnuzilla.scm
gnu/packages/haskell.scm
gnu/packages/pdf.scm
gnu/packages/python-xyz.scm
gnu/packages/samba.scm
gnu/packages/tex.scm
gnu/packages/tls.scm
gnu/packages/wxwidgets.scm
Diffstat (limited to 'guix/scripts')
-rw-r--r-- | guix/scripts/build.scm | 18 | ||||
-rw-r--r-- | guix/scripts/container/exec.scm | 10 | ||||
-rw-r--r-- | guix/scripts/describe.scm | 6 | ||||
-rw-r--r-- | guix/scripts/environment.scm | 4 | ||||
-rw-r--r-- | guix/scripts/home.scm | 8 | ||||
-rw-r--r-- | guix/scripts/home/edit.scm | 6 | ||||
-rw-r--r-- | guix/scripts/import.scm | 5 | ||||
-rw-r--r-- | guix/scripts/offload.scm | 7 | ||||
-rw-r--r-- | guix/scripts/pack.scm | 564 | ||||
-rw-r--r-- | guix/scripts/package.scm | 6 | ||||
-rw-r--r-- | guix/scripts/pull.scm | 6 | ||||
-rw-r--r-- | guix/scripts/repl.scm | 1 | ||||
-rw-r--r-- | guix/scripts/shell.scm | 10 | ||||
-rw-r--r-- | guix/scripts/system.scm | 9 | ||||
-rw-r--r-- | guix/scripts/system/edit.scm | 6 |
15 files changed, 462 insertions, 204 deletions
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 <ludo@gnu.org> +;;; Copyright © 2012-2023 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2013 Mark H Weaver <mhw@netris.org> ;;; Copyright © 2020 Marius Bakke <mbakke@fastmail.com> ;;; Copyright © 2020 Ricardo Wurmus <rekado@elephly.net> @@ -377,12 +377,12 @@ use '--no-offload' instead~%"))) arg) (if closest (display-hint - (format #f (G_ "Did you mean @code{~a}? + (G_ "Did you mean @code{~a}? Try @option{--list-targets} to view available targets.~%") - closest)) + closest) (display-hint - (format #f (G_ "\ -Try @option{--list-targets} to view available targets.~%")))) + (G_ "\ +Try @option{--list-targets} to view available targets.~%"))) (exit 1)))))))) (define %standard-native-build-options @@ -404,12 +404,12 @@ Try @option{--list-targets} to view available targets.~%")))) arg) (if closest (display-hint - (format #f (G_ "Did you mean @code{~a}? + (G_ "Did you mean @code{~a}? Try @option{--list-systems} to view available system types.~%") - closest)) + closest) (display-hint - (format #f (G_ "\ -Try @option{--list-systems} to view available system types.~%")))) + (G_ "\ +Try @option{--list-systems} to view available system types.~%"))) (exit 1)))))))) diff --git a/guix/scripts/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 @@ and the other containing arguments for the command to be executed." 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))))))))) diff --git a/guix/scripts/describe.scm b/guix/scripts/describe.scm index 80cd0ce00a..5523aa0ec2 100644 --- a/guix/scripts/describe.scm +++ b/guix/scripts/describe.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2018, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2018, 2019, 2020, 2021, 2023 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2018 Oleg Pykhalov <go.wigust@gmail.com> ;;; Copyright © 2020 Ekaitz Zarraga <ekaitz@elenq.tech> ;;; Copyright © 2021 Simon Tournier <zimon.toutoune@gmail.com> @@ -154,10 +154,10 @@ within a Git checkout." (channel (repository->guix-channel (dirname program)))) (unless channel (report-error (G_ "failed to determine origin~%")) - (display-hint (format #f (G_ "Perhaps this + (display-hint (G_ "Perhaps this @command{guix} command was not obtained with @command{guix pull}? Its version string is ~a.~%") - %guix-version)) + %guix-version) (exit 1)) (match fmt diff --git a/guix/scripts/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 @@ command name." (let ((closest (string-closest executable available #:threshold 12))) (unless (or (not closest) (string=? closest executable)) - (display-hint (format #f (G_ "Did you mean '~a'?~%") - closest))))))))) + (display-hint (G_ "Did you mean '~a'?~%") + closest)))))))) (define* (launch-environment/fork command profile manifest #:key pure? (white-list '())) diff --git a/guix/scripts/home.scm b/guix/scripts/home.scm index a37f059711..445853d01f 100644 --- a/guix/scripts/home.scm +++ b/guix/scripts/home.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2021 Andrew Tropin <andrew@trop.in> +;;; Copyright © 2021, 2023 Andrew Tropin <andrew@trop.in> ;;; Copyright © 2021 Xinglu Chen <public@yoctocell.xyz> ;;; Copyright © 2021 Pierre Langlois <pierre.langlois@gmx.com> ;;; Copyright © 2021 Oleg Pykhalov <go.wigust@gmail.com> @@ -410,6 +410,7 @@ immediately. Return the exit status of the process in the container." network?) "Perform ACTION for home environment. " + (ensure-profile-directory) (define println (cut format #t "~a~%" <>)) @@ -474,7 +475,6 @@ ACTION must be one of the sub-commands that takes a home environment declaration as an argument (a file name.) OPTS is the raw alist of options resulting from command-line parsing." (define (ensure-home-environment file-or-exp obj) - (ensure-profile-directory) (unless (home-environment? obj) (leave (G_ "'~a' does not return a home environment~%") file-or-exp)) @@ -573,10 +573,10 @@ argument list and OPTS is the option alist." (cut import-manifest manifest destination <>)) (info (G_ "'~a' populated with all the Home configuration files~%") destination) - (display-hint (format #f (G_ "\ + (display-hint (G_ "\ Run @command{guix home reconfigure ~a/home-configuration.scm} to effectively deploy the home environment described by these files.\n") - destination)))) + destination))) ((describe) (let ((list-installed-regex (assoc-ref opts 'list-installed))) (match (generation-number %guix-home) diff --git a/guix/scripts/home/edit.scm b/guix/scripts/home/edit.scm index a6c05675b3..d039179a10 100644 --- a/guix/scripts/home/edit.scm +++ b/guix/scripts/home/edit.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2022 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2022, 2023 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -40,8 +40,8 @@ '())) (closest (string-closest type available))) (unless (or (not closest) (string=? closest type)) - (display-hint (format #f (G_ "Did you mean @code{~a}?~%") - closest)))) + (display-hint (G_ "Did you mean @code{~a}?~%") + closest))) (exit 1)) diff --git a/guix/scripts/import.scm b/guix/scripts/import.scm index 2bca927d63..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 <ludo@gnu.org> +;;; Copyright © 2012-2014, 2020-2023 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2014 David Thompson <davet@gnu.org> ;;; Copyright © 2018 Kyle Meyer <kyle@kyleam.com> ;;; Copyright © 2019, 2022 Ricardo Wurmus <rekado@elephly.net> @@ -106,6 +106,5 @@ Run IMPORTER with ARGS.\n")) (let ((hint (string-closest importer importers #:threshold 3))) (report-error (G_ "~a: invalid importer~%") importer) (when hint - (display-hint - (format #f (G_ "Did you mean @code{~a}?~%") hint))) + (display-hint (G_ "Did you mean @code{~a}?~%") hint)) (exit 1)))))) diff --git a/guix/scripts/offload.scm b/guix/scripts/offload.scm index 578b3b9888..8c6132e7c3 100644 --- a/guix/scripts/offload.scm +++ b/guix/scripts/offload.scm @@ -220,7 +220,12 @@ number of seconds after which the connection times out." (session (make-session #:user (build-machine-user machine) #:host (build-machine-name machine) #:port (build-machine-port machine) - #:timeout 10 ;initial timeout (seconds) + ;; Multiple derivations may be offloaded in + ;; parallel, and when there is a large amount + ;; of data to be sent, it can choke lower + ;; bandwidth connections and cause timeouts, so + ;; set it to a large enough value. + #:timeout 30 ;initial timeout (seconds) ;; #:log-verbosity 'protocol #:identity (build-machine-private-key machine) diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm index f65642fb85..eb41eb5563 100644 --- a/guix/scripts/pack.scm +++ b/guix/scripts/pack.scm @@ -1,11 +1,11 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2015, 2017-2022 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2015, 2017-2023 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2017, 2018 Ricardo Wurmus <rekado@elephly.net> ;;; Copyright © 2018 Konrad Hinsen <konrad.hinsen@fastmail.net> ;;; Copyright © 2018 Chris Marusich <cmmarusich@gmail.com> ;;; Copyright © 2018 Efraim Flashner <efraim@flashner.co.il> ;;; Copyright © 2020 Tobias Geerinckx-Rice <me@tobias.gr> -;;; Copyright © 2020, 2021, 2022 Maxim Cournoyer <maxim.cournoyer@gmail.com> +;;; Copyright © 2020, 2021, 2022, 2023 Maxim Cournoyer <maxim.cournoyer@gmail.com> ;;; Copyright © 2020 Eric Bavier <bavier@posteo.net> ;;; Copyright © 2022 Alex Griffin <a@ajgrf.com> ;;; @@ -67,6 +67,7 @@ self-contained-tarball debian-archive + rpm-archive docker-image squashfs-image @@ -194,104 +195,150 @@ target the profile's @file{bin/env} file: (leave (G_ "~a: invalid symlink specification~%") arg)))) - -;;; -;;; Tarball format. -;;; -(define* (self-contained-tarball/builder profile - #:key (profile-name "guix-profile") - (compressor (first %compressors)) - localstatedir? - (symlinks '()) - (archiver tar) - (extra-options '())) - "Return the G-Expression of the builder used for self-contained-tarball." +(define (set-utf8-locale profile) + "Configure the environment to use the \"en_US.utf8\" locale provided by the +GLIBC-UT8-LOCALES package." + ;; Arrange to not depend on 'glibc-utf8-locales' when using '--bootstrap'. + (and (or (not (profile? profile)) + (profile-locales? profile)) + #~(begin + (setenv "GUIX_LOCPATH" + #+(file-append glibc-utf8-locales "/lib/locale")) + (setlocale LC_ALL "en_US.utf8")))) + +(define* (populate-profile-root profile + #:key (profile-name "guix-profile") + target + localstatedir? + deduplicate? + (symlinks '())) + "Populate the root profile directory with SYMLINKS and a Guix database, when +LOCALSTATEDIR? is set. When DEDUPLICATE? is true, deduplicate the store +items, which relies on hard links." (define database (and localstatedir? (file-append (store-database (list profile)) "/db/db.sqlite"))) - (define set-utf8-locale - ;; Arrange to not depend on 'glibc-utf8-locales' when using '--bootstrap'. - (and (or (not (profile? profile)) - (profile-locales? profile)) - #~(begin - (setenv "GUIX_LOCPATH" - #+(file-append glibc-utf8-locales "/lib/locale")) - (setlocale LC_ALL "en_US.utf8")))) + (define bootstrap? + ;; Whether a '--bootstrap' environment is needed, for testing purposes. + ;; XXX: Infer that from available info. + (and (not database) (not (profile-locales? profile)))) (define (import-module? module) ;; Since we don't use deduplication support in 'populate-store', don't ;; import (guix store deduplication) and its dependencies, which includes - ;; Guile-Gcrypt. That way we can run tests with '--bootstrap'. + ;; Guile-Gcrypt, unless DEDUPLICATE? is #t. This makes it possible to run + ;; tests with '--bootstrap'. (and (not-config? module) - (not (equal? '(guix store deduplication) module)))) - - (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: + ;; <http://lists.gnu.org/archive/html/bug-tar/2017-11/msg00009.html>. + (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 + #:guile (if bootstrap? %bootstrap-guile (default-guile)) + #:options (list #:references-graphs `(("profile" ,profile)) + #:target target))) + + +;;; +;;; Tarball format. +;;; +(define* (self-contained-tarball/builder profile + #:key (profile-name "guix-profile") + target + localstatedir? + deduplicate? + symlinks + compressor + archiver) + "Return a GEXP that can build a self-contained tarball." + + (define root (populate-profile-root profile + #:profile-name profile-name + #:target target + #:localstatedir? localstatedir? + #:deduplicate? deduplicate? + #:symlinks symlinks)) + + (with-imported-modules (source-module-closure '((guix build pack) + (guix build utils))) #~(begin (use-modules (guix build pack) - (guix build 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: - ;; <http://lists.gnu.org/archive/html/bug-tar/2017-11/msg00009.html>. - (populate-store (list "profile") %root #:deduplicate? #f) + (define %root (if #$localstatedir? "." #$root)) - (when #+localstatedir? - (install-database-and-gc-roots %root #+database #$profile - #:profile-name #$profile-name)) + (when #$localstatedir? + ;; Fix the permission of the Guix database file, which was made + ;; read-only when copied to the store in populate-profile-root. + (copy-recursively #$root %root) + (chmod (string-append %root "/var/guix/db/db.sqlite") #o644)) - ;; Create SYMLINKS. - (for-each (cut evaluate-populate-directive <> %root) - directives) - - ;; Create the tarball. (with-directory-excursion %root ;; GNU Tar recurses directories by default. Simply add the whole - ;; current directory, which contains all the generated files so far. + ;; current directory, which contains all the files to be archived. ;; This avoids creating duplicate files in the archives that would ;; be stored as hard links by GNU Tar. (apply invoke tar "-cvf" #$output "." @@ -320,17 +367,16 @@ added to the pack." (warning (G_ "entry point not supported in the '~a' format~%") 'tarball)) - (gexp->derivation - (string-append name ".tar" - (compressor-extension compressor)) - (self-contained-tarball/builder profile - #:profile-name profile-name - #:compressor compressor - #:localstatedir? localstatedir? - #:symlinks symlinks - #:archiver archiver) - #:target target - #:references-graphs `(("profile" ,profile)))) + (gexp->derivation (string-append name ".tar" + (compressor-extension compressor)) + (self-contained-tarball/builder profile + #:profile-name profile-name + #:target target + #:localstatedir? localstatedir? + #:deduplicate? deduplicate? + #:symlinks symlinks + #:compressor compressor + #:archiver archiver))) ;;; @@ -676,18 +722,19 @@ Valid compressors are: ~a~%") compressor-name %valid-compressors))) 'deb)) (define data-tarball - (computed-file (string-append "data.tar" - (compressor-extension compressor)) - (self-contained-tarball/builder - profile - #:profile-name profile-name - #:compressor compressor - #:localstatedir? localstatedir? - #:symlinks symlinks - #:archiver archiver) - #:local-build? #f ;allow offloading - #:options (list #:references-graphs `(("profile" ,profile)) - #:target target))) + (computed-file (string-append "data.tar" (compressor-extension + compressor)) + (self-contained-tarball/builder profile + #:target target + #:profile-name profile-name + #:localstatedir? localstatedir? + #:deduplicate? deduplicate? + #:symlinks symlinks + #:compressor compressor + #:archiver archiver) + #:local-build? #f ;allow offloading + #:options (list #:references-graphs `(("profile" ,profile)) + #:target target))) (define build (with-extensions (list guile-gcrypt) @@ -702,6 +749,7 @@ Valid compressors are: ~a~%") compressor-name %valid-compressors))) (guix build utils) (guix profiles) (ice-9 match) + (ice-9 optargs) (srfi srfi-1)) (define machine-type @@ -762,32 +810,23 @@ Valid compressors are: ~a~%") compressor-name %valid-compressors))) (copy-file #+data-tarball data-tarball-file-name) - (define (keyword-ref lst keyword) - (match (memq keyword lst) - ((_ value . _) value) - (#f #f))) - ;; Generate the control archive. - (define control-file - (keyword-ref '#$extra-options #:control-file)) - - (define postinst-file - (keyword-ref '#$extra-options #:postinst-file)) - - (define triggers-file - (keyword-ref '#$extra-options #:triggers-file)) - - (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,36 +836,196 @@ Priority: optional Section: misc ~%" package-name package-version architecture)))) - (when postinst-file - (copy-file postinst-file "postinst") - (chmod "postinst" #o755)) + (when postinst-file + (copy-file postinst-file "postinst") + (chmod "postinst" #o755)) - (when triggers-file - (copy-file triggers-file "triggers")) + (when triggers-file + (copy-file triggers-file "triggers")) - (define tar (string-append #+archiver "/bin/tar")) + (define tar (string-append #+archiver "/bin/tar")) - (apply invoke tar - `(,@(tar-base-options - #:tar tar - #:compressor #+(and=> compressor compressor-command)) - "-cvf" ,control-tarball-file-name - "control" - ,@(if postinst-file '("postinst") '()) - ,@(if triggers-file '("triggers") '()))) + (apply invoke tar + `(,@(tar-base-options + #:tar tar + #:compressor #+(and=> compressor compressor-command)) + "-cvf" ,control-tarball-file-name + "control" + ,@(if postinst-file '("postinst") '()) + ,@(if triggers-file '("triggers") '()))) - ;; Create the .deb archive using GNU ar. - (invoke (string-append #+binutils "/bin/ar") "-rv" #$output - "debian-binary" - control-tarball-file-name data-tarball-file-name))))) + ;; Create the .deb archive using GNU ar. + (invoke (string-append #+binutils "/bin/ar") "-rv" #$output + "debian-binary" + control-tarball-file-name data-tarball-file-name)))))) - (gexp->derivation (string-append name ".deb") - build - #:target target - #:references-graphs `(("profile" ,profile)))) + (gexp->derivation (string-append name ".deb") build)) ;;; +;;; RPM archive format. +;;; +(define* (rpm-archive name profile + #:key target + (profile-name "guix-profile") + entry-point + (compressor (first %compressors)) + deduplicate? + localstatedir? + (symlinks '()) + archiver + (extra-options '())) + "Return a RPM archive (.rpm) containing a store initialized with the closure +of PROFILE, a derivation. The archive contains /gnu/store. SYMLINKS must be +a list of (SOURCE -> TARGET) tuples denoting symlinks to be added to the pack. +ARCHIVER and ENTRY-POINT are not used. RELOCATABLE?, PREIN-FILE, POSTIN-FILE, +PREUN-FILE and POSTUN-FILE can be provided via EXTRA-OPTIONS." + (when entry-point + (warning (G_ "entry point not supported in the '~a' format~%") 'rpm)) + + (define root (populate-profile-root profile + #:profile-name profile-name + #:target target + #:localstatedir? localstatedir? + #:deduplicate? deduplicate? + #:symlinks symlinks)) + + (define payload + (let* ((raw-cpio-file-name "payload.cpio") + (compressed-cpio-file-name (string-append raw-cpio-file-name + (compressor-extension + compressor)))) + (computed-file compressed-cpio-file-name + (with-imported-modules (source-module-closure + '((guix build utils) + (guix cpio) + (guix rpm))) + #~(begin + (use-modules (guix build utils) + (guix cpio) + (guix rpm) + (srfi srfi-1)) + + ;; Make sure non-ASCII file names are properly handled. + #+(set-utf8-locale profile) + + (define %root (if #$localstatedir? "." #$root)) + + (when #$localstatedir? + ;; Fix the permission of the Guix database file, which was made + ;; read-only when copied to the store in populate-profile-root. + (copy-recursively #$root %root) + (chmod (string-append %root "/var/guix/db/db.sqlite") #o644)) + + (call-with-output-file #$raw-cpio-file-name + (lambda (port) + (with-directory-excursion %root + ;; The first "." entry is discarded. + (write-cpio-archive + (remove fhs-directory? + (cdr (find-files "." #:directories? #t))) + port)))) + (when #+(compressor-command compressor) + (apply invoke (append #+(compressor-command compressor) + (list #$raw-cpio-file-name)))) + (copy-file #$compressed-cpio-file-name #$output))) + #:local-build? #f))) ;allow offloading + + (define build + (with-extensions (list guile-gcrypt) + (with-imported-modules `(((guix config) => ,(make-config.scm)) + ,@(source-module-closure + `((gcrypt hash) + (guix build utils) + (guix profiles) + (guix rpm)) + #:select? not-config?)) + #~(begin + (use-modules (gcrypt hash) + (guix build utils) + (guix profiles) + (guix rpm) + (ice-9 binary-ports) + (ice-9 match) ;for manifest->friendly-name + (ice-9 optargs) + (rnrs bytevectors) + (srfi srfi-1)) + + ;; Make sure non-ASCII file names are properly handled. + #+(set-utf8-locale profile) + + (define machine-type + (and=> (or #$target %host-type) + (lambda (triplet) + (first (string-split triplet #\-))))) + + #$(procedure-source manifest->friendly-name) + + (define manifest (profile-manifest #$profile)) + + (define single-entry ;manifest entry + (match (manifest-entries manifest) + ((entry) + entry) + (_ #f))) + + (define name + (or (and=> single-entry manifest-entry-name) + (manifest->friendly-name manifest))) + + (define version + (or (and=> single-entry manifest-entry-version) "0.0.0")) + + (define lead + (generate-lead (string-append name "-" version) + #:target (or #$target %host-type))) + + (define payload-digest + (bytevector->hex-string (file-sha256 #$payload))) + + (let-keywords '#$extra-options #f ((relocatable? #f) + (prein-file #f) + (postin-file #f) + (preun-file #f) + (postun-file #f)) + + (let ((header (generate-header name version + payload-digest + #$root + #$(compressor-name compressor) + #:target (or #$target %host-type) + #:relocatable? relocatable? + #:prein-file prein-file + #:postin-file postin-file + #:preun-file preun-file + #:postun-file postun-file))) + + (define header-sha256 + (bytevector->hex-string (sha256 (u8-list->bytevector header)))) + + (define payload-size (stat:size (stat #$payload))) + + (define header+compressed-payload-size + (+ (length header) payload-size)) + + (define signature + (generate-signature header-sha256 + header+compressed-payload-size)) + + ;; Serialize the archive components to a file. + (call-with-input-file #$payload + (lambda (in) + (call-with-output-file #$output + (lambda (out) + (put-bytevector out (assemble-rpm-metadata lead + signature + header)) + (sendfile out in payload-size))))))))))) + + (gexp->derivation (string-append name ".rpm") build)) + + +;;; ;;; Compiling C programs. ;;; @@ -1158,7 +1357,8 @@ last resort for relocation." `((tarball . ,self-contained-tarball) (squashfs . ,squashfs-image) (docker . ,docker-image) - (deb . ,debian-archive))) + (deb . ,debian-archive) + (rpm . ,rpm-archive))) (define (show-formats) ;; Print the supported pack formats. @@ -1172,18 +1372,22 @@ last resort for relocation." docker Tarball ready for 'docker load'")) (display (G_ " deb Debian archive installable via dpkg/apt")) + (display (G_ " + rpm RPM archive installable via rpm/yum")) (newline)) +(define (required-option symbol) + "Return an SYMBOL option that requires a value." + (option (list (symbol->string symbol)) #t #f + (lambda (opt name arg result . rest) + (apply values + (alist-cons symbol arg result) + rest)))) + (define %deb-format-options - (let ((required-option (lambda (symbol) - (option (list (symbol->string symbol)) #t #f - (lambda (opt name arg result . rest) - (apply values - (alist-cons symbol arg result) - rest)))))) - (list (required-option 'control-file) - (required-option 'postinst-file) - (required-option 'triggers-file)))) + (list (required-option 'control-file) + (required-option 'postinst-file) + (required-option 'triggers-file))) (define (show-deb-format-options) (display (G_ " @@ -1202,6 +1406,32 @@ last resort for relocation." (newline) (exit 0)) +(define %rpm-format-options + (list (required-option 'prein-file) + (required-option 'postin-file) + (required-option 'preun-file) + (required-option 'postun-file))) + +(define (show-rpm-format-options) + (display (G_ " + --help-rpm-format list options specific to the RPM format"))) + +(define (show-rpm-format-options/detailed) + (display (G_ " + --prein-file=FILE + Embed the provided prein script")) + (display (G_ " + --postin-file=FILE + Embed the provided postin script")) + (display (G_ " + --preun-file=FILE + Embed the provided preun script")) + (display (G_ " + --postun-file=FILE + Embed the provided postun script")) + (newline) + (exit 0)) + (define %options ;; Specifications of the command-line options. (cons* (option '(#\h "help") #f #f @@ -1278,7 +1508,12 @@ last resort for relocation." (lambda args (show-deb-format-options/detailed))) + (option '("help-rpm-format") #f #f + (lambda args + (show-rpm-format-options/detailed))) + (append %deb-format-options + %rpm-format-options %transformation-options %standard-build-options %standard-cross-build-options @@ -1296,6 +1531,7 @@ Create a bundle of PACKAGE.\n")) (show-transformation-options-help) (newline) (show-deb-format-options) + (show-rpm-format-options) (newline) (display (G_ " -f, --format=FORMAT build a pack in the given FORMAT")) @@ -1454,6 +1690,16 @@ Create a bundle of PACKAGE.\n")) (process-file-arg opts 'postinst-file) #:triggers-file (process-file-arg opts 'triggers-file))) + ('rpm + (list #:relocatable? relocatable? + #:prein-file + (process-file-arg opts 'prein-file) + #:postin-file + (process-file-arg opts 'postin-file) + #:preun-file + (process-file-arg opts 'preun-file) + #:postun-file + (process-file-arg opts 'postun-file))) (_ '()))) (target (assoc-ref opts 'target)) (bootstrap? (assoc-ref opts 'bootstrap?)) diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm index 2f774621bb..cb58f56d5a 100644 --- a/guix/scripts/package.scm +++ b/guix/scripts/package.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2012-2022 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2012-2023 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2013 Nikita Karetnikov <nikita@karetnikov.org> ;;; Copyright © 2013, 2015 Mark H Weaver <mhw@netris.org> ;;; Copyright © 2014, 2016 Alex Kost <alezost@gmail.com> @@ -323,7 +323,7 @@ of manifest entries, in the context of PROFILE." (settings (search-path-environment-variables entries (list profile) #:kind 'prefix))) (unless (null? settings) - (display-hint (format #f (G_ "Consider setting the necessary environment + (display-hint (G_ "Consider setting the necessary environment variables by running: @example @@ -332,7 +332,7 @@ GUIX_PROFILE=\"~a\" @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 <ludo@gnu.org> +;;; Copyright © 2013-2015, 2017-2023 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2017 Marius Bakke <mbakke@fastmail.com> ;;; Copyright © 2020, 2021 Tobias Geerinckx-Rice <me@tobias.gr> ;;; @@ -469,9 +469,9 @@ true, display what would be built without actually building it." ;; Is the 'guix' command previously in $PATH the same as the new ;; one? If the answer is "no", then suggest 'hash guix'. (unless (member guix-command new) - (display-hint (format #f (G_ "After setting @code{PATH}, run + (display-hint (G_ "After setting @code{PATH}, run @command{hash guix} to make sure your shell refers to @file{~a}.") - (first new)))) + (first new))) (return #f)) (return #f))))) diff --git a/guix/scripts/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 @@ call THUNK." ((guile) (save-module-excursion (lambda () + (current-profile) ;populate (%package-module-path); see above (set-user-module) ;; Do not exit repl on SIGINT. ((@@ (ice-9 top-repl) call-with-sigint) diff --git a/guix/scripts/shell.scm b/guix/scripts/shell.scm index 64b5c2e8e9..92bbfb04d0 100644 --- a/guix/scripts/shell.scm +++ b/guix/scripts/shell.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2021-2022 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2021-2023 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -305,16 +305,16 @@ Return the modified OPTS." (report-error (G_ "not loading '~a' because not authorized to do so~%") file) - (display-hint (format #f (G_ "To allow automatic loading of + (display-hint (G_ "To allow automatic loading of @file{~a} when running @command{guix shell}, you must explicitly authorize its directory, like so: @example echo ~a >> ~a @end example\n") - file - (dirname file) - (authorized-directory-file))) + file + (dirname file) + (authorized-directory-file)) (exit 1))))))) diff --git a/guix/scripts/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 <ludo@gnu.org> +;;; Copyright © 2014-2023 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2016 Alex Kost <alezost@gmail.com> ;;; Copyright © 2016, 2017, 2018 Chris Marusich <cmmarusich@gmail.com> ;;; Copyright © 2017, 2019 Mathieu Othacehe <m.othacehe@gmail.com> @@ -633,9 +633,9 @@ any, are available. Raise an error if they're not." (G_ "device '~a' not found: ~a~%") device (strerror errno)) (unless (string-prefix? "/" device) - (display-hint (format #f (G_ "If '~a' is a file system + (display-hint (G_ "If '~a' is a file system label, write @code{(file-system-label ~s)} in your @code{device} field.") - device device))))))) + device device)))))) literal) (for-each (lambda (fs) (let ((label (file-system-label->string @@ -1417,8 +1417,7 @@ argument list and OPTS is the option alist." (let ((hint (string-closest arg actions #:threshold 3))) (report-error (G_ "~a: unknown action~%") arg) (when hint - (display-hint - (format #f (G_ "Did you mean @code{~a}?~%") hint))) + (display-hint (G_ "Did you mean @code{~a}?~%") hint)) (exit 1))))) (define (match-pair car) diff --git a/guix/scripts/system/edit.scm b/guix/scripts/system/edit.scm index d966ee0aaa..0afb071650 100644 --- a/guix/scripts/system/edit.scm +++ b/guix/scripts/system/edit.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2022 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2022, 2023 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -39,8 +39,8 @@ '())) (closest (string-closest type available))) (unless (or (not closest) (string=? closest type)) - (display-hint (format #f (G_ "Did you mean @code{~a}?~%") - closest)))) + (display-hint (G_ "Did you mean @code{~a}?~%") + closest))) (exit 1)) |