diff options
| author | Maxim Cournoyer <maxim.cournoyer@gmail.com> | 2020-09-14 16:17:19 -0400 |
|---|---|---|
| committer | Maxim Cournoyer <maxim.cournoyer@gmail.com> | 2020-09-14 16:17:19 -0400 |
| commit | fa8fe90edb4efaf7d52f71516c4dcabb13d56418 (patch) | |
| tree | 8d69a1132e95845d8a3d90f1fe4d0ef04039e2f4 /guix | |
| parent | 1bec03df9b60f156c657a64a323ef27f4ed14b44 (diff) | |
| parent | d60739dff2e2f5eb74173b73a5fd207ef7cd110a (diff) | |
| download | guix-patches-fa8fe90edb4efaf7d52f71516c4dcabb13d56418.tar guix-patches-fa8fe90edb4efaf7d52f71516c4dcabb13d56418.tar.gz | |
Merge remote-tracking branch 'origin/master' into core-updates
Diffstat (limited to 'guix')
62 files changed, 1082 insertions, 428 deletions
diff --git a/guix/android-repo-download.scm b/guix/android-repo-download.scm new file mode 100644 index 0000000000..5ff3e7edd4 --- /dev/null +++ b/guix/android-repo-download.scm @@ -0,0 +1,156 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2014, 2015, 2016, 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2017 Mathieu Lirzin <mthl@gnu.org> +;;; Copyright © 2017 Christopher Baines <mail@cbaines.net> +;;; Copyright © 2020 Jakub Kądziołka <kuba@kadziolka.net> +;;; Copyright © 2020 Danny Milosavljevic <dannym@scratchpost.org> +;;; +;;; 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 android-repo-download) + #:use-module (guix gexp) + #:use-module (guix store) + #:use-module (guix monads) + #:use-module (guix records) + #:use-module (guix packages) + #:use-module (guix modules) + #:autoload (guix build-system gnu) (standard-packages) + #:use-module (ice-9 match) + #:use-module (ice-9 vlist) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-34) + #:use-module (srfi srfi-35) + #:export (android-repo-reference + android-repo-reference? + android-repo-reference-manifest-url + android-repo-reference-revision + + android-repo-fetch + android-repo-version + android-repo-file-name)) + +;;; Commentary: +;;; +;;; An <origin> method that fetches a specific commit from an Android repo +;;; repository. +;;; The repository's manifest (URL and revision) can be specified with a +;;; <android-repo-reference> object. +;;; +;;; Code: + +(define-record-type* <android-repo-reference> + android-repo-reference make-android-repo-reference + android-repo-reference? + (manifest-url android-repo-reference-manifest-url) + (manifest-revision android-repo-reference-manifest-revision)) + +(define (git-repo-package) + "Return the default git-repo package." + (let ((distro (resolve-interface '(gnu packages android)))) + (module-ref distro 'git-repo))) + +(define* (android-repo-fetch ref hash-algo hash + #:optional name + #:key (system (%current-system)) + (guile (default-guile)) + (git-repo (git-repo-package))) + "Return a fixed-output derivation that fetches REF, an +<android-repo-reference> object. The output is expected to have recursive +hash HASH of type HASH-ALGO (a symbol). Use NAME as the file name, or a +generic name if unset." + ;; TODO: Remove. + (define inputs + (standard-packages)) + + (define zlib + (module-ref (resolve-interface '(gnu packages compression)) 'zlib)) + + (define gnutls + (module-ref (resolve-interface '(gnu packages tls)) 'gnutls)) + + (define config.scm + (scheme-file "config.scm" + #~(begin + (define-module (guix config) + #:export (%libz)) + + (define %libz + #+(file-append zlib "/lib/libz"))))) + + (define modules + (cons `((guix config) => ,config.scm) + (delete '(guix config) + (source-module-closure '((guix build android-repo) + (guix build utils) + (guix build download-nar)))))) + + (define build + (with-imported-modules modules + (with-extensions (list gnutls) + #~(begin + (use-modules (guix build android-repo) + (guix build utils) + (guix build download-nar) + (ice-9 match)) + + ;; The 'git submodule' commands expects Coreutils, sed, + ;; grep, etc. to be in $PATH. + (set-path-environment-variable "PATH" '("bin") + (match '#+inputs + (((names dirs outputs ...) ...) + dirs))) + + (setvbuf (current-output-port) 'line) + (setvbuf (current-error-port) 'line) + + (or (android-repo-fetch (getenv "android-repo manifest-url") + (getenv "android-repo manifest-revision") + #$output + #:git-repo-command + (string-append #+git-repo "/bin/repo")) + (download-nar #$output)))))) + + (mlet %store-monad ((guile (package->derivation guile system))) + (gexp->derivation (or name "android-repo-checkout") build + + ;; Use environment variables and a fixed script name so + ;; there's only one script in store for all the + ;; downloads. + #:script-name "android-repo-download" + #:env-vars + `(("android-repo manifest-url" . + ,(android-repo-reference-manifest-url ref)) + ("android-repo manifest-revision" . + ,(android-repo-reference-manifest-revision ref))) + #:leaked-env-vars '("http_proxy" "https_proxy" + "LC_ALL" "LC_MESSAGES" "LANG" + "COLUMNS") + #:system system + #:local-build? #t ;don't offload repo cloning + #:hash-algo hash-algo + #:hash hash + #:recursive? #t + #:guile-for-build guile))) + +(define (android-repo-version version revision) + "Return the version string for packages using android-repo-download." + (string-append version "-" (string-join (string-split revision #\/) "_"))) + +(define (android-repo-file-name name version) + "Return the file-name for packages using android-repo-download." + (string-append name "-" version "-checkout")) + + diff --git a/guix/build-system/linux-module.scm b/guix/build-system/linux-module.scm index 1077215671..fc3d959ce7 100644 --- a/guix/build-system/linux-module.scm +++ b/guix/build-system/linux-module.scm @@ -68,14 +68,41 @@ (lambda* (#:key inputs outputs #:allow-other-keys) (let* ((out (assoc-ref outputs "out")) (out-lib-build (string-append out "/lib/modules/build"))) + ;; Delete some huge items that we probably don't need. ;; TODO: Only preserve the minimum, i.e. [Kbuild], Kconfig, ;; scripts, include, ".config". (copy-recursively "." out-lib-build) + (for-each (lambda (name) + (when (file-exists? name) + (delete-file-recursively name))) + (map (lambda (name) + (string-append out-lib-build "/" name)) + '("arch" ; 137 MB + ;"tools" ; 44 MB ; Note: is built by our 'build phase. + "tools/testing" ; 14 MB + "tools/perf" ; 17 MB + "drivers" ; 600 MB + "Documentation" ; 52 MB + "fs" ; 43 MB + "net" ; 33 MB + "samples" ; 2 MB + "sound"))) ; 40 MB + ;; Reinstate arch/**/dts since "scripts/dtc" depends on it. + ;; Reinstate arch/**/include directories. + ;; Reinstate arch/**/Makefile. + ;; Reinstate arch/**/module.lds. + (for-each + (lambda (name) + (mkdir-p (dirname (string-append out-lib-build "/" name))) + (copy-recursively name + (string-append out-lib-build "/" name))) + (append (find-files "arch" "^(dts|include)$" #:directories? #t) + (find-files "arch" "^(Makefile|module.lds)$"))) (let* ((linux (assoc-ref inputs "linux"))) (install-file (string-append linux "/System.map") out-lib-build) (let ((source (string-append linux "/Module.symvers"))) - (if (file-exists? source) + (when (file-exists? source) (install-file source out-lib-build)))) #t))))))))) diff --git a/guix/build/android-repo.scm b/guix/build/android-repo.scm new file mode 100644 index 0000000000..db8c4d127b --- /dev/null +++ b/guix/build/android-repo.scm @@ -0,0 +1,75 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2014, 2016, 2019 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2020 Danny Milosavljevic <dannym@scratchpost.org> +;;; +;;; 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 android-repo) + #:use-module (guix build utils) + #:use-module (srfi srfi-34) + #:use-module (ice-9 format) + #:export (android-repo-fetch)) + +;;; Commentary: +;;; +;;; This is the build-side support code of (guix android-repo-download). +;;; It allows a multirepository managed by the git-repo tool to be cloned and +;;; checked out at a specific revision. +;;; +;;; Code: + +(define* (android-repo-fetch manifest-url manifest-revision directory + #:key (git-repo-command "git-repo")) + "Fetch packages according to the manifest at MANIFEST-URL with +MANIFEST-REVISION. MANIFEST-REVISION must be either a revision +or a branch. Return #t on success, #f otherwise." + + ;; Disable TLS certificate verification. The hash of the checkout is known + ;; in advance anyway. + (setenv "GIT_SSL_NO_VERIFY" "true") + + (mkdir-p directory) + + (guard (c ((invoke-error? c) + (format (current-error-port) + "android-repo-fetch: '~a~{ ~a~}' failed with exit code ~a~%" + (invoke-error-program c) + (invoke-error-arguments c) + (or (invoke-error-exit-status c) ;XXX: not quite accurate + (invoke-error-stop-signal c) + (invoke-error-term-signal c))) + (delete-file-recursively directory) + #f)) + (with-directory-excursion directory + (invoke git-repo-command "init" "-u" manifest-url "-b" manifest-revision + "--depth=1") + (invoke git-repo-command "sync" "-c" "--fail-fast" "-v" "-j" + (number->string (parallel-job-count))) + + ;; Delete vendor/**/.git, system/**/.git, toolchain/**/.git, + ;; .repo/**/.git etc since they contain timestamps. + (for-each delete-file-recursively + (find-files "." "^\\.git$" #:directories? #t)) + + ;; Delete git state directories since they contain timestamps. + (for-each delete-file-recursively + (find-files ".repo" "^.*\\.git$" #:directories? #t)) + + ;; This file contains timestamps. + (delete-file ".repo/.repo_fetchtimes.json") + #t))) + +;;; android-repo.scm ends here diff --git a/guix/ci.scm b/guix/ci.scm index 02eb90e6c3..7a03befc7c 100644 --- a/guix/ci.scm +++ b/guix/ci.scm @@ -19,7 +19,6 @@ (define-module (guix ci) #:use-module (guix http-client) - #:use-module (guix json) #:use-module (json) #:use-module (srfi srfi-1) #:use-module (ice-9 match) diff --git a/guix/cve.scm b/guix/cve.scm index ae9cca2341..57b8459d01 100644 --- a/guix/cve.scm +++ b/guix/cve.scm @@ -19,7 +19,6 @@ (define-module (guix cve) #:use-module (guix utils) #:use-module (guix http-client) - #:use-module (guix json) #:use-module (guix i18n) #:use-module ((guix diagnostics) #:select (formatted-message)) #:use-module (json) diff --git a/guix/derivations.scm b/guix/derivations.scm index 7db61d272f..2fe684cc18 100644 --- a/guix/derivations.scm +++ b/guix/derivations.scm @@ -26,6 +26,7 @@ #:use-module (srfi srfi-34) #:use-module (srfi srfi-35) #:use-module (ice-9 binary-ports) + #:use-module ((ice-9 textual-ports) #:select (put-char put-string)) #:use-module (rnrs bytevectors) #:use-module (ice-9 match) #:use-module (ice-9 rdelim) @@ -561,33 +562,65 @@ things as appropriate and is thus more efficient." ((prefix (... ...) last) (for-each (lambda (item) (write-item item port) - (display "," port)) + (put-char port #\,)) prefix) (write-item last port)))) (define-inlinable (write-list lst write-item port) ;; Write LST as a derivation list to PORT, using WRITE-ITEM to write each ;; element. - (display "[" port) + (put-char port #\[) (write-sequence lst write-item port) - (display "]" port)) + (put-char port #\])) (define-inlinable (write-tuple lst write-item port) ;; Same, but write LST as a tuple. - (display "(" port) + (put-char port #\() (write-sequence lst write-item port) - (display ")" port)) + (put-char port #\))) + +(define %escape-char-set + ;; Characters that need to be escaped. + (char-set #\" #\\ #\newline #\return #\tab)) + +(define (escaped-string str) + "Escape double quote characters found in STR, if any." + (define escape + (match-lambda + (#\" "\\\"") + (#\\ "\\\\") + (#\newline "\\n") + (#\return "\\r") + (#\tab "\\t"))) + + (let loop ((str str) + (result '())) + (let ((index (string-index str %escape-char-set))) + (if index + (let ((rest (string-drop str (+ 1 index)))) + (loop rest + (cons* (escape (string-ref str index)) + (string-take str index) + result))) + (if (null? result) + str + (string-concatenate-reverse (cons str result))))))) (define (write-derivation drv port) "Write the ATerm-like serialization of DRV to PORT. See Section 2.4 of Eelco Dolstra's PhD dissertation for an overview of a previous version of that form." - ;; Make sure we're using the faster implementation. - (define format simple-format) + ;; Use 'put-string', which does less work and is faster than 'display'. + ;; Likewise, 'write-escaped-string' is faster than 'write'. + + (define (write-escaped-string str port) + (put-char port #\") + (put-string port (escaped-string str)) + (put-char port #\")) (define (write-string-list lst) - (write-list lst write port)) + (write-list lst write-escaped-string port)) (define (write-output output port) (match output @@ -599,48 +632,47 @@ that form." "") (or (and=> hash bytevector->base16-string) "")) - write + write-escaped-string port)))) (define (write-input input port) (match input (($ <derivation-input> obj sub-drvs) - (display "(\"" port) + (put-string port "(\"") ;; 'derivation/masked-inputs' produces objects that contain a string ;; instead of a <derivation>, so we need to account for that. - (display (if (derivation? obj) - (derivation-file-name obj) - obj) - port) - (display "\"," port) + (put-string port (if (derivation? obj) + (derivation-file-name obj) + obj)) + (put-string port "\",") (write-string-list sub-drvs) - (display ")" port)))) + (put-char port #\))))) (define (write-env-var env-var port) (match env-var ((name . value) - (display "(" port) - (write name port) - (display "," port) - (write value port) - (display ")" port)))) + (put-char port #\() + (write-escaped-string name port) + (put-char port #\,) + (write-escaped-string value port) + (put-char port #\))))) ;; Assume all the lists we are writing are already sorted. (match drv (($ <derivation> outputs inputs sources system builder args env-vars) - (display "Derive(" port) + (put-string port "Derive(") (write-list outputs write-output port) - (display "," port) + (put-char port #\,) (write-list inputs write-input port) - (display "," port) + (put-char port #\,) (write-string-list sources) (simple-format port ",\"~a\",\"~a\"," system builder) (write-string-list args) - (display "," port) + (put-char port #\,) (write-list env-vars write-env-var port) - (display ")" port)))) + (put-char port #\))))) (define derivation->bytevector (lambda (drv) diff --git a/guix/gexp.scm b/guix/gexp.scm index 7132ca899b..a8d890ccd2 100644 --- a/guix/gexp.scm +++ b/guix/gexp.scm @@ -3,6 +3,7 @@ ;;; Copyright © 2018 Clément Lassieur <clement@lassieur.org> ;;; Copyright © 2018 Jan Nieuwenhuizen <janneke@gnu.org> ;;; Copyright © 2019, 2020 Mathieu Othacehe <m.othacehe@gmail.com> +;;; Copyright © 2020 Maxim Cournoyer <maxim.cournoyer@gmail.com> ;;; ;;; This file is part of GNU Guix. ;;; @@ -504,13 +505,15 @@ This is the declarative counterpart of 'text-file'." (options computed-file-options)) ;list of arguments (define* (computed-file name gexp - #:key guile (options '(#:local-build? #t))) + #:key guile (local-build? #t) (options '())) "Return an object representing the store item NAME, a file or directory -computed by GEXP. OPTIONS is a list of additional arguments to pass -to 'gexp->derivation'. +computed by GEXP. When LOCAL-BUILD? is #t (the default), it ensures the +corresponding derivation is built locally. OPTIONS may be used to pass +additional arguments to 'gexp->derivation'. This is the declarative counterpart of 'gexp->derivation'." - (%computed-file name gexp guile options)) + (let ((options* `(#:local-build? ,local-build? ,@options))) + (%computed-file name gexp guile options*))) (define-gexp-compiler (computed-file-compiler (file <computed-file>) system target) diff --git a/guix/git-download.scm b/guix/git-download.scm index 90634a8c4c..8e575e3b5f 100644 --- a/guix/git-download.scm +++ b/guix/git-download.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2014, 2015, 2016, 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2014, 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2017 Mathieu Lirzin <mthl@gnu.org> ;;; Copyright © 2017 Christopher Baines <mail@cbaines.net> ;;; Copyright © 2020 Jakub Kądziołka <kuba@kadziolka.net> @@ -85,7 +85,7 @@ HASH-ALGO (a symbol). Use NAME as the file name, or a generic name if #f." 'tar))))) (define guile-json - (module-ref (resolve-interface '(gnu packages guile)) 'guile-json-3)) + (module-ref (resolve-interface '(gnu packages guile)) 'guile-json-4)) (define guile-zlib (module-ref (resolve-interface '(gnu packages guile)) 'guile-zlib)) diff --git a/guix/git.scm b/guix/git.scm index 7f8f9addfb..637936c16a 100644 --- a/guix/git.scm +++ b/guix/git.scm @@ -39,6 +39,7 @@ #:export (%repository-cache-directory honor-system-x509-certificates! + url-cache-directory with-repository with-git-error-handling false-if-git-not-found diff --git a/guix/import/cpan.scm b/guix/import/cpan.scm index 085467b871..fd940415a2 100644 --- a/guix/import/cpan.scm +++ b/guix/import/cpan.scm @@ -28,7 +28,6 @@ #:use-module (srfi srfi-1) #:use-module (srfi srfi-26) #:use-module (json) - #:use-module (guix json) #:use-module (gcrypt hash) #:use-module (guix store) #:use-module (guix utils) diff --git a/guix/import/crate.scm b/guix/import/crate.scm index 796a7641e9..f87c89163c 100644 --- a/guix/import/crate.scm +++ b/guix/import/crate.scm @@ -24,7 +24,6 @@ #:use-module ((guix download) #:prefix download:) #:use-module (gcrypt hash) #:use-module (guix http-client) - #:use-module (guix json) #:use-module (guix import json) #:use-module (guix import utils) #:use-module ((guix licenses) #:prefix license:) diff --git a/guix/import/gem.scm b/guix/import/gem.scm index a2d99ddbca..3fe240f36a 100644 --- a/guix/import/gem.scm +++ b/guix/import/gem.scm @@ -22,7 +22,7 @@ (define-module (guix import gem) #:use-module (ice-9 match) #:use-module (srfi srfi-1) - #:use-module (guix json) + #:use-module (json) #:use-module ((guix download) #:prefix download:) #:use-module (guix import utils) #:use-module (guix import json) diff --git a/guix/import/launchpad.scm b/guix/import/launchpad.scm index c7375837c7..fd3cfa8444 100644 --- a/guix/import/launchpad.scm +++ b/guix/import/launchpad.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2019 Arun Isaac <arunisaac@systemreboot.net> +;;; Copyright © 2019, 2020 Arun Isaac <arunisaac@systemreboot.net> ;;; ;;; This file is part of GNU Guix. ;;; @@ -32,7 +32,7 @@ "Return the extension of the archive e.g. '.tar.gz' given a URL, or false if none is recognized" (find (lambda (x) (string-suffix? x url)) - (list ".tar.gz" ".tar.bz2" ".tar.xz" + (list ".orig.tar.gz" ".tar.gz" ".tar.bz2" ".tar.xz" ".zip" ".tar" ".tgz" ".tbz" ".love"))) (define (updated-launchpad-url old-package new-version) @@ -46,15 +46,35 @@ false if none is recognized" (version (package-version old-package)) (repo (launchpad-repository url))) (cond - ((and - (>= (length (string-split version #\.)) 2) - (string=? (string-append "https://launchpad.net/" - repo "/" (version-major+minor version) - "/" version "/+download/" repo "-" version ext) - url)) + ((< (length (string-split version #\.)) 2) #f) + ((string=? (string-append "https://launchpad.net/" + repo "/" (version-major+minor version) + "/" version "/+download/" repo "-" version ext) + url) (string-append "https://launchpad.net/" repo "/" (version-major+minor new-version) "/" new-version "/+download/" repo "-" new-version ext)) + ((string=? (string-append "https://launchpad.net/" + repo "/" (version-major+minor version) + "/" version "/+download/" repo "_" version ext) + url) + (string-append "https://launchpad.net/" + repo "/" (version-major+minor new-version) + "/" new-version "/+download/" repo "-" new-version ext)) + ((string=? (string-append "https://launchpad.net/" + repo "/trunk/" version "/+download/" + repo "-" version ext) + url) + (string-append "https://launchpad.net/" + repo "/trunk/" new-version + "/+download/" repo "-" new-version ext)) + ((string=? (string-append "https://launchpad.net/" + repo "/trunk/" version "/+download/" + repo "_" version ext) + url) + (string-append "https://launchpad.net/" + repo "/trunk/" new-version + "/+download/" repo "_" new-version ext)) (#t #f))))) ; Some URLs are not recognised. (match (package-source old-package) @@ -66,7 +86,7 @@ false if none is recognized" ((? string?) (updated-url source-uri)) ((source-uri ...) - (find updated-url source-uri)))))) + (any updated-url source-uri)))))) (_ #f))) (define (launchpad-package? package) diff --git a/guix/import/pypi.scm b/guix/import/pypi.scm index a4a2489688..15116e349d 100644 --- a/guix/import/pypi.scm +++ b/guix/import/pypi.scm @@ -46,7 +46,7 @@ #:use-module (guix import utils) #:use-module ((guix download) #:prefix download:) #:use-module (guix import json) - #:use-module (guix json) + #:use-module (json) #:use-module (guix packages) #:use-module (guix upstream) #:use-module ((guix licenses) #:prefix license:) diff --git a/guix/json.scm b/guix/json.scm deleted file mode 100644 index 3e3a28b749..0000000000 --- a/guix/json.scm +++ /dev/null @@ -1,83 +0,0 @@ -;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org> -;;; -;;; 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 json) - #:use-module (json) - #:use-module (srfi srfi-9)) - -;;; Commentary: -;;; -;;; Helpers to map JSON objects to SRFI-9 records. Taken from (guix swh). -;;; This module is superseded by 'define-json-mapping' as found since version -;;; 4.2.0 of Guile-JSON and will be removed once migration is complete. -;;; -;;; Code: - -(define-syntax define-as-needed - (lambda (s) - "Define the given syntax rule unless (json) already provides it." - (syntax-case s () - ((_ (macro args ...) body ...) - (if (module-defined? (resolve-interface '(json)) - (syntax->datum #'macro)) - #'(eval-when (expand load eval) - ;; Re-export MACRO from (json). - (module-re-export! (current-module) '(macro))) - #'(begin - ;; Using Guile-JSON < 4.2.0, so provide our own MACRO. - (define-syntax-rule (macro args ...) - body ...) - (eval-when (expand load eval) - (module-export! (current-module) '(macro))))))))) - -(define-syntax-rule (define-json-reader json->record ctor spec ...) - "Define JSON->RECORD as a procedure that converts a JSON representation, -read from a port, string, or hash table, into a record created by CTOR and -following SPEC, a series of field specifications." - (define (json->record input) - (let ((table (cond ((port? input) - (json->scm input)) - ((string? input) - (json-string->scm input)) - ((or (null? input) (pair? input)) - input)))) - (let-syntax ((extract-field (syntax-rules () - ((_ table (field key json->value)) - (json->value (assoc-ref table key))) - ((_ table (field key)) - (assoc-ref table key)) - ((_ table (field)) - (assoc-ref table - (symbol->string 'field)))))) - (ctor (extract-field table spec) ...))))) - -;; For some reason we cannot just have colliding definitions of -;; 'define-json-mapping' (that leads to a build failure in users of this -;; module), hence the use of 'define-as-needed'. -(define-as-needed (define-json-mapping rtd ctor pred json->record - (field getter spec ...) ...) - "Define RTD as a record type with the given FIELDs and GETTERs, à la SRFI-9, -and define JSON->RECORD as a conversion from JSON to a record of this type." - (begin - (define-record-type rtd - (ctor field ...) - pred - (field getter) ...) - - (define-json-reader json->record ctor - (field spec ...) ...))) diff --git a/guix/nar.scm b/guix/nar.scm index 6bb2ea5b96..a23af2e5de 100644 --- a/guix/nar.scm +++ b/guix/nar.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2018, 2019 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2014 Mark H Weaver <mhw@netris.org> ;;; ;;; This file is part of GNU Guix. @@ -156,7 +156,8 @@ protected from GC." (define* (restore-one-item port #:key acl (verify-signature? #t) (lock? #t) (log-port (current-error-port))) - "Restore one store item from PORT; return its file name on success." + "Restore one store item of a nar bundle read from PORT; return its file name +on success." (define (assert-valid-signature signature hash file) ;; Bail out if SIGNATURE, which must be a string as produced by @@ -251,11 +252,11 @@ a signature")) (define* (restore-file-set port #:key (verify-signature? #t) (lock? #t) (log-port (current-error-port))) - "Restore the file set read from PORT to the store. The format of the data -on PORT must be as created by 'export-paths'---i.e., a series of Nar-formatted -archives with interspersed meta-data joining them together, possibly with a -digital signature at the end. Log progress to LOG-PORT. Return the list of -files restored. + "Restore the file set (\"nar bundle\") read from PORT to the store. The +format of the data on PORT must be as created by 'export-paths'---i.e., a +series of Nar-formatted archives with interspersed meta-data joining them +together, possibly with a digital signature at the end. Log progress to +LOG-PORT. Return the list of files restored. When LOCK? is #f, assume locks for the files to be restored are already held. This is the case when the daemon calls a build hook. diff --git a/guix/packages.scm b/guix/packages.scm index 95d7c2cc0d..6598bd3149 100644 --- a/guix/packages.scm +++ b/guix/packages.scm @@ -228,7 +228,8 @@ as base32. Otherwise, it must be a bytevector." (define (print-content-hash hash port) (format port "#<content-hash ~a:~a>" (content-hash-algorithm hash) - (bytevector->nix-base32-string (content-hash-value hash)))) + (and=> (content-hash-value hash) + bytevector->nix-base32-string))) (set-record-type-printer! <content-hash> print-content-hash) diff --git a/guix/scripts.scm b/guix/scripts.scm index 8534948892..9792aaebe9 100644 --- a/guix/scripts.scm +++ b/guix/scripts.scm @@ -34,7 +34,12 @@ #:use-module (srfi srfi-19) #:use-module (srfi srfi-37) #:use-module (ice-9 match) - #:export (args-fold* + #:export (synopsis + category + define-command + %command-categories + + args-fold* parse-command-line maybe-build build-package @@ -50,6 +55,61 @@ ;;; ;;; Code: +;; Syntactic keywords. +(define synopsis 'command-synopsis) +(define category 'command-category) + +(define-syntax define-command-categories + (syntax-rules (G_) + "Define command categories." + ((_ name assert-valid (identifiers (G_ synopses)) ...) + (begin + (define-public identifiers + ;; Define and export syntactic keywords. + (list 'syntactic-keyword-for-command-category)) + ... + + (define-syntax assert-valid + ;; Validate at expansion time that we're passed a valid category. + (syntax-rules (identifiers ...) + ((_ identifiers) #t) + ...)) + + (define name + ;; Alist mapping category name to synopsis. + `((identifiers . synopses) ...)))))) + +;; Command categories. +(define-command-categories %command-categories + assert-valid-command-category + (main (G_ "main commands")) + (development (G_ "software development commands")) + (packaging (G_ "packaging commands")) + (plumbing (G_ "plumbing commands")) + (internal (G_ "internal commands"))) + +(define-syntax define-command + (syntax-rules (category synopsis) + "Define the given command as a procedure along with its synopsis and, +optionally, its category. The synopsis becomes the docstring of the +procedure, but both the category and synopsis are meant to be read (parsed) by +'guix help'." + ;; The (synopsis ...) form is here so that xgettext sees those strings as + ;; translatable. + ((_ (name . args) + (synopsis doc) body ...) + (define (name . args) + doc + body ...)) + ((_ (name . args) + (category cat) (synopsis doc) + body ...) + (begin + (assert-valid-command-category cat) + (define (name . args) + doc + body ...))))) + (define (args-fold* args options unrecognized-option-proc operand-proc . seeds) "A wrapper on top of `args-fold' that does proper user-facing error reporting." diff --git a/guix/scripts/archive.scm b/guix/scripts/archive.scm index f3b86fba14..02557ce454 100644 --- a/guix/scripts/archive.scm +++ b/guix/scripts/archive.scm @@ -355,7 +355,10 @@ output port." ;;; Entry point. ;;; -(define (guix-archive . args) +(define-command (guix-archive . args) + (category plumbing) + (synopsis "manipulate, export, and import normalized archives (nars)") + (define (lines port) ;; Return lines read from PORT. (let loop ((line (read-line port)) diff --git a/guix/scripts/authenticate.scm b/guix/scripts/authenticate.scm index f1fd8ee895..0bac13edee 100644 --- a/guix/scripts/authenticate.scm +++ b/guix/scripts/authenticate.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2013, 2014, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2020 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -17,14 +17,20 @@ ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. (define-module (guix scripts authenticate) - #:use-module (guix config) + #:use-module (guix scripts) #:use-module (guix base16) #:use-module (gcrypt pk-crypto) #:use-module (guix pki) #:use-module (guix ui) + #:use-module (guix diagnostics) + #:use-module (srfi srfi-34) + #:use-module (srfi srfi-35) + #:use-module (srfi srfi-71) + #:use-module (rnrs bytevectors) #:use-module (ice-9 binary-ports) #:use-module (ice-9 rdelim) #:use-module (ice-9 match) + #:use-module (ice-9 vlist) #:export (guix-authenticate)) ;;; Commentary: @@ -39,58 +45,129 @@ ;; Read a gcrypt sexp from a port and return it. (compose string->canonical-sexp read-string)) -(define (read-hash-data port key-type) - "Read sha256 hash data from PORT and return it as a gcrypt sexp. KEY-TYPE -is a symbol representing the type of public key algo being used." - (let* ((hex (read-string port)) - (bv (base16-string->bytevector (string-trim-both hex)))) - (bytevector->hash-data bv #:key-type key-type))) - -(define (sign-with-key key-file port) - "Sign the hash read from PORT with KEY-FILE, and write an sexp that includes -both the hash and the actual signature." - (let* ((secret-key (call-with-input-file key-file read-canonical-sexp)) - (public-key (if (string-suffix? ".sec" key-file) - (call-with-input-file +(define (load-key-pair key-file) + "Load the key pair whose secret key lives at KEY-FILE. Return a pair of +canonical sexps representing those keys." + (catch 'system-error + (lambda () + (let* ((secret-key (call-with-input-file key-file read-canonical-sexp)) + (public-key (call-with-input-file (string-append (string-drop-right key-file 4) ".pub") - read-canonical-sexp) - (leave - (G_ "cannot find public key for secret key '~a'~%") - key-file))) - (data (read-hash-data port (key-type public-key))) - (signature (signature-sexp data secret-key public-key))) - (display (canonical-sexp->string signature)) - #t)) - -(define (validate-signature port) - "Read the signature from PORT (which is as produced above), check whether -its public key is authorized, verify the signature, and print the signed data -to stdout upon success." - (let* ((signature (read-canonical-sexp port)) - (subject (signature-subject signature)) - (data (signature-signed-data signature))) + read-canonical-sexp))) + (cons public-key secret-key))) + (lambda args + (let ((errno (system-error-errno args))) + (raise + (formatted-message + (G_ "failed to load key pair at '~a': ~a~%") + key-file (strerror errno))))))) + +(define (sign-with-key public-key secret-key sha256) + "Sign the hash SHA256 (a bytevector) with SECRET-KEY (a canonical sexp), and +return the signature as a canonical sexp that includes SHA256, PUBLIC-KEY, and +the actual signature." + (let ((data (bytevector->hash-data sha256 + #:key-type (key-type public-key)))) + (signature-sexp data secret-key public-key))) + +(define (validate-signature signature acl) + "Validate SIGNATURE, a canonical sexp. Check whether its public key is +authorized in ACL, verify the signature, and return the signed data (a +bytevector) upon success." + (let* ((subject (signature-subject signature)) + (data (signature-signed-data signature))) (if (and data subject) - (if (authorized-key? subject) + (if (authorized-key? subject acl) (if (valid-signature? signature) - (let ((hash (hash-data->bytevector data))) - (display (bytevector->base16-string hash)) - #t) ; success - (leave (G_ "error: invalid signature: ~a~%") - (canonical-sexp->string signature))) - (leave (G_ "error: unauthorized public key: ~a~%") - (canonical-sexp->string subject))) - (leave (G_ "error: corrupt signature data: ~a~%") - (canonical-sexp->string signature))))) + (hash-data->bytevector data) ; success + (raise + (formatted-message (G_ "invalid signature: ~a") + (canonical-sexp->string signature)))) + (raise + (formatted-message (G_ "unauthorized public key: ~a") + (canonical-sexp->string subject)))) + (raise + (formatted-message (G_ "corrupt signature data: ~a") + (canonical-sexp->string signature)))))) + +(define (read-command port) + "Read a command from PORT and return the command and arguments as a list of +strings. Return the empty list when the end-of-file is reached. + +Commands are newline-terminated and must look something like this: + + COMMAND 3:abc 5:abcde 1:x + +where COMMAND is an alphanumeric sequence and the remainder is the command +arguments. Each argument is written as its length (in characters), followed +by colon, followed by the given number of characters." + (define (consume-whitespace port) + (let ((chr (lookahead-u8 port))) + (when (eqv? chr (char->integer #\space)) + (get-u8 port) + (consume-whitespace port)))) + + (match (read-delimited " \t\n\r" port) + ((? eof-object?) + '()) + (command + (let loop ((result (list command))) + (consume-whitespace port) + (let ((next (lookahead-u8 port))) + (cond ((eqv? next (char->integer #\newline)) + (get-u8 port) + (reverse result)) + ((eof-object? next) + (reverse result)) + (else + (let* ((len (string->number (read-delimited ":" port))) + (str (utf8->string + (get-bytevector-n port len)))) + (loop (cons str result)))))))))) + +(define-syntax define-enumerate-type ;TODO: factorize + (syntax-rules () + ((_ name->int (name id) ...) + (define-syntax name->int + (syntax-rules (name ...) + ((_ name) id) ...))))) + +;; Codes used when reply to requests. +(define-enumerate-type reply-code + (success 0) + (command-not-found 404) + (command-failed 500)) ;;; -;;; Entry point with 'openssl'-compatible interface. We support this -;;; interface because that's what the daemon expects, and we want to leave it -;;; unmodified currently. +;;; Entry point. ;;; -(define (guix-authenticate . args) +(define-command (guix-authenticate . args) + (category internal) + (synopsis "sign or verify signatures on normalized archives (nars)") + + (define (send-reply code str) + ;; Send CODE and STR as a reply to our client. + (let ((bv (string->utf8 str))) + (format #t "~a ~a:" code (bytevector-length bv)) + (put-bytevector (current-output-port) bv) + (force-output (current-output-port)))) + + (define (call-with-reply thunk) + ;; Send a reply for the result of THUNK or for any exception raised during + ;; its execution. + (guard (c ((formatted-message? c) + (send-reply (reply-code command-failed) + (apply format #f + (G_ (formatted-message-string c)) + (formatted-message-arguments c))))) + (send-reply (reply-code success) (thunk)))) + + (define-syntax-rule (with-reply exp ...) + (call-with-reply (lambda () exp ...))) + ;; Signature sexps written to stdout may contain binary data, so force ;; ISO-8859-1 encoding so that things are not mangled. See ;; <http://bugs.gnu.org/17312> for details. @@ -101,29 +178,46 @@ to stdout upon success." (with-fluids ((%default-port-encoding "ISO-8859-1") (%default-port-conversion-strategy 'error)) (match args - ;; As invoked by guix-daemon. - (("rsautl" "-sign" "-inkey" key "-in" hash-file) - (call-with-input-file hash-file - (lambda (port) - (sign-with-key key port)))) - ;; As invoked by Nix/Crypto.pm (used by Hydra.) - (("rsautl" "-sign" "-inkey" key) - (sign-with-key key (current-input-port))) - ;; As invoked by guix-daemon. - (("rsautl" "-verify" "-inkey" _ "-pubin" "-in" signature-file) - (call-with-input-file signature-file - (lambda (port) - (validate-signature port)))) - ;; As invoked by Nix/Crypto.pm (used by Hydra.) - (("rsautl" "-verify" "-inkey" _ "-pubin") - (validate-signature (current-input-port))) (("--help") (display (G_ "Usage: guix authenticate OPTION... -Sign or verify the signature on the given file. This tool is meant to -be used internally by 'guix-daemon'.\n"))) +Sign data or verify signatures. This tool is meant to be used internally by +'guix-daemon'.\n"))) (("--version") (show-version-and-exit "guix authenticate")) - (else - (leave (G_ "wrong arguments")))))) + (() + (let ((acl (current-acl))) + (let loop ((key-pairs vlist-null)) + ;; Read a request on standard input and reply. + (match (read-command (current-input-port)) + (("sign" signing-key (= base16-string->bytevector hash)) + (let* ((key-pairs keys + (match (vhash-assoc signing-key key-pairs) + ((_ . keys) + (values key-pairs keys)) + (#f + (let ((keys (load-key-pair signing-key))) + (values (vhash-cons signing-key keys + key-pairs) + keys)))))) + (with-reply (canonical-sexp->string + (match keys + ((public . secret) + (sign-with-key public secret hash))))) + (loop key-pairs))) + (("verify" signature) + (with-reply (bytevector->base16-string + (validate-signature + (string->canonical-sexp signature) + acl))) + (loop key-pairs)) + (() + (exit 0)) + (commands + (warning (G_ "~s: invalid command; ignoring~%") commands) + (send-reply (reply-code command-not-found) + "invalid command") + (loop key-pairs)))))) + (_ + (leave (G_ "wrong arguments~%")))))) ;;; authenticate.scm ends here diff --git a/guix/scripts/build.scm b/guix/scripts/build.scm index 6286a43c02..25418661b9 100644 --- a/guix/scripts/build.scm +++ b/guix/scripts/build.scm @@ -945,7 +945,10 @@ needed." ;;; Entry point. ;;; -(define (guix-build . args) +(define-command (guix-build . args) + (category packaging) + (synopsis "build packages or derivations without installing them") + (define opts (parse-command-line args %options (list %default-options))) diff --git a/guix/scripts/challenge.scm b/guix/scripts/challenge.scm index 624f51b200..39bd2c1c0f 100644 --- a/guix/scripts/challenge.scm +++ b/guix/scripts/challenge.scm @@ -475,7 +475,10 @@ Challenge the substitutes for PACKAGE... provided by one or more servers.\n")) ;;; Entry point. ;;; -(define (guix-challenge . args) +(define-command (guix-challenge . args) + (category packaging) + (synopsis "challenge substitute servers, comparing their binaries") + (with-error-handling (let* ((opts (parse-command-line args %options (list %default-options) #:build-options? #f)) diff --git a/guix/scripts/container.scm b/guix/scripts/container.scm index 8041d64b6b..2369437043 100644 --- a/guix/scripts/container.scm +++ b/guix/scripts/container.scm @@ -20,6 +20,7 @@ (define-module (guix scripts container) #:use-module (ice-9 match) #:use-module (guix ui) + #:use-module (guix scripts) #:export (guix-container)) (define (show-help) @@ -46,7 +47,10 @@ Build and manipulate Linux containers.\n")) (proc (string->symbol (string-append "guix-container-" name)))) (module-ref module proc))) -(define (guix-container . args) +(define-command (guix-container . args) + (category development) + (synopsis "run code in containers created by 'guix environment -C'") + (with-error-handling (match args (() diff --git a/guix/scripts/copy.scm b/guix/scripts/copy.scm index 16d2de30f7..2780d4fbe9 100644 --- a/guix/scripts/copy.scm +++ b/guix/scripts/copy.scm @@ -20,6 +20,7 @@ #:use-module (guix ui) #:use-module (guix scripts) #:use-module (guix ssh) + #:use-module ((ssh session) #:select (disconnect!)) #:use-module (guix store) #:use-module ((guix status) #:select (with-status-verbosity)) #:use-module (guix utils) @@ -71,9 +72,10 @@ package names, build the underlying packages before sending them." (and (build-derivations local drv) (let* ((session (open-ssh-session host #:user user #:port (or port 22))) - (sent (send-files local items - (connect-to-remote-daemon session) + (remote (connect-to-remote-daemon session)) + (sent (send-files local items remote #:recursive? #t))) + (close-connection remote) (format #t "~{~a~%~}" sent) sent)))) @@ -93,6 +95,8 @@ package names, build the underlying packages before sending them." (options->derivations+files local opts)) ((retrieved) (retrieve-files local items remote #:recursive? #t))) + (close-connection remote) + (disconnect! session) (format #t "~{~a~%~}" retrieved) retrieved))) @@ -166,7 +170,10 @@ Copy ITEMS to or from the specified host over SSH.\n")) ;;; Entry point. ;;; -(define (guix-copy . args) +(define-command (guix-copy . args) + (category plumbing) + (synopsis "copy store items remotely over SSH") + (with-error-handling (let* ((opts (parse-command-line args %options (list %default-options))) (source (assoc-ref opts 'source)) diff --git a/guix/scripts/deploy.scm b/guix/scripts/deploy.scm index 4a68197620..1b5be307be 100644 --- a/guix/scripts/deploy.scm +++ b/guix/scripts/deploy.scm @@ -136,7 +136,8 @@ Perform the deployment specified by FILE.\n")) (machine-display-name machine)))) -(define (guix-deploy . args) +(define-command (guix-deploy . args) + (synopsis "deploy operating systems on a set of machines") (define (handle-argument arg result) (alist-cons 'file arg result)) diff --git a/guix/scripts/describe.scm b/guix/scripts/describe.scm index bc868ffbbf..c3667516eb 100644 --- a/guix/scripts/describe.scm +++ b/guix/scripts/describe.scm @@ -304,7 +304,8 @@ text. The hyperlink links to a web view of COMMIT, when available." ;;; Entry point. ;;; -(define (guix-describe . args) +(define-command (guix-describe . args) + (synopsis "describe the channel revisions currently used") (let* ((opts (args-fold* args %options (lambda (opt name arg result) (leave (G_ "~A: unrecognized option~%") diff --git a/guix/scripts/download.scm b/guix/scripts/download.scm index 589f62da9d..ce8dd8b02c 100644 --- a/guix/scripts/download.scm +++ b/guix/scripts/download.scm @@ -156,7 +156,10 @@ and 'base16' ('hex' and 'hexadecimal' can be used as well).\n")) ;;; Entry point. ;;; -(define (guix-download . args) +(define-command (guix-download . args) + (category packaging) + (synopsis "download a file to the store and print its hash") + (define (parse-options) ;; Return the alist of option values. (args-fold* args %options diff --git a/guix/scripts/edit.scm b/guix/scripts/edit.scm index 43f3011869..49c9d945b6 100644 --- a/guix/scripts/edit.scm +++ b/guix/scripts/edit.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2015, 2016, 2019 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2015, 2016, 2019, 2020 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2015 Mathieu Lirzin <mthl@gnu.org> ;;; Copyright © 2020 Simon Tournier <zimon.toutoune@gmail.com> ;;; @@ -78,7 +78,10 @@ line." (search-path* %load-path (location-file location)))) -(define (guix-edit . args) +(define-command (guix-edit . args) + (category packaging) + (synopsis "view and edit package definitions") + (define (parse-arguments) ;; Return the list of package names. (args-fold* args %options diff --git a/guix/scripts/environment.scm b/guix/scripts/environment.scm index b8979cac19..ad50281eb2 100644 --- a/guix/scripts/environment.scm +++ b/guix/scripts/environment.scm @@ -477,6 +477,7 @@ WHILE-LIST." (group-entry (gid 65534) ;the overflow GID (name "overflow")))) (home-dir (password-entry-directory passwd)) + (logname (password-entry-name passwd)) (environ (filter (match-lambda ((variable . value) (find (cut regexp-exec <> variable) @@ -528,6 +529,10 @@ WHILE-LIST." ;; The same variables as in Nix's 'build.cc'. '("TMPDIR" "TEMPDIR" "TMP" "TEMP")) + ;; Some programs expect USER and/or LOGNAME to be set. + (setenv "LOGNAME" logname) + (setenv "USER" logname) + ;; Create a dummy home directory. (mkdir-p home-dir) (setenv "HOME" home-dir) @@ -673,7 +678,10 @@ message if any test fails." ;;; Entry point. ;;; -(define (guix-environment . args) +(define-command (guix-environment . args) + (category development) + (synopsis "spawn one-off software environments") + (with-error-handling (let* ((opts (parse-args args)) (pure? (assoc-ref opts 'pure)) diff --git a/guix/scripts/gc.scm b/guix/scripts/gc.scm index ab7c13315f..043273f491 100644 --- a/guix/scripts/gc.scm +++ b/guix/scripts/gc.scm @@ -220,7 +220,9 @@ is deprecated; use '-D'~%")) ;;; Entry point. ;;; -(define (guix-gc . args) +(define-command (guix-gc . args) + (synopsis "invoke the garbage collector") + (define (parse-options) ;; Return the alist of option values. (parse-command-line args %options (list %default-options) diff --git a/guix/scripts/git.scm b/guix/scripts/git.scm index bc829cbe99..4436d8a6e0 100644 --- a/guix/scripts/git.scm +++ b/guix/scripts/git.scm @@ -19,6 +19,7 @@ (define-module (guix scripts git) #:use-module (ice-9 match) #:use-module (guix ui) + #:use-module (guix scripts) #:export (guix-git)) (define (show-help) @@ -45,7 +46,10 @@ Operate on Git repositories.\n")) (proc (string->symbol (string-append "guix-git-" name)))) (module-ref module proc))) -(define (guix-git . args) +(define-command (guix-git . args) + (category plumbing) + (synopsis "operate on Git repositories") + (with-error-handling (match args (() diff --git a/guix/scripts/graph.scm b/guix/scripts/graph.scm index 73d9269de2..d7a08a4fe1 100644 --- a/guix/scripts/graph.scm +++ b/guix/scripts/graph.scm @@ -565,7 +565,10 @@ Emit a representation of the dependency graph of PACKAGE...\n")) ;;; Entry point. ;;; -(define (guix-graph . args) +(define-command (guix-graph . args) + (category packaging) + (synopsis "view and query package dependency graphs") + (with-error-handling (define opts (parse-command-line args %options diff --git a/guix/scripts/hash.scm b/guix/scripts/hash.scm index 9b4f419a24..797b99f053 100644 --- a/guix/scripts/hash.scm +++ b/guix/scripts/hash.scm @@ -116,7 +116,10 @@ and 'base16' ('hex' and 'hexadecimal' can be used as well).\n")) ;;; Entry point. ;;; -(define (guix-hash . args) +(define-command (guix-hash . args) + (category packaging) + (synopsis "compute the cryptographic hash of a file") + (define (parse-options) ;; Return the alist of option values. (parse-command-line args %options (list %default-options) diff --git a/guix/scripts/import.scm b/guix/scripts/import.scm index c6cc93fad8..0a3863f965 100644 --- a/guix/scripts/import.scm +++ b/guix/scripts/import.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2012, 2013, 2014 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2012, 2013, 2014, 2020 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2014 David Thompson <davet@gnu.org> ;;; Copyright © 2018 Kyle Meyer <kyle@kyleam.com> ;;; Copyright © 2019 Ricardo Wurmus <rekado@elephly.net> @@ -21,6 +21,7 @@ (define-module (guix scripts import) #:use-module (guix ui) + #:use-module (guix scripts) #:use-module (guix utils) #:use-module (srfi srfi-1) #:use-module (srfi srfi-11) @@ -98,7 +99,10 @@ Run IMPORTER with ARGS.\n")) (newline) (show-bug-report-information)) -(define (guix-import . args) +(define-command (guix-import . args) + (category packaging) + (synopsis "import a package definition from an external repository") + (match args (() (format (current-error-port) diff --git a/guix/scripts/install.scm b/guix/scripts/install.scm index d88e86e77a..894e60f9da 100644 --- a/guix/scripts/install.scm +++ b/guix/scripts/install.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2019 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2019, 2020 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -66,7 +66,9 @@ This is an alias for 'guix package -i'.\n")) %transformation-options %standard-build-options))) -(define (guix-install . args) +(define-command (guix-install . args) + (synopsis "install packages") + (define (handle-argument arg result arg-handler) ;; Treat all non-option arguments as package specs. (values (alist-cons 'install arg result) diff --git a/guix/scripts/lint.scm b/guix/scripts/lint.scm index 5168a1ca17..979d4f8363 100644 --- a/guix/scripts/lint.scm +++ b/guix/scripts/lint.scm @@ -157,7 +157,10 @@ run the checkers on all packages.\n")) ;;; Entry Point ;;; -(define (guix-lint . args) +(define-command (guix-lint . args) + (category packaging) + (synopsis "validate package definitions") + (define (parse-options) ;; Return the alist of option values. (parse-command-line args %options (list %default-options) diff --git a/guix/scripts/offload.scm b/guix/scripts/offload.scm index a56701f07a..3dc8ccefcb 100644 --- a/guix/scripts/offload.scm +++ b/guix/scripts/offload.scm @@ -39,6 +39,7 @@ #:select (fcntl-flock set-thread-name)) #:use-module ((guix build utils) #:select (which mkdir-p)) #:use-module (guix ui) + #:use-module (guix scripts) #:use-module (guix diagnostics) #:use-module (srfi srfi-1) #:use-module (srfi srfi-11) @@ -365,6 +366,8 @@ of free disk space on '~a'~%") #:log-port (current-error-port) #:lock? #f))) + (close-connection store) + (disconnect! session) (format (current-error-port) "done with offloaded '~a'~%" (derivation-file-name drv))) @@ -723,7 +726,10 @@ machine." ;;; Entry point. ;;; -(define (guix-offload . args) +(define-command (guix-offload . args) + (category plumbing) + (synopsis "set up and operate build offloading") + (define request-line-rx ;; The request format. See 'tryBuildHook' method in build.cc. (make-regexp "([01]) ([a-z0-9_-]+) (/[[:graph:]]+.drv) ([[:graph:]]*)")) diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm index 9d6881fdaf..379e6a3ac6 100644 --- a/guix/scripts/pack.scm +++ b/guix/scripts/pack.scm @@ -1089,7 +1089,10 @@ Create a bundle of PACKAGE.\n")) ;;; Entry point. ;;; -(define (guix-pack . args) +(define-command (guix-pack . args) + (category development) + (synopsis "create application bundles") + (define opts (parse-command-line args %options (list %default-options))) diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm index ac8dedb5f3..4eb968a49b 100644 --- a/guix/scripts/package.scm +++ b/guix/scripts/package.scm @@ -941,7 +941,9 @@ processed, #f otherwise." ;;; Entry point. ;;; -(define (guix-package . args) +(define-command (guix-package . args) + (synopsis "manage packages and profiles") + (define (handle-argument arg result arg-handler) ;; Process non-option argument ARG by calling back ARG-HANDLER. (if arg-handler diff --git a/guix/scripts/perform-download.scm b/guix/scripts/perform-download.scm index df787a9940..8d409092ba 100644 --- a/guix/scripts/perform-download.scm +++ b/guix/scripts/perform-download.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2016, 2017, 2018, 2020 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -18,6 +18,7 @@ (define-module (guix scripts perform-download) #:use-module (guix ui) + #:use-module (guix scripts) #:use-module (guix derivations) #:use-module ((guix store) #:select (derivation-path? store-path?)) #:use-module (guix build download) @@ -91,14 +92,15 @@ actual output is different from that when we're doing a 'bmCheck' or (leave (G_ "refusing to run with elevated privileges (UID ~a)~%") (getuid)))) -(define (guix-perform-download . args) - "Perform the download described by the given fixed-output derivation. +(define-command (guix-perform-download . args) + (category internal) + (synopsis "perform download described by fixed-output derivations") -This is an \"out-of-band\" download in that this code is executed directly by -the daemon and not explicitly described as an input of the derivation. This -allows us to sidestep bootstrapping problems, such downloading the source code -of GnuTLS over HTTPS, before we have built GnuTLS. See -<http://bugs.gnu.org/22774>." + ;; This is an "out-of-band" download in that this code is executed directly + ;; by the daemon and not explicitly described as an input of the derivation. + ;; This allows us to sidestep bootstrapping problems, such as downloading + ;; the source code of GnuTLS over HTTPS before we have built GnuTLS. See + ;; <https://bugs.gnu.org/22774>. (define print-build-trace? (match (getenv "_NIX_OPTIONS") diff --git a/guix/scripts/processes.scm b/guix/scripts/processes.scm index 35698a0216..b4ca7b1687 100644 --- a/guix/scripts/processes.scm +++ b/guix/scripts/processes.scm @@ -223,7 +223,9 @@ List the current Guix sessions and their processes.")) ;;; Entry point. ;;; -(define (guix-processes . args) +(define-command (guix-processes . args) + (category plumbing) + (synopsis "list currently running sessions") (define options (args-fold* args %options (lambda (opt name arg result) diff --git a/guix/scripts/publish.scm b/guix/scripts/publish.scm index 61542f83a0..4eaf961ab2 100644 --- a/guix/scripts/publish.scm +++ b/guix/scripts/publish.scm @@ -1013,7 +1013,10 @@ methods, return the applicable compression." ;;; Entry point. ;;; -(define (guix-publish . args) +(define-command (guix-publish . args) + (category packaging) + (synopsis "publish build results over HTTP") + (with-error-handling (let* ((opts (args-fold* args %options (lambda (opt name arg result) diff --git a/guix/scripts/pull.scm b/guix/scripts/pull.scm index 5b4ccf13fe..bb1b560a22 100644 --- a/guix/scripts/pull.scm +++ b/guix/scripts/pull.scm @@ -507,6 +507,7 @@ true, display what would be built without actually building it." ;; workaround, skip this code when $SUDO_USER is set. See ;; <https://bugs.gnu.org/36785>. (unless (or (getenv "SUDO_USER") + (not (file-exists? %user-profile-directory)) (string=? %profile-directory (dirname (canonicalize-profile %user-profile-directory)))) @@ -750,7 +751,9 @@ Use '~/.config/guix/channels.scm' instead.")) channels))) -(define (guix-pull . args) +(define-command (guix-pull . args) + (synopsis "pull the latest revision of Guix") + (with-error-handling (with-git-error-handling (let* ((opts (parse-command-line args %options diff --git a/guix/scripts/refresh.scm b/guix/scripts/refresh.scm index efada1df5a..4a71df28d1 100644 --- a/guix/scripts/refresh.scm +++ b/guix/scripts/refresh.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2013 Nikita Karetnikov <nikita@karetnikov.org> ;;; Copyright © 2014 Eric Bavier <bavier@member.fsf.org> ;;; Copyright © 2015 Alex Kost <alezost@gmail.com> @@ -496,7 +496,10 @@ all are dependent packages: ~{~a~^ ~}~%") ;;; Entry point. ;;; -(define (guix-refresh . args) +(define-command (guix-refresh . args) + (category packaging) + (synopsis "update existing package definitions") + (define (parse-options) ;; Return the alist of option values. (parse-command-line args %options (list %default-options) diff --git a/guix/scripts/remove.scm b/guix/scripts/remove.scm index 2f06ea4f37..a46ad04d56 100644 --- a/guix/scripts/remove.scm +++ b/guix/scripts/remove.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2019 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2019, 2020 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -63,7 +63,9 @@ This is an alias for 'guix package -r'.\n")) %standard-build-options))) -(define (guix-remove . args) +(define-command (guix-remove . args) + (synopsis "remove installed packages") + (define (handle-argument arg result arg-handler) ;; Treat all non-option arguments as package specs. (values (alist-cons 'remove arg result) diff --git a/guix/scripts/repl.scm b/guix/scripts/repl.scm index 0ea9c3655c..3c79e89f8d 100644 --- a/guix/scripts/repl.scm +++ b/guix/scripts/repl.scm @@ -137,7 +137,10 @@ call THUNK." (loop))))))) -(define (guix-repl . args) +(define-command (guix-repl . args) + (category plumbing) + (synopsis "read-eval-print loop (REPL) for interactive programming") + (define opts (args-fold* args %options (lambda (opt name arg result) diff --git a/guix/scripts/search.scm b/guix/scripts/search.scm index 827b2eb7a9..0c9e6af07b 100644 --- a/guix/scripts/search.scm +++ b/guix/scripts/search.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2019 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2019, 2020 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -57,7 +57,9 @@ This is an alias for 'guix package -s'.\n")) (member "load-path" (option-names option))) %standard-build-options))) -(define (guix-search . args) +(define-command (guix-search . args) + (synopsis "search for packages") + (define (handle-argument arg result) ;; Treat all non-option arguments as regexps. (cons `(query search ,(or arg "")) diff --git a/guix/scripts/show.scm b/guix/scripts/show.scm index a2b0030a63..535d03c1a6 100644 --- a/guix/scripts/show.scm +++ b/guix/scripts/show.scm @@ -57,7 +57,9 @@ This is an alias for 'guix package --show='.\n")) (member "load-path" (option-names option))) %standard-build-options))) -(define (guix-show . args) +(define-command (guix-show . args) + (synopsis "show information about packages") + (define (handle-argument arg result) ;; Treat all non-option arguments as regexps. (cons `(query show ,arg) diff --git a/guix/scripts/size.scm b/guix/scripts/size.scm index c42f4f7782..e46983382a 100644 --- a/guix/scripts/size.scm +++ b/guix/scripts/size.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2015, 2016, 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2019 Simon Tournier <zimon.toutoune@gmail.com> ;;; ;;; This file is part of GNU Guix. @@ -298,7 +298,10 @@ Report the size of the PACKAGE or STORE-ITEM, with its dependencies.\n")) ;;; Entry point. ;;; -(define (guix-size . args) +(define-command (guix-size . args) + (category packaging) + (synopsis "profile the on-disk size of packages") + (with-error-handling (let* ((opts (parse-command-line args %options (list %default-options) #:build-options? #f)) diff --git a/guix/scripts/substitute.scm b/guix/scripts/substitute.scm index f9d19fd735..26613df68f 100755 --- a/guix/scripts/substitute.scm +++ b/guix/scripts/substitute.scm @@ -20,6 +20,7 @@ (define-module (guix scripts substitute) #:use-module (guix ui) + #:use-module (guix scripts) #:use-module (guix store) #:use-module (guix utils) #:use-module (guix combinators) @@ -1095,8 +1096,10 @@ default value." (unless (string->uri uri) (leave (G_ "~a: invalid URI~%") uri))) -(define (guix-substitute . args) - "Implement the build daemon's substituter protocol." +(define-command (guix-substitute . args) + (category internal) + (synopsis "implement the build daemon's substituter protocol") + (define print-build-trace? (match (or (find-daemon-option "untrusted-print-extended-build-trace") (find-daemon-option "print-extended-build-trace")) @@ -1126,12 +1129,13 @@ default value." ;; Sanity-check SUBSTITUTE-URLS so we can provide a meaningful error message. (for-each validate-uri (substitute-urls)) - ;; Attempt to install the client's locale, mostly so that messages are - ;; suitably translated. + ;; Attempt to install the client's locale so that messages are suitably + ;; translated. LC_CTYPE must be a UTF-8 locale; it's the case by default so + ;; don't change it. (match (or (find-daemon-option "untrusted-locale") (find-daemon-option "locale")) (#f #f) - (locale (false-if-exception (setlocale LC_ALL locale)))) + (locale (false-if-exception (setlocale LC_MESSAGES locale)))) (catch 'system-error (lambda () diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm index f6d20382b6..bd5f84fc5b 100644 --- a/guix/scripts/system.scm +++ b/guix/scripts/system.scm @@ -6,6 +6,8 @@ ;;; Copyright © 2018 Ricardo Wurmus <rekado@elephly.net> ;;; Copyright © 2019 Christopher Baines <mail@cbaines.net> ;;; Copyright © 2020 Jan (janneke) Nieuwenhuizen <janneke@gnu.org> +;;; Copyright © 2020 Julien Lepiller <julien@lepiller.eu> +;;; Copyright © 2020 Efraim Flashner <efraim@flashner.co.il> ;;; ;;; This file is part of GNU Guix. ;;; @@ -271,28 +273,33 @@ expression in %STORE-MONAD." (define (report-shepherd-error error) "Report ERROR, a '&shepherd-error' error condition object." - (cond ((service-not-found-error? error) - (report-error (G_ "service '~a' could not be found~%") - (service-not-found-error-service error))) - ((action-not-found-error? error) - (report-error (G_ "service '~a' does not have an action '~a'~%") - (action-not-found-error-service error) - (action-not-found-error-action error))) - ((action-exception-error? error) - (report-error (G_ "exception caught while executing '~a' \ + (when error + (cond ((service-not-found-error? error) + (warning (G_ "service '~a' could not be found~%") + (service-not-found-error-service error))) + ((action-not-found-error? error) + (warning (G_ "service '~a' does not have an action '~a'~%") + (action-not-found-error-service error) + (action-not-found-error-action error))) + ((action-exception-error? error) + (warning (G_ "exception caught while executing '~a' \ on service '~a':~%") - (action-exception-error-action error) - (action-exception-error-service error)) - (print-exception (current-error-port) #f - (action-exception-error-key error) - (action-exception-error-arguments error))) - ((unknown-shepherd-error? error) - (report-error (G_ "something went wrong: ~s~%") - (unknown-shepherd-error-sexp error))) - ((shepherd-error? error) - (report-error (G_ "shepherd error~%"))) - ((not error) ;not an error - #t))) + (action-exception-error-action error) + (action-exception-error-service error)) + (print-exception (current-error-port) #f + (action-exception-error-key error) + (action-exception-error-arguments error))) + ((unknown-shepherd-error? error) + (warning (G_ "something went wrong: ~s~%") + (unknown-shepherd-error-sexp error))) + ((shepherd-error? error) + (warning (G_ "shepherd error~%")))) + + ;; Don't leave users out in the cold and explain what that means and what + ;; they can do. + (warning (G_ "some services could not be upgraded~%")) + (display-hint (G_ "To allow changes to all the system services to take +effect, you will need to reboot.")))) (define-syntax-rule (unless-file-not-found exp) (catch 'system-error @@ -662,7 +669,7 @@ checking this by themselves in their 'check' procedure." (define* (system-derivation-for-action os base-image action #:key image-size file-system-type full-boot? container-shared-network? - mappings) + mappings label) "Return as a monadic value the derivation for OS according to ACTION." (case action ((build init reconfigure) @@ -686,7 +693,7 @@ checking this by themselves in their 'check' procedure." (lower-object (system-image (image - (inherit base-image) + (inherit (if label (image-with-label base-image label) base-image)) (size image-size) (operating-system os))))) ((docker-image) @@ -741,7 +748,7 @@ and TARGET arguments." install-bootloader? dry-run? derivations-only? use-substitutes? bootloader-target target - image-size file-system-type full-boot? + image-size file-system-type full-boot? label container-shared-network? (mappings '()) (gc-root #f)) @@ -795,6 +802,7 @@ static checks." ((target* (current-target-system)) (image -> (find-image file-system-type target*)) (sys (system-derivation-for-action os image action + #:label label #:file-system-type file-system-type #:image-size image-size #:full-boot? full-boot? @@ -835,7 +843,9 @@ static checks." (upgrade-shepherd-services local-eval os) (return (format #t (G_ "\ To complete the upgrade, run 'herd restart SERVICE' to stop, -upgrade, and restart each service that was not automatically restarted.\n")))))) +upgrade, and restart each service that was not automatically restarted.\n"))) + (return (format #t (G_ "\ +Run 'herd status' to view the list of services on your system.\n")))))) ((init) (newline) (format #t (G_ "initializing operating system under '~a'...~%") @@ -943,11 +953,15 @@ Some ACTIONS support additional ARGS.\n")) (display (G_ " --no-bootloader for 'init', do not install a bootloader")) (display (G_ " + --label=LABEL for 'disk-image', label disk image with LABEL")) + (display (G_ " --save-provenance save provenance information")) (display (G_ " - --share=SPEC for 'vm', share host file system according to SPEC")) + --share=SPEC for 'vm' and 'container', share host file system with + read/write access according to SPEC")) (display (G_ " - --expose=SPEC for 'vm', expose host file system according to SPEC")) + --expose=SPEC for 'vm' and 'container', expose host file system + directory as read-only according to SPEC")) (display (G_ " -N, --network for 'container', allow containers to access the network")) (display (G_ " @@ -1008,6 +1022,9 @@ Some ACTIONS support additional ARGS.\n")) (option '("no-bootloader" "no-grub") #f #f (lambda (opt name arg result) (alist-cons 'install-bootloader? #f result))) + (option '("label") #t #f + (lambda (opt name arg result) + (alist-cons 'label arg result))) (option '("full-boot") #f #f (lambda (opt name arg result) (alist-cons 'full-boot? #t result))) @@ -1065,7 +1082,8 @@ Some ACTIONS support additional ARGS.\n")) (validate-reconfigure . ,ensure-forward-reconfigure) (file-system-type . "ext4") (image-size . guess) - (install-bootloader? . #t))) + (install-bootloader? . #t) + (label . #f))) (define (verbosity-level opts) "Return the verbosity level based on OPTS, the alist of parsed options." @@ -1119,6 +1137,7 @@ resulting from command-line parsing." (dry? (assoc-ref opts 'dry-run?)) (bootloader? (assoc-ref opts 'install-bootloader?)) + (label (assoc-ref opts 'label)) (target-file (match args ((first second) second) (_ #f))) @@ -1169,6 +1188,7 @@ resulting from command-line parsing." (_ #f)) opts) #:install-bootloader? bootloader? + #:label label #:target target-file #:bootloader-target bootloader-target #:gc-root (assoc-ref opts 'gc-root))))) @@ -1233,7 +1253,9 @@ argument list and OPTS is the option alist." ;; need an operating system configuration file. (else (process-action command args opts)))) -(define (guix-system . args) +(define-command (guix-system . args) + (synopsis "build and deploy full operating systems") + (define (parse-sub-command arg result) ;; Parse sub-command ARG and augment RESULT accordingly. (if (assoc-ref result 'action) diff --git a/guix/scripts/time-machine.scm b/guix/scripts/time-machine.scm index 441673b780..0d27414702 100644 --- a/guix/scripts/time-machine.scm +++ b/guix/scripts/time-machine.scm @@ -128,7 +128,9 @@ Execute COMMAND ARGS... in an older version of Guix.\n")) ;;; Entry point. ;;; -(define (guix-time-machine . args) +(define-command (guix-time-machine . args) + (synopsis "run commands from a different revision") + (with-error-handling (with-git-error-handling (let* ((opts (parse-args args)) diff --git a/guix/scripts/upgrade.scm b/guix/scripts/upgrade.scm index d2784669be..8c7abd133a 100644 --- a/guix/scripts/upgrade.scm +++ b/guix/scripts/upgrade.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2019 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2019, 2020 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2020 Jakub Kądziołka <kuba@kadziolka.net> ;;; ;;; This file is part of GNU Guix. @@ -67,7 +67,9 @@ This is an alias for 'guix package -u'.\n")) %transformation-options %standard-build-options))) -(define (guix-upgrade . args) +(define-command (guix-upgrade . args) + (synopsis "upgrade packages to their latest version") + (define (handle-argument arg result arg-handler) ;; Accept at most one non-option argument, and treat it as an upgrade ;; regexp. diff --git a/guix/scripts/weather.scm b/guix/scripts/weather.scm index 3035ff6ca8..6a2582c997 100644 --- a/guix/scripts/weather.scm +++ b/guix/scripts/weather.scm @@ -495,7 +495,9 @@ SERVER. Display information for packages with at least THRESHOLD dependents." ;;; Entry point. ;;; -(define (guix-weather . args) +(define-command (guix-weather . args) + (synopsis "report on the availability of pre-built package binaries") + (define (package-list opts) ;; Return the package list specified by OPTS. (let ((files (filter-map (match-lambda diff --git a/guix/self.scm b/guix/self.scm index 6a1640acdf..02ef982c7c 100644 --- a/guix/self.scm +++ b/guix/self.scm @@ -49,7 +49,7 @@ (module-ref (resolve-interface module) variable)))) (match-lambda ("guile" (ref '(gnu packages guile) 'guile-3.0/libgc-7)) - ("guile-json" (ref '(gnu packages guile) 'guile-json-3)) + ("guile-json" (ref '(gnu packages guile) 'guile-json-4)) ("guile-ssh" (ref '(gnu packages ssh) 'guile-ssh)) ("guile-git" (ref '(gnu packages guile) 'guile-git)) ("guile-sqlite3" (ref '(gnu packages guile) 'guile-sqlite3)) diff --git a/guix/ssh.scm b/guix/ssh.scm index 24db171374..e41bffca65 100644 --- a/guix/ssh.scm +++ b/guix/ssh.scm @@ -20,7 +20,11 @@ #:use-module (guix store) #:use-module (guix inferior) #:use-module (guix i18n) - #:use-module ((guix diagnostics) #:select (&fix-hint formatted-message)) + #:use-module ((guix diagnostics) + #:select (info &fix-hint formatted-message)) + #:use-module ((guix progress) + #:select (progress-bar + erase-current-line current-terminal-columns)) #:use-module (gcrypt pk-crypto) #:use-module (ssh session) #:use-module (ssh auth) @@ -36,6 +40,7 @@ #:use-module (ice-9 match) #:use-module (ice-9 format) #:use-module (ice-9 binary-ports) + #:use-module (ice-9 vlist) #:export (open-ssh-session authenticate-server* @@ -402,6 +407,56 @@ to the system ACL file if it has not yet been authorized." session become-command)) +(define (prepare-to-send store host log-port items) + "Notify the user that we're about to send ITEMS to HOST. Return three +values allowing 'notify-send-progress' to track the state of this transfer." + (let* ((count (length items)) + (sizes (fold (lambda (item result) + (vhash-cons item + (path-info-nar-size + (query-path-info store item)) + result)) + vlist-null + items)) + (total (vlist-fold (lambda (pair result) + (match pair + ((_ . size) (+ size result)))) + 0 + sizes))) + (info (N_ "sending ~a store item (~h MiB) to '~a'...~%" + "sending ~a store items (~h MiB) to '~a'...~%" count) + count + (inexact->exact (round (/ total (expt 2. 20)))) + host) + + (values log-port sizes total 0))) + +(define (notify-transfer-progress item port sizes total sent) + "Notify the user that we've already transferred SENT bytes out of TOTAL. +Use SIZES to determine the size of ITEM, which is about to be sent." + (define (display-bar %) + (erase-current-line port) + (format port "~3@a% ~a" + (inexact->exact (round (* 100. (/ sent total)))) + (progress-bar % (- (max (current-terminal-columns) 5) 5))) + (force-output port)) + + (unless (zero? total) + (let ((% (* 100. (/ sent total)))) + (match (vhash-assoc item sizes) + (#f + (display-bar %) + (values port sizes total sent)) + ((_ . size) + (display-bar %) + (values port sizes total (+ sent size))))))) + +(define (notify-transfer-completion port . args) + "Notify the user that the transfer has completed." + (apply notify-transfer-progress "" port args) ;display the 100% progress bar + (erase-current-line port) + (force-output port)) + (define* (send-files local files remote #:key recursive? @@ -421,11 +476,8 @@ Return the list of store items actually sent." (remove (cut valid-path? store <>) ',files))) session)) - (count (length missing)) - (sizes (map (lambda (item) - (path-info-nar-size (query-path-info local item))) - missing)) - (port (store-import-channel session))) + (port (store-import-channel session)) + (host (session-get session 'host))) ;; Make sure everything alright on the remote side. (match (read port) (('importing) @@ -433,14 +485,12 @@ Return the list of store items actually sent." (sexp (handle-import/export-channel-error sexp remote))) - (format log-port (N_ "sending ~a store item (~h MiB) to '~a'...~%" - "sending ~a store items (~h MiB) to '~a'...~%" count) - count - (inexact->exact (round (/ (reduce + 0 sizes) (expt 2. 20)))) - (session-get session 'host)) - ;; Send MISSING in topological order. - (export-paths local missing port) + (let ((tty? (isatty? log-port))) + (export-paths local missing port + #:start (cut prepare-to-send local host log-port <>) + #:progress (if tty? notify-transfer-progress (const #f)) + #:finish (if tty? notify-transfer-completion (const #f)))) ;; Tell the remote process that we're done. (In theory the end-of-archive ;; mark of 'export-paths' would be enough, but in practice it's not.) diff --git a/guix/store.scm b/guix/store.scm index 683e125b20..d859ea33ed 100644 --- a/guix/store.scm +++ b/guix/store.scm @@ -628,9 +628,10 @@ connection. Use with care." (define (thunk) (parameterize ((current-store-protocol-version (store-connection-version store))) - (let ((result (proc store))) - (close-connection store) - result))) + (call-with-values (lambda () (proc store)) + (lambda results + (close-connection store) + (apply values results))))) (cond-expand (guile-3 @@ -819,7 +820,7 @@ encoding conversion errors." (terminal-columns (terminal-columns)) ;; Locale of the client. - (locale (false-if-exception (setlocale LC_ALL)))) + (locale (false-if-exception (setlocale LC_MESSAGES)))) ;; Must be called after `open-connection'. (define buffered @@ -1727,10 +1728,20 @@ is raised if the set of paths read from PORT is not signed (as per (or done? (loop (process-stderr server port)))) (= 1 (read-int s)))) -(define* (export-paths server paths port #:key (sign? #t) recursive?) +(define* (export-paths server paths port #:key (sign? #t) recursive? + (start (const #f)) + (progress (const #f)) + (finish (const #f))) "Export the store paths listed in PATHS to PORT, in topological order, signing them if SIGN? is true. When RECURSIVE? is true, export the closure of -PATHS---i.e., PATHS and all their dependencies." +PATHS---i.e., PATHS and all their dependencies. + +START, PROGRESS, and FINISH are used to track progress of the data transfer. +START is a one-argument that is passed the list of store items that will be +transferred; it returns values that are then used as the initial state +threaded through PROGRESS calls. PROGRESS is passed the store item about to +be sent, along with the values previously return by START or by PROGRESS +itself. FINISH is called when the last store item has been called." (define ordered (let ((sorted (topologically-sorted server paths))) ;; When RECURSIVE? is #f, filter out the references of PATHS. @@ -1738,14 +1749,20 @@ PATHS---i.e., PATHS and all their dependencies." sorted (filter (cut member <> paths) sorted)))) - (let loop ((paths ordered)) + (let loop ((paths ordered) + (state (call-with-values (lambda () (start ordered)) + list))) (match paths (() + (apply finish state) (write-int 0 port)) ((head tail ...) (write-int 1 port) (and (export-path server head port #:sign? sign?) - (loop tail)))))) + (loop tail + (call-with-values + (lambda () (apply progress head state)) + list))))))) (define-operation (query-failed-paths) "Return the list of store items for which a build failure is cached. diff --git a/guix/store/database.scm b/guix/store/database.scm index 50b66ce282..2ea63b17aa 100644 --- a/guix/store/database.scm +++ b/guix/store/database.scm @@ -397,7 +397,10 @@ absolute file name to the state directory of the store being initialized. Return #t on success. Use with care as it directly modifies the store! This is primarily meant to -be used internally by the daemon's build hook." +be used internally by the daemon's build hook. + +PATH must be protected from GC and locked during execution of this, typically +by adding it as a temp-root." (define db-file (store-database-file #:prefix prefix #:state-directory state-directory)) @@ -423,7 +426,9 @@ be used internally by the daemon's build hook." "Register all of ITEMS, a list of <store-info> records as returned by 'read-reference-graph', in DB. ITEMS must be in topological order (with leaves first.) REGISTRATION-TIME must be the registration time to be recorded -in the database; #f means \"now\". Write a progress report to LOG-PORT." +in the database; #f means \"now\". Write a progress report to LOG-PORT. All +of ITEMS must be protected from GC and locked during execution of this, +typically by adding them as temp-roots." (define store-dir (if prefix (string-append prefix %storedir) @@ -452,24 +457,25 @@ in the database; #f means \"now\". Write a progress report to LOG-PORT." (when reset-timestamps? (reset-timestamps real-file-name)) (let-values (((hash nar-size) (nar-sha256 real-file-name))) - (sqlite-register db #:path to-register - #:references (store-info-references item) - #:deriver (store-info-deriver item) - #:hash (string-append "sha256:" - (bytevector->base16-string hash)) - #:nar-size nar-size - #:time registration-time) + (call-with-retrying-transaction db + (lambda () + (sqlite-register db #:path to-register + #:references (store-info-references item) + #:deriver (store-info-deriver item) + #:hash (string-append + "sha256:" + (bytevector->base16-string hash)) + #:nar-size nar-size + #:time registration-time))) (when deduplicate? (deduplicate real-file-name hash #:store store-dir))))) - (call-with-retrying-transaction db - (lambda () - (let* ((prefix (format #f "registering ~a items" (length items))) - (progress (progress-reporter/bar (length items) - prefix log-port))) - (call-with-progress-reporter progress - (lambda (report) - (for-each (lambda (item) - (register db item) - (report)) - items))))))) + (let* ((prefix (format #f "registering ~a items" (length items))) + (progress (progress-reporter/bar (length items) + prefix log-port))) + (call-with-progress-reporter progress + (lambda (report) + (for-each (lambda (item) + (register db item) + (report)) + items))))) diff --git a/guix/store/deduplication.scm b/guix/store/deduplication.scm index df959bdd06..0655ceb890 100644 --- a/guix/store/deduplication.scm +++ b/guix/store/deduplication.scm @@ -94,8 +94,8 @@ LINK-PREFIX." (try (tempname-in link-prefix)) (apply throw args)))))) -(define (call-with-writable-file file thunk) - (if (string=? file (%store-directory)) +(define (call-with-writable-file file store thunk) + (if (string=? file store) (thunk) ;don't meddle with the store's permissions (let ((stat (lstat file))) (dynamic-wind @@ -106,17 +106,18 @@ LINK-PREFIX." (set-file-time file stat) (chmod file (stat:mode stat))))))) -(define-syntax-rule (with-writable-file file exp ...) +(define-syntax-rule (with-writable-file file store exp ...) "Make FILE writable for the dynamic extent of EXP..., except if FILE is the store." - (call-with-writable-file file (lambda () exp ...))) + (call-with-writable-file file store (lambda () exp ...))) ;; There are 3 main kinds of errors we can get from hardlinking: "Too many ;; things link to this" (EMLINK), "this link already exists" (EEXIST), and ;; "can't fit more stuff in this directory" (ENOSPC). (define* (replace-with-link target to-replace - #:key (swap-directory (dirname target))) + #:key (swap-directory (dirname target)) + (store (%store-directory))) "Atomically replace the file TO-REPLACE with a link to TARGET. Use SWAP-DIRECTORY as the directory to store temporary hard links. Upon ENOSPC and EMLINK, TO-REPLACE is left unchanged. @@ -137,7 +138,7 @@ Note: TARGET, TO-REPLACE, and SWAP-DIRECTORY must be on the same file system." ;; If we couldn't create TEMP-LINK, that's OK: just don't do the ;; replacement, which means TO-REPLACE won't be deduplicated. (when temp-link - (with-writable-file (dirname to-replace) + (with-writable-file (dirname to-replace) store (catch 'system-error (lambda () (rename-file temp-link to-replace)) @@ -154,46 +155,49 @@ under STORE." (define links-directory (string-append store "/.links")) - (mkdir-p links-directory) - (let loop ((path path) - (type (stat:type (lstat path))) - (hash hash)) - (if (eq? 'directory type) - ;; Can't hardlink directories, so hardlink their atoms. - (for-each (match-lambda - ((file . properties) - (unless (member file '("." "..")) - (let* ((file (string-append path "/" file)) - (type (match (assoc-ref properties 'type) - ((or 'unknown #f) - (stat:type (lstat file))) - (type type)))) - (loop file type - (and (not (eq? 'directory type)) - (nar-sha256 file))))))) - (scandir* path)) - (let ((link-file (string-append links-directory "/" - (bytevector->nix-base32-string hash)))) - (if (file-exists? link-file) - (replace-with-link link-file path - #:swap-directory links-directory) - (catch 'system-error - (lambda () - (link path link-file)) - (lambda args - (let ((errno (system-error-errno args))) - (cond ((= errno EEXIST) - ;; Someone else put an entry for PATH in - ;; LINKS-DIRECTORY before we could. Let's use it. - (replace-with-link path link-file - #:swap-directory links-directory)) - ((= errno ENOSPC) - ;; There's not enough room in the directory index for - ;; more entries in .links, but that's fine: we can - ;; just stop. - #f) - ((= errno EMLINK) - ;; PATH has reached the maximum number of links, but - ;; that's OK: we just can't deduplicate it more. - #f) - (else (apply throw args))))))))))) + (mkdir-p links-directory) + (let loop ((path path) + (type (stat:type (lstat path))) + (hash hash)) + (if (eq? 'directory type) + ;; Can't hardlink directories, so hardlink their atoms. + (for-each (match-lambda + ((file . properties) + (unless (member file '("." "..")) + (let* ((file (string-append path "/" file)) + (type (match (assoc-ref properties 'type) + ((or 'unknown #f) + (stat:type (lstat file))) + (type type)))) + (loop file type + (and (not (eq? 'directory type)) + (nar-sha256 file))))))) + (scandir* path)) + (let ((link-file (string-append links-directory "/" + (bytevector->nix-base32-string hash)))) + (if (file-exists? link-file) + (replace-with-link link-file path + #:swap-directory links-directory + #:store store) + (catch 'system-error + (lambda () + (link path link-file)) + (lambda args + (let ((errno (system-error-errno args))) + (cond ((= errno EEXIST) + ;; Someone else put an entry for PATH in + ;; LINKS-DIRECTORY before we could. Let's use it. + (replace-with-link path link-file + #:swap-directory + links-directory + #:store store)) + ((= errno ENOSPC) + ;; There's not enough room in the directory index for + ;; more entries in .links, but that's fine: we can + ;; just stop. + #f) + ((= errno EMLINK) + ;; PATH has reached the maximum number of links, but + ;; that's OK: we just can't deduplicate it more. + #f) + (else (apply throw args))))))))))) diff --git a/guix/svn-download.scm b/guix/svn-download.scm index 59e2eb8d07..b96151234c 100644 --- a/guix/svn-download.scm +++ b/guix/svn-download.scm @@ -159,10 +159,11 @@ reports to LOG." (parameterize ((current-output-port log)) (build:svn-fetch (svn-reference-url ref) (svn-reference-revision ref) - temp + (string-append temp "/svn") #:user-name (svn-reference-user-name ref) #:password (svn-reference-password ref))))) (and result - (add-to-store store name #t "sha256" temp)))))) + (add-to-store store name #t "sha256" + (string-append temp "/svn"))))))) ;;; svn-download.scm ends here diff --git a/guix/swh.scm b/guix/swh.scm index a343ccfdd7..0b765cc743 100644 --- a/guix/swh.scm +++ b/guix/swh.scm @@ -22,7 +22,6 @@ #:use-module (guix build utils) #:use-module ((guix build syscalls) #:select (mkdtemp!)) #:use-module (web uri) - #:use-module (guix json) #:use-module (web client) #:use-module (web response) #:use-module (json) diff --git a/guix/ui.scm b/guix/ui.scm index efc3f39186..ecaf975c1f 100644 --- a/guix/ui.scm +++ b/guix/ui.scm @@ -15,6 +15,7 @@ ;;; Copyright © 2019 Tobias Geerinckx-Rice <me@tobias.gr> ;;; Copyright © 2019 Simon Tournier <zimon.toutoune@gmail.com> ;;; Copyright © 2020 Arun Isaac <arunisaac@systemreboot.net> +;;; Copyright © 2020 Maxim Cournoyer <maxim.cournoyer@gmail.com> ;;; ;;; This file is part of GNU Guix. ;;; @@ -60,6 +61,7 @@ ;; Avoid "overrides core binding" warning. delete)) #:use-module (srfi srfi-1) + #:use-module (srfi srfi-9 gnu) #:use-module (srfi srfi-11) #:use-module (srfi srfi-19) #:use-module (srfi srfi-26) @@ -494,7 +496,11 @@ guix package -i glibc-utf8-locales export GUIX_LOCPATH=\"$HOME/.guix-profile/lib/locale\" @end example -See the \"Application Setup\" section in the manual, for more info.\n"))))) +See the \"Application Setup\" section in the manual, for more info.\n")) + ;; We're now running in the "C" locale. Try to install a UTF-8 locale + ;; instead. This one is guaranteed to be available in 'guix' from 'guix + ;; pull'. + (false-if-exception (setlocale LC_ALL "en_US.utf8"))))) (define (initialize-guix) "Perform the usual initialization for stand-alone Guix commands." @@ -541,8 +547,9 @@ There is NO WARRANTY, to the extent permitted by law. Report bugs to: ~a.") %guix-bug-report-address) (format #t (G_ " ~a home page: <~a>") %guix-package-name %guix-home-page-url) - (display (G_ " -General help using GNU software: <http://www.gnu.org/gethelp/>")) + (format #t (G_ " +General help using Guix and GNU software: <~a>") + "https://guix.gnu.org/help/") (newline)) (define (augmented-system-error-handler file) @@ -1068,16 +1075,19 @@ summary, and level 0 shows nothing." (null? hook) (map colorized-store-item hook))) ((= verbosity 1) ;; Display the bare minimum; don't mention grafts and hooks. + (unless (null? build) + (newline (current-error-port))) (if display-download-size? (format (current-error-port) ;; TRANSLATORS: "MB" is for "megabyte"; it should be ;; translated to the corresponding abbreviation. - (G_ "~:[~,1h MB would be downloaded~%~;~]") + (highlight (G_ "~:[~,1h MB would be downloaded~%~;~]")) (null? download) download-size) (format (current-error-port) - (N_ "~:[~h item would be downloaded~%~;~]" - "~:[~h items would be downloaded~%~;~]" - (length download)) + (highlight + (N_ "~:[~h item would be downloaded~%~;~]" + "~:[~h items would be downloaded~%~;~]" + (length download))) (null? download) (length download)))))) (begin @@ -1116,16 +1126,19 @@ summary, and level 0 shows nothing." (null? hook) (map colorized-store-item hook))) ((= verbosity 1) ;; Display the bare minimum; don't mention grafts and hooks. + (unless (null? build) + (newline (current-error-port))) (if display-download-size? (format (current-error-port) ;; TRANSLATORS: "MB" is for "megabyte"; it should be ;; translated to the corresponding abbreviation. - (G_ "~:[~,1h MB will be downloaded~%~;~]") + (highlight (G_ "~:[~,1h MB will be downloaded~%~;~]")) (null? download) download-size) (format (current-error-port) - (N_ "~:[~h item will be downloaded~%~;~]" - "~:[~h items will be downloaded~%~;~]" - (length download)) + (highlight + (N_ "~:[~h item will be downloaded~%~;~]" + "~:[~h items will be downloaded~%~;~]" + (length download))) (null? download) (length download))))))) (check-available-space installed-size) @@ -1232,31 +1245,27 @@ separator between subsequent columns." (define* (show-manifest-transaction store manifest transaction #:key dry-run?) "Display what will/would be installed/removed from MANIFEST by TRANSACTION." - (define (package-strings names versions outputs) - (tabulate (zip (map (lambda (name output) - (if (string=? output "out") - name - (string-append name ":" output))) - names outputs) - versions) + (define* (package-strings names versions outputs #:key old-versions) + (tabulate (stable-sort + (zip (map (lambda (name output) + (if (string=? output "out") + name + (string-append name ":" output))) + names outputs) + (if old-versions + (map (lambda (old new) + (if (string=? old new) + (G_ "(dependencies or package changed)") + (string-append old " " → " " new))) + old-versions versions) + versions)) + (lambda (x y) + (string<? (first x) (first y)))) #:initial-indent 3)) (define → ;an arrow that can be represented on stderr (right-arrow (current-error-port))) - (define (upgrade-string names old-version new-version outputs) - (tabulate (zip (map (lambda (name output) - (if (string=? output "out") - name - (string-append name ":" output))) - names outputs) - (map (lambda (old new) - (if (string=? old new) - (G_ "(dependencies or package changed)") - (string-append old " " → " " new))) - old-version new-version)) - #:initial-indent 3)) - (let-values (((remove install upgrade downgrade) (manifest-transaction-effects manifest transaction))) (match remove @@ -1279,8 +1288,8 @@ separator between subsequent columns." (((($ <manifest-entry> name old-version) . ($ <manifest-entry> _ new-version output item)) ..1) (let ((len (length name)) - (downgrade (upgrade-string name old-version new-version - output))) + (downgrade (package-strings name new-version output + #:old-versions old-version))) (if dry-run? (format (current-error-port) (N_ "The following package would be downgraded:~%~{~a~%~}~%" @@ -1297,9 +1306,8 @@ separator between subsequent columns." (((($ <manifest-entry> name old-version) . ($ <manifest-entry> _ new-version output item)) ..1) (let ((len (length name)) - (upgrade (upgrade-string name - old-version new-version - output))) + (upgrade (package-strings name new-version output + #:old-versions old-version))) (if dry-run? (format (current-error-port) (N_ "The following package would be upgraded:~%~{~a~%~}~%" @@ -1988,6 +1996,44 @@ optionally contain a version number and an output name, as in these examples: (G_ "Try `guix --help' for more information.~%")) (exit 1)) +;; Representation of a 'guix' command. +(define-immutable-record-type <command> + (command name synopsis category) + command? + (name command-name) + (synopsis command-synopsis) + (category command-category)) + +(define (source-file-command file) + "Read FILE, a Scheme source file, and return either a <command> object based +on the 'define-command' top-level form found therein, or #f if FILE does not +contain a 'define-command' form." + (define command-name + (match (string-split file #\/) + ((_ ... "guix" "scripts" name) + (list (file-sans-extension name))) + ((_ ... "guix" "scripts" first second) + (list first (file-sans-extension second))))) + + ;; The strategy here is to parse FILE. This is much cheaper than a + ;; technique based on run-time introspection where we'd load FILE and all + ;; the modules it depends on. + (call-with-input-file file + (lambda (port) + (let loop () + (match (read port) + (('define-command _ ('synopsis synopsis) + _ ...) + (command command-name synopsis 'main)) + (('define-command _ + ('category category) ('synopsis synopsis) + _ ...) + (command command-name synopsis category)) + ((? eof-object?) + #f) + (_ + (loop))))))) + (define (command-files) "Return the list of source files that define Guix sub-commands." (define directory @@ -1999,28 +2045,51 @@ optionally contain a version number and an output name, as in these examples: (cut string-suffix? ".scm" <>)) (if directory - (scandir directory dot-scm?) + (map (cut string-append directory "/" <>) + (scandir directory dot-scm?)) '())) (define (commands) - "Return the list of Guix command names." - (map (compose (cut string-drop-right <> 4) - basename) - (command-files))) + "Return the list of commands, alphabetically sorted." + (filter-map source-file-command (command-files))) (define (show-guix-help) (define (internal? command) (member command '("substitute" "authenticate" "offload" "perform-download"))) + (define (display-commands commands) + (let* ((names (map (lambda (command) + (string-join (command-name command))) + commands)) + (max-width (reduce max 0 (map string-length names)))) + (for-each (lambda (name command) + (format #t " ~a ~a~%" + (string-pad-right name max-width) + (G_ (command-synopsis command)))) + names + commands))) + + (define (category-predicate category) + (lambda (command) + (eq? category (command-category command)))) + (format #t (G_ "Usage: guix COMMAND ARGS... Run COMMAND with ARGS.\n")) (newline) (format #t (G_ "COMMAND must be one of the sub-commands listed below:\n")) - (newline) - ;; TODO: Display a synopsis of each command. - (format #t "~{ ~a~%~}" (sort (remove internal? (commands)) - string<?)) + + (let ((commands (commands)) + (categories (module-ref (resolve-interface '(guix scripts)) + '%command-categories))) + (for-each (match-lambda + (('internal . _) + #t) ;hide internal commands + ((category . synopsis) + (format #t "~% ~a~%" (G_ synopsis)) + (display-commands (filter (category-predicate category) + commands)))) + categories)) (show-bug-report-information)) (define (run-guix-command command . args) |