diff options
Diffstat (limited to 'guix/scripts')
| -rw-r--r-- | guix/scripts/challenge.scm | 11 | ||||
| -rw-r--r-- | guix/scripts/download.scm | 2 | ||||
| -rw-r--r-- | guix/scripts/edit.scm | 6 | ||||
| -rw-r--r-- | guix/scripts/environment.scm | 10 | ||||
| -rw-r--r-- | guix/scripts/import.scm | 2 | ||||
| -rw-r--r-- | guix/scripts/import/composer.scm | 107 | ||||
| -rw-r--r-- | guix/scripts/import/crate.scm | 24 | ||||
| -rw-r--r-- | guix/scripts/locate.scm | 26 | ||||
| -rw-r--r-- | guix/scripts/pack.scm | 96 | ||||
| -rw-r--r-- | guix/scripts/shell.scm | 7 | ||||
| -rw-r--r-- | guix/scripts/size.scm | 3 | ||||
| -rw-r--r-- | guix/scripts/style.scm | 2 | ||||
| -rwxr-xr-x | guix/scripts/substitute.scm | 5 | ||||
| -rw-r--r-- | guix/scripts/system.scm | 31 | ||||
| -rw-r--r-- | guix/scripts/time-machine.scm | 91 | ||||
| -rw-r--r-- | guix/scripts/weather.scm | 61 |
16 files changed, 391 insertions, 93 deletions
diff --git a/guix/scripts/challenge.scm b/guix/scripts/challenge.scm index 01e2f9a2b2..d38171b868 100644 --- a/guix/scripts/challenge.scm +++ b/guix/scripts/challenge.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2015-2017, 2019-2022 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2015-2017, 2019-2023 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -504,7 +504,6 @@ Challenge the substitutes for PACKAGE... provided by one or more servers.\n")) (define %default-options `((system . ,(%current-system)) - (substitute-urls . ,%default-substitute-urls) (difference-report . ,report-differing-files))) @@ -539,7 +538,13 @@ Challenge the substitutes for PACKAGE... provided by one or more servers.\n")) (G_ "no arguments specified, nothing to do~%")) (exit 0)) (x - files)))) + files))) + (urls (or urls + (substitute-urls store) + (begin + (warning (G_ "could not determine current \ +substitute URLs; using defaults~%")) + %default-substitute-urls)))) (set-build-options store #:use-substitutes? #f) diff --git a/guix/scripts/download.scm b/guix/scripts/download.scm index 0441d3fead..19052d5652 100644 --- a/guix/scripts/download.scm +++ b/guix/scripts/download.scm @@ -55,7 +55,7 @@ file)) (define (ensure-valid-store-file-name name) - "Replace any character not allowed in a stror name by an underscore." + "Replace any character not allowed in a store name by an underscore." (define valid ;; according to nix/libstore/store-api.cc diff --git a/guix/scripts/edit.scm b/guix/scripts/edit.scm index ff2d529bcf..b7b4cd2514 100644 --- a/guix/scripts/edit.scm +++ b/guix/scripts/edit.scm @@ -64,7 +64,11 @@ Start $VISUAL or $EDITOR to edit the definitions of PACKAGE...\n")) (define (search-path* path file) "Like 'search-path' but exit if FILE is not found." - (let ((absolute-file-name (search-path path file))) + (let ((absolute-file-name (or (search-path path file) + ;; It could be that FILE is a relative name + ;; i.e., not relative to an element of PATH. + (and (file-exists? file) + file)))) (unless absolute-file-name ;; Shouldn't happen unless somebody fiddled with the 'location' field. (leave (G_ "file '~a' not found in search path ~s~%") diff --git a/guix/scripts/environment.scm b/guix/scripts/environment.scm index 6ae3b11e39..1d7a6e198d 100644 --- a/guix/scripts/environment.scm +++ b/guix/scripts/environment.scm @@ -311,6 +311,9 @@ use '--preserve' instead~%")) (define (options/resolve-packages store opts) "Return OPTS with package specification strings replaced by manifest entries for the corresponding packages." + (define system + (assoc-ref opts 'system)) + (define (manifest-entry=? e1 e2) (and (eq? (manifest-entry-item e1) (manifest-entry-item e2)) (string=? (manifest-entry-output e1) @@ -327,11 +330,11 @@ for the corresponding packages." ((? package? package) (if (eq? mode 'ad-hoc-package) (list (package->manifest-entry* package)) - (manifest-entries (package->development-manifest package)))) + (manifest-entries (package->development-manifest package system)))) (((? package? package) (? string? output)) (if (eq? mode 'ad-hoc-package) (list (package->manifest-entry* package output)) - (manifest-entries (package->development-manifest package)))) + (manifest-entries (package->development-manifest package system)))) ((lst ...) (append-map (cut packages->outputs <> mode) lst)))) @@ -345,7 +348,8 @@ for the corresponding packages." (('package 'package (? string? spec)) (manifest-entries (package->development-manifest - (transform (specification->package+output spec))))) + (transform (specification->package+output spec)) + system))) (('expression mode str) ;; Add all the outputs of the package STR evaluates to. (packages->outputs (read/eval str) mode)) diff --git a/guix/scripts/import.scm b/guix/scripts/import.scm index 1e8ffd25ec..d2a1cee56e 100644 --- a/guix/scripts/import.scm +++ b/guix/scripts/import.scm @@ -47,7 +47,7 @@ (define importers '("gnu" "pypi" "cpan" "hackage" "stackage" "egg" "elpa" "gem" "go" "cran" "crate" "texlive" "json" "opam" - "minetest" "elm" "hexpm")) + "minetest" "elm" "hexpm" "composer")) (define (resolve-importer name) (let ((module (resolve-interface diff --git a/guix/scripts/import/composer.scm b/guix/scripts/import/composer.scm new file mode 100644 index 0000000000..412bae6318 --- /dev/null +++ b/guix/scripts/import/composer.scm @@ -0,0 +1,107 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2015 David Thompson <davet@gnu.org> +;;; Copyright © 2018 Oleg Pykhalov <go.wigust@gmail.com> +;;; +;;; This file is part of GNU Guix. +;;; +;;; GNU Guix is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; GNU Guix is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. + +(define-module (guix scripts import composer) + #:use-module (guix ui) + #:use-module (guix utils) + #:use-module (guix scripts) + #:use-module (guix import composer) + #:use-module (guix scripts import) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-11) + #:use-module (srfi srfi-37) + #:use-module (srfi srfi-41) + #:use-module (ice-9 match) + #:use-module (ice-9 format) + #:export (guix-import-composer)) + + +;;; +;;; Command-line options. +;;; + +(define %default-options + '()) + +(define (show-help) + (display (G_ "Usage: guix import composer PACKAGE-NAME +Import and convert the Composer package for PACKAGE-NAME.\n")) + (display (G_ " + -h, --help display this help and exit")) + (display (G_ " + -V, --version display version information and exit")) + (display (G_ " + -r, --recursive generate package expressions for all Composer packages\ + that are not yet in Guix")) + (newline) + (show-bug-report-information)) + +(define %options + ;; Specification of the command-line options. + (cons* (option '(#\h "help") #f #f + (lambda args + (show-help) + (exit 0))) + (option '(#\V "version") #f #f + (lambda args + (show-version-and-exit "guix import composer"))) + (option '(#\r "recursive") #f #f + (lambda (opt name arg result) + (alist-cons 'recursive #t result))) + %standard-import-options)) + + +;;; +;;; Entry point. +;;; + +(define (guix-import-composer . args) + (define (parse-options) + ;; Return the alist of option values. + (args-fold* args %options + (lambda (opt name arg result) + (leave (G_ "~A: unrecognized option~%") name)) + (lambda (arg result) + (alist-cons 'argument arg result)) + %default-options)) + + (let* ((opts (parse-options)) + (args (filter-map (match-lambda + (('argument . value) + value) + (_ #f)) + (reverse opts)))) + (match args + ((package-name) + (if (assoc-ref opts 'recursive) + (map (match-lambda + ((and ('package ('name name) . rest) pkg) + `(define-public ,(string->symbol name) + ,pkg)) + (_ #f)) + (composer-recursive-import package-name)) + (let ((sexp (composer->guix-package package-name))) + (unless sexp + (leave (G_ "failed to download meta-data for package '~a'~%") + package-name)) + sexp))) + (() + (leave (G_ "too few arguments~%"))) + ((many ...) + (leave (G_ "too many arguments~%")))))) diff --git a/guix/scripts/import/crate.scm b/guix/scripts/import/crate.scm index 038faa87db..082a973aee 100644 --- a/guix/scripts/import/crate.scm +++ b/guix/scripts/import/crate.scm @@ -5,6 +5,7 @@ ;;; Copyright © 2019, 2020 Martin Becze <mjbecze@riseup.net> ;;; Copyright © 2021 Sarah Morgensen <iskarian@mgsn.dev> ;;; Copyright © 2023 Simon Tournier <zimon.toutoune@gmail.com> +;;; Copyright © 2023 David Elsing <david.elsing@posteo.net> ;;; ;;; This file is part of GNU Guix. ;;; @@ -47,6 +48,13 @@ Import and convert the crates.io package for PACKAGE-NAME.\n")) (display (G_ " -r, --recursive import packages recursively")) + (display (G_ " + --recursive-dev-dependencies + include dev-dependencies recursively")) + (display (G_ " + --allow-yanked + allow importing yanked crates if no alternative + satisfying the version requirement exists")) (newline) (display (G_ " -h, --help display this help and exit")) @@ -67,6 +75,12 @@ Import and convert the crates.io package for PACKAGE-NAME.\n")) (option '(#\r "recursive") #f #f (lambda (opt name arg result) (alist-cons 'recursive #t result))) + (option '("recursive-dev-dependencies") #f #f + (lambda (opt name arg result) + (alist-cons 'recursive-dev-dependencies #t result))) + (option '("allow-yanked") #f #f + (lambda (opt name arg result) + (alist-cons 'allow-yanked #t result))) %standard-import-options)) @@ -92,8 +106,14 @@ Import and convert the crates.io package for PACKAGE-NAME.\n")) (package-name->name+version spec)) (match (if (assoc-ref opts 'recursive) - (crate-recursive-import name #:version version) - (crate->guix-package name #:version version #:include-dev-deps? #t)) + (crate-recursive-import + name #:version version + #:recursive-dev-dependencies? + (assoc-ref opts 'recursive-dev-dependencies) + #:allow-yanked? (assoc-ref opts 'allow-yanked)) + (crate->guix-package + name #:version version #:include-dev-deps? #t + #:allow-yanked? (assoc-ref opts 'allow-yanked))) ((or #f '()) (leave (G_ "failed to download meta-data for package '~a'~%") (if version diff --git a/guix/scripts/locate.scm b/guix/scripts/locate.scm index ae64f46896..963ff2bf57 100644 --- a/guix/scripts/locate.scm +++ b/guix/scripts/locate.scm @@ -114,14 +114,24 @@ alter table Packages add column output text; "))) +;; XXX: missing in guile-sqlite3@0.1.3 +(define SQLITE_BUSY 5) + (define (call-with-database file proc) - (let ((db (sqlite-open file))) - (dynamic-wind - (lambda () #t) - (lambda () - (ensure-latest-database-schema db) - (proc db)) - (lambda () (sqlite-close db))))) + (catch 'sqlite-error + (lambda () + (let ((db (sqlite-open file))) + (dynamic-wind + (lambda () #t) + (lambda () + (ensure-latest-database-schema db) + (proc db)) + (lambda () (sqlite-close db))))) + (lambda (key who code errmsg) + (if (= code SQLITE_BUSY) + (leave (G_ "~a: database is locked by another process~%") + file) + (throw key who code errmsg))))) (define (ensure-latest-database-schema db) "Ensure DB follows the latest known version of the schema." @@ -657,7 +667,7 @@ Locate FILE and return the list of packages that contain it.\n")) files))) (() (if (null? files) - (unless update? + (unless (or update? (assoc-ref opts 'clear?)) (leave (G_ "no files to search for~%"))) (leave (N_ "file~{ '~a'~} not found in database '~a'~%" "files~{ '~a'~} not found in database '~a'~%" diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm index bdbea49910..3e45c34895 100644 --- a/guix/scripts/pack.scm +++ b/guix/scripts/pack.scm @@ -8,6 +8,8 @@ ;;; 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> +;;; Copyright © 2023 Graham James Addis <graham@addis.org.uk> +;;; Copyright © 2023 Oleg Pykhalov <go.wigust@gmail.com> ;;; ;;; This file is part of GNU Guix. ;;; @@ -47,6 +49,7 @@ #:use-module (guix scripts build) #:use-module (guix transformations) #:use-module ((guix self) #:select (make-config.scm)) + #:use-module ((guix docker) #:select (%docker-image-max-layers)) #:use-module (gnu compression) #:use-module (gnu packages) #:use-module (gnu packages bootstrap) @@ -137,7 +140,8 @@ dependencies are registered." ;; Make sure non-ASCII file names are properly handled. (setenv "GUIX_LOCPATH" - #+(file-append glibc-utf8-locales "/lib/locale")) + #+(file-append (libc-utf8-locales-for-target (%current-system)) + "/lib/locale")) (setlocale LC_ALL "en_US.utf8") (sql-schema #$schema) @@ -201,6 +205,16 @@ target the profile's @file{bin/env} file: (leave (G_ "~a: invalid symlink specification~%") arg)))) +(define (entry-point-argument-spec-option-parser opt name arg result) + "A SRFI-37 option parser for the --entry-point-argument option. The spec +takes multiple occurrences. The entries are used in the exec form for the +docker entry-point. The values are used as parameters in conjunction with the +--entry-point option which is used as the first value in the exec form." + (let ((entry-point-argument (assoc-ref result 'entry-point-argument))) + (alist-cons 'entry-point-argument + (append entry-point-argument (list arg)) + (alist-delete 'entry-point-argument result eq?)))) + (define (set-utf8-locale profile) "Configure the environment to use the \"en_US.utf8\" locale provided by the GLIBC-UT8-LOCALES package." @@ -209,7 +223,10 @@ GLIBC-UT8-LOCALES package." (profile-locales? profile)) #~(begin (setenv "GUIX_LOCPATH" - #+(file-append glibc-utf8-locales "/lib/locale")) + #+(file-append (let-system (system target) + (libc-utf8-locales-for-target + (or target system))) + "/lib/locale")) (setlocale LC_ALL "en_US.utf8")) #~(setenv "GUIX_LOCPATH" "unset for tests"))) @@ -502,12 +519,15 @@ added to the pack." localstatedir? (symlinks '()) (archiver tar) - (extra-options '())) - "Return a derivation to construct a Docker image of PROFILE. The -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. EXTRA-OPTIONS may contain the IMAGE-TAG keyword argument." + (extra-options '()) + max-layers) + "Return a derivation to construct a Docker image of PROFILE. The 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. EXTRA-OPTIONS may contain the IMAGE-TAG keyword argument. If +MAX-LAYERS is not false, the image will be splitted in up to MAX-LAYERS +layers." (define database (and localstatedir? (file-append (store-database (list profile)) @@ -558,10 +578,28 @@ the image. EXTRA-OPTIONS may contain the IMAGE-TAG keyword argument." `((directory "/tmp" ,(getuid) ,(getgid) #o1777) ,@(append-map symlink->directives '#$symlinks))) - (setenv "PATH" #+(file-append archiver "/bin")) + (define (form-entry-point prefix entry-point entry-point-argument) + ;; Construct entry-point parameter for build-docker-image. The + ;; first entry is constructed by prefixing the entry-point with + ;; the supplied index, subsequent entries are taken from the + ;; --entry-point-argument options. + (and=> entry-point + (lambda (entry-point) + (cons* (string-append prefix "/" entry-point) + entry-point-argument)))) + + (setenv "PATH" + (string-join `(#+(file-append archiver "/bin") + #+@(if max-layers + (list (file-append gzip "/bin")) + '())) + ":")) (let-keywords '#$extra-options #f - ((image-tag #f)) + ((image-tag #f) + (entry-point-argument '()) + (max-layers #f)) + (build-docker-image #$output (map store-info-item (call-with-input-file "profile" @@ -574,16 +612,16 @@ the image. EXTRA-OPTIONS may contain the IMAGE-TAG keyword argument." #:database #+database #:system (or #$target %host-type) #:environment environment - #:entry-point - #$(and entry-point - #~(list - (string-append #$profile "/" - #$entry-point))) + #:entry-point (form-entry-point + #$profile + #$entry-point + entry-point-argument) #:extra-files directives #:compressor #+(compressor-command compressor) #:creation-time - (make-time time-utc 0 1))))))) + (make-time time-utc 0 1) + #:max-layers max-layers)))))) (gexp->derivation (string-append name ".tar" (compressor-extension compressor)) @@ -1260,6 +1298,8 @@ last resort for relocation." (debug . 0) (verbosity . 1) (symlinks . ()) + (entry-point-argument . ()) + (max-layers . ,%docker-image-max-layers) (compressor . ,(first %compressors)))) (define %formats @@ -1295,7 +1335,13 @@ last resort for relocation." rest)))) (define %docker-format-options - (list (required-option 'image-tag))) + (list (required-option 'image-tag) + (option '(#\A "entry-point-argument") #t #f + entry-point-argument-spec-option-parser) + (option '("max-layers") #t #f + (lambda (opt name arg result) + (alist-cons 'max-layers (string->number* arg) + result))))) (define (show-docker-format-options) (display (G_ " @@ -1304,7 +1350,15 @@ last resort for relocation." (define (show-docker-format-options/detailed) (display (G_ " --image-tag=NAME - Use the given NAME for the Docker image repository")) + Use the given NAME for the Docker image repository + + -A, --entry-point-argument=COMMAND/PARAMETER + Value(s) to use for the Docker ENTRYPOINT arguments. + Multiple instances are accepted. This is only valid + in conjunction with the --entry-point option + + --max-layers=N + Number of image layers")) (newline) (exit 0)) @@ -1615,7 +1669,11 @@ Create a bundle of PACKAGE.\n")) (extra-options (match pack-format ('docker (list #:image-tag - (assoc-ref opts 'image-tag))) + (assoc-ref opts 'image-tag) + #:entry-point-argument + (assoc-ref opts 'entry-point-argument) + #:max-layers + (assoc-ref opts 'max-layers))) ('deb (list #:control-file (process-file-arg opts 'control-file) diff --git a/guix/scripts/shell.scm b/guix/scripts/shell.scm index 10ea110fee..0584a7e018 100644 --- a/guix/scripts/shell.scm +++ b/guix/scripts/shell.scm @@ -399,9 +399,16 @@ return #f and #f." ((('nesting? . #t) . rest) (loop rest system file (append specs '("nested guix")))) ((('load . ('package candidate)) . rest) + ;; This is 'guix shell -D -f guix.scm'. (if (and (not file) (null? specs)) (loop rest system candidate specs) (values #f #f))) + ((('load . ('ad-hoc-package candidate)) . rest) + ;; When running 'guix shell -f guix.scm', one typically expects + ;; 'guix.scm' to be evaluated every time because it may contain + ;; references like (local-file "." #:recursive? #t). Thus, disable + ;; caching. + (values #f #f)) ((('manifest . candidate) . rest) (if (and (not file) (null? specs)) (loop rest system candidate specs) diff --git a/guix/scripts/size.scm b/guix/scripts/size.scm index d26ed98388..8a8676a16f 100644 --- a/guix/scripts/size.scm +++ b/guix/scripts/size.scm @@ -317,7 +317,8 @@ Report the size of the PACKAGE or STORE-ITEM, with its dependencies.\n")) ;; Turn off grafts because (1) substitute servers do not serve grafted ;; packages, and (2) they do not make any difference on the ;; resulting size. - (parameterize ((%graft? #f)) + (parameterize ((%graft? #f) + (%current-system system)) (with-store store (set-build-options store #:use-substitutes? #t diff --git a/guix/scripts/style.scm b/guix/scripts/style.scm index 145cd09881..211980dc1c 100644 --- a/guix/scripts/style.scm +++ b/guix/scripts/style.scm @@ -625,6 +625,8 @@ Update package definitions to the latest style.\n")) opts))) (unless (eq? format-package-definition style) (warning (G_ "'--styling' option has no effect in whole-file mode~%"))) + (when (null? files) + (warning (G_ "no files specified, nothing to do~%"))) (for-each format-whole-file files)) (let ((packages (filter-map (match-lambda (('argument . spec) diff --git a/guix/scripts/substitute.scm b/guix/scripts/substitute.scm index 126f0f9c69..37cd08e289 100755 --- a/guix/scripts/substitute.scm +++ b/guix/scripts/substitute.scm @@ -635,8 +635,9 @@ way to download the nar." (let loop ((cache-urls cache-urls)) (match cache-urls (() - (leave (G_ "failed to find alternative substitute for '~a'~%") - (narinfo-path narinfo))) + (report-error (G_ "failed to find alternative substitute for '~a'~%") + (narinfo-path narinfo)) + (display "not-found\n" port)) ((cache-url rest ...) (match (lookup-narinfos cache-url (list (narinfo-path narinfo)) diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm index f85b663d64..bf3d2f9044 100644 --- a/guix/scripts/system.scm +++ b/guix/scripts/system.scm @@ -58,6 +58,7 @@ #:use-module (guix scripts system reconfigure) #:use-module (guix build utils) #:use-module (guix progress) + #:use-module ((guix docker) #:select (%docker-image-max-layers)) #:use-module (gnu build image) #:use-module (gnu build install) #:autoload (gnu build file-systems) @@ -1053,6 +1054,8 @@ Some ACTIONS support additional ARGS.\n")) (newline) (show-native-build-options-help) (newline) + (show-docker-format-options) + (newline) (display (G_ " -h, --help display this help and exit")) (display (G_ " @@ -1060,12 +1063,21 @@ Some ACTIONS support additional ARGS.\n")) (newline) (show-bug-report-information)) +(define %docker-format-options + (list (option '("max-layers") #t #f + (lambda (opt name arg result) + (alist-cons 'max-layers (string->number* arg) + result))))) + (define %options ;; Specifications of the command-line options. (cons* (option '(#\h "help") #f #f (lambda args (leave-on-EPIPE (show-help)) (exit 0))) + (option '("help-docker-format") #f #f + (lambda args + (show-docker-format-options/detailed))) (option '(#\V "version") #f #f (lambda args (show-version-and-exit "guix system"))) @@ -1154,7 +1166,8 @@ Some ACTIONS support additional ARGS.\n")) (alist-cons 'list-installed (or arg "") result))) (append %standard-build-options %standard-cross-build-options - %standard-native-build-options))) + %standard-native-build-options + %docker-format-options))) (define %default-options ;; Alist of default option values. @@ -1175,7 +1188,8 @@ Some ACTIONS support additional ARGS.\n")) (label . #f) (volatile-image-root? . #f) (volatile-vm-root? . #t) - (graph-backend . "graphviz"))) + (graph-backend . "graphviz") + (max-layers . ,%docker-image-max-layers))) (define (verbosity-level opts) "Return the verbosity level based on OPTS, the alist of parsed options." @@ -1183,6 +1197,17 @@ Some ACTIONS support additional ARGS.\n")) (if (eq? (assoc-ref opts 'action) 'build) 3 1))) +(define (show-docker-format-options) + (display (G_ " + --help-docker-format list options specific to the docker image type."))) + +(define (show-docker-format-options/detailed) + (display (G_ " + --max-layers=N + Number of image layers")) + (newline) + (exit 0)) + ;;; ;;; Entry point. @@ -1245,6 +1270,7 @@ resulting from command-line parsing." ((docker-image) docker-image-type) (else image-type))) (image-size (assoc-ref opts 'image-size)) + (image-max-layers (assoc-ref opts 'max-layers)) (volatile? (assoc-ref opts 'volatile-image-root?)) (shared-network? @@ -1258,6 +1284,7 @@ resulting from command-line parsing." (image-with-label base-image label) base-image)) (size image-size) + (max-layers image-max-layers) (volatile-root? volatile?) (shared-network? shared-network?)))) (os (or (image-operating-system image) diff --git a/guix/scripts/time-machine.scm b/guix/scripts/time-machine.scm index f31fae7435..2c30fe7cfd 100644 --- a/guix/scripts/time-machine.scm +++ b/guix/scripts/time-machine.scm @@ -46,12 +46,6 @@ #:use-module (srfi srfi-71) #:export (guix-time-machine)) -;;; The required inferiors mechanism relied on by 'guix time-machine' was -;;; firmed up in v1.0.0; it is the oldest, safest commit that can be travelled -;;; to. -(define %oldest-possible-commit - "6298c3ffd9654d3231a6f25390b056483e8f407c") ;v1.0.0 - ;;; ;;; Command-line options. @@ -146,6 +140,31 @@ Execute COMMAND ARGS... in an older version of Guix.\n")) ;;; +;;; Avoiding traveling too far back. +;;; + +;;; The required inferiors mechanism relied on by 'guix time-machine' was +;;; firmed up in v1.0.0; it is the oldest, safest commit that can be travelled +;;; to. +(define %oldest-possible-commit + "6298c3ffd9654d3231a6f25390b056483e8f407c") ;v1.0.0 + +(define %reference-channels + (list (channel (inherit %default-guix-channel) + (commit %oldest-possible-commit)))) + +(define (validate-guix-channel channel start commit relation) + "Raise an error if CHANNEL is the 'guix' channel and the RELATION of COMMIT +to %OLDEST-POSSIBLE-COMMIT is not that of an ancestor." + (unless (or (not (guix-channel? channel)) + (memq relation '(ancestor self))) + (raise (formatted-message + (G_ "cannot travel past commit `~a' from May 1st, 2019") + (string-take %oldest-possible-commit 12))))) + + + +;;; ;;; Entry point. ;;; @@ -160,44 +179,22 @@ Execute COMMAND ARGS... in an older version of Guix.\n")) (ref (assoc-ref opts 'ref)) (substitutes? (assoc-ref opts 'substitutes?)) (authenticate? (assoc-ref opts 'authenticate-channels?))) - - (define (validate-guix-channel channels) - "Finds the Guix channel among CHANNELS, and validates that REF as -captured from the closure, a git reference specification such as a commit hash -or tag associated to the channel, is valid and new enough to satisfy the 'guix -time-machine' requirements. If the captured REF variable is #f, the reference -validate is the one of the Guix channel found in CHANNELS. A -`formatted-message' condition is raised otherwise." - (let* ((guix-channel (find guix-channel? channels)) - (guix-channel-commit (channel-commit guix-channel)) - (guix-channel-branch (channel-branch guix-channel)) - (guix-channel-ref (if guix-channel-commit - `(tag-or-commit . ,guix-channel-commit) - `(branch . ,guix-channel-branch))) - (reference (or ref guix-channel-ref)) - (checkout commit relation (update-cached-checkout - (channel-url guix-channel) - #:ref reference - #:starting-commit - %oldest-possible-commit))) - (unless (memq relation '(ancestor self)) - (raise (formatted-message - (G_ "cannot travel past commit `~a' from May 1st, 2019") - (string-take %oldest-possible-commit 12)))))) - - (when command-line - (let* ((directory - (with-store store - (with-status-verbosity (assoc-ref opts 'verbosity) - (with-build-handler (build-notifier #:use-substitutes? - substitutes? - #:verbosity - (assoc-ref opts 'verbosity) - #:dry-run? #f) - (set-build-options-from-command-line store opts) - (cached-channel-instance store channels - #:authenticate? authenticate? - #:validate-channels - validate-guix-channel))))) - (executable (string-append directory "/bin/guix"))) - (apply execl (cons* executable executable command-line)))))))) + (if command-line + (let* ((directory + (with-store store + (with-status-verbosity (assoc-ref opts 'verbosity) + (with-build-handler (build-notifier #:use-substitutes? + substitutes? + #:verbosity + (assoc-ref opts 'verbosity) + #:dry-run? #f) + (set-build-options-from-command-line store opts) + (cached-channel-instance store channels + #:authenticate? authenticate? + #:reference-channels + %reference-channels + #:validate-channels + validate-guix-channel))))) + (executable (string-append directory "/bin/guix"))) + (apply execl (cons* executable executable command-line))) + (warning (G_ "no command specified; nothing to do~%"))))))) diff --git a/guix/scripts/weather.scm b/guix/scripts/weather.scm index 140df3435f..2f8985593d 100644 --- a/guix/scripts/weather.scm +++ b/guix/scripts/weather.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2017-2022 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2017-2023 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2017 Ricardo Wurmus <rekado@elephly.net> ;;; Copyright © 2018 Kyle Meyer <kyle@kyleam.com> ;;; Copyright © 2020 Simon Tournier <zimon.toutoune@gmail.com> @@ -35,6 +35,8 @@ #:use-module ((guix build utils) #:select (every*)) #:use-module (guix substitutes) #:use-module (guix narinfo) + #:use-module (guix pki) + #:autoload (gcrypt pk-crypto) (canonical-sexp->string) #:use-module (guix http-client) #:use-module (guix ci) #:use-module (guix sets) @@ -185,6 +187,44 @@ or #f if it could not be determined." (() #f))) +(define (check-narinfo-authorization narinfo) + "Print a warning when NARINFO is not signed by an authorized key." + (define acl + (catch 'system-error + (lambda () + (current-acl)) + (lambda args + (warning (G_ "could not read '~a': ~a~%") + %acl-file (strerror (system-error-errno args))) + (warning (G_ "'~a' is unreadable, cannot determine whether \ +substitutes are authorized~%") + %acl-file) + #f))) + + (unless (or (not acl) (valid-narinfo? narinfo acl)) + (warning (G_ "substitutes from '~a' are unauthorized~%") + (narinfo-uri-base narinfo)) + ;; The "all substitutes" below reflects the fact that, in reality, it *is* + ;; possible to download "unauthorized" substitutes, as long as they match + ;; authorized substitutes. + (display-hint (G_ "To authorize all substitutes from @uref{~a} to be +downloaded, the following command needs to be run as root: + +@example +guix archive --authorize <<EOF +~a +EOF +@end example + +Alternatively, on Guix System, you can add the signing key above to the +@code{authorized-keys} field of @code{guix-configuration}. + +See \"Getting Substitutes from Other Servers\" in the manual for more +information.") + (narinfo-uri-base narinfo) + (canonical-sexp->string + (signature-subject (narinfo-signature narinfo)))))) + (define* (report-server-coverage server items #:key display-missing?) "Report the subset of ITEMS available as substitutes on SERVER. @@ -204,6 +244,12 @@ In case ITEMS is an empty list, return 1 instead." #:make-progress-reporter (lambda* (total #:key url #:allow-other-keys) (progress-reporter/bar total))))) + (match narinfos + (() #f) + ((narinfo . _) + ;; Help diagnose missing substitute authorizations. + (check-narinfo-authorization narinfo))) + (let ((obtained (length narinfos)) (requested (length items)) (missing (lset-difference string=? @@ -391,7 +437,7 @@ Report the availability of substitutes.\n")) %standard-native-build-options)) (define %default-options - `((substitute-urls . ,%default-substitute-urls))) + '()) (define (load-manifest file) "Load the manifest from FILE and return the list of packages it refers to." @@ -582,7 +628,16 @@ SERVER. Display information for packages with at least THRESHOLD dependents." (let* ((opts (parse-command-line args %options (list %default-options) #:build-options? #f)) - (urls (assoc-ref opts 'substitute-urls)) + (urls (or (assoc-ref opts 'substitute-urls) + (with-store store + (substitute-urls store)) + (begin + ;; Could not determine the daemon's current + ;; substitute URLs, presumably because it's too + ;; old. + (warning (G_ "using default \ +substitute URLs~%")) + %default-substitute-urls))) (systems (match (filter-map (match-lambda (('system . system) system) (_ #f)) |