diff options
Diffstat (limited to 'guix/scripts')
| -rw-r--r-- | guix/scripts/archive.scm | 2 | ||||
| -rw-r--r-- | guix/scripts/build.scm | 2 | ||||
| -rw-r--r-- | guix/scripts/copy.scm | 10 | ||||
| -rw-r--r-- | guix/scripts/deploy.scm | 31 | ||||
| -rw-r--r-- | guix/scripts/environment.scm | 7 | ||||
| -rw-r--r-- | guix/scripts/graph.scm | 9 | ||||
| -rw-r--r-- | guix/scripts/lint.scm | 39 | ||||
| -rw-r--r-- | guix/scripts/offload.scm | 39 | ||||
| -rw-r--r-- | guix/scripts/pack.scm | 19 | ||||
| -rw-r--r-- | guix/scripts/package.scm | 2 | ||||
| -rw-r--r-- | guix/scripts/processes.scm | 5 | ||||
| -rw-r--r-- | guix/scripts/publish.scm | 15 | ||||
| -rw-r--r-- | guix/scripts/pull.scm | 3 | ||||
| -rwxr-xr-x | guix/scripts/substitute.scm | 10 | ||||
| -rw-r--r-- | guix/scripts/system.scm | 103 | ||||
| -rw-r--r-- | guix/scripts/system/reconfigure.scm | 22 | ||||
| -rw-r--r-- | guix/scripts/upgrade.scm | 3 |
17 files changed, 204 insertions, 117 deletions
diff --git a/guix/scripts/archive.scm b/guix/scripts/archive.scm index 41a2a42c21..f3b86fba14 100644 --- a/guix/scripts/archive.scm +++ b/guix/scripts/archive.scm @@ -380,6 +380,8 @@ output port." (with-build-handler (build-notifier #:use-substitutes? (assoc-ref opts 'substitutes?) + #:verbosity + (assoc-ref opts 'verbosity) #:dry-run? (assoc-ref opts 'dry-run?)) (cond ((assoc-ref opts 'export) diff --git a/guix/scripts/build.scm b/guix/scripts/build.scm index 8ff2fd1910..6286a43c02 100644 --- a/guix/scripts/build.scm +++ b/guix/scripts/build.scm @@ -961,6 +961,8 @@ needed." (with-build-handler (build-notifier #:use-substitutes? (assoc-ref opts 'substitutes?) + #:verbosity + (assoc-ref opts 'verbosity) #:dry-run? (assoc-ref opts 'dry-run?)) (parameterize ((current-terminal-columns (terminal-columns)) diff --git a/guix/scripts/copy.scm b/guix/scripts/copy.scm index f6f64d0a11..274620fc1e 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))) @@ -175,6 +179,8 @@ Copy ITEMS to or from the specified host over SSH.\n")) (set-build-options-from-command-line store opts) (with-build-handler (build-notifier #:use-substitutes? (assoc-ref opts 'substitutes?) + #:verbosity + (assoc-ref opts 'verbosity) #:dry-run? (assoc-ref opts 'dry-run?)) (with-status-verbosity (assoc-ref opts 'verbosity) diff --git a/guix/scripts/deploy.scm b/guix/scripts/deploy.scm index 4466a0c632..4a68197620 100644 --- a/guix/scripts/deploy.scm +++ b/guix/scripts/deploy.scm @@ -140,18 +140,21 @@ Perform the deployment specified by FILE.\n")) (define (handle-argument arg result) (alist-cons 'file arg result)) - (let* ((opts (parse-command-line args %options (list %default-options) - #:argument-handler handle-argument)) - (file (assq-ref opts 'file)) - (machines (or (and file (load-source-file file)) '()))) - (show-what-to-deploy machines) + (with-error-handling + (let* ((opts (parse-command-line args %options (list %default-options) + #:argument-handler handle-argument)) + (file (assq-ref opts 'file)) + (machines (or (and file (load-source-file file)) '()))) + (show-what-to-deploy machines) - (with-status-verbosity (assoc-ref opts 'verbosity) - (with-store store - (set-build-options-from-command-line store opts) - (with-build-handler (build-notifier #:use-substitutes? - (assoc-ref opts 'substitutes?)) - (parameterize ((%graft? (assq-ref opts 'graft?))) - (map/accumulate-builds store - (cut deploy-machine* store <>) - machines))))))) + (with-status-verbosity (assoc-ref opts 'verbosity) + (with-store store + (set-build-options-from-command-line store opts) + (with-build-handler (build-notifier #:use-substitutes? + (assoc-ref opts 'substitutes?) + #:verbosity + (assoc-ref opts 'verbosity)) + (parameterize ((%graft? (assq-ref opts 'graft?))) + (map/accumulate-builds store + (cut deploy-machine* store <>) + machines)))))))) diff --git a/guix/scripts/environment.scm b/guix/scripts/environment.scm index d3b8b57ccc..1fb3505307 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) @@ -708,6 +713,8 @@ message if any test fails." (with-store store (with-build-handler (build-notifier #:use-substitutes? (assoc-ref opts 'substitutes?) + #:verbosity + (assoc-ref opts 'verbosity) #:dry-run? (assoc-ref opts 'dry-run?)) (with-status-verbosity (assoc-ref opts 'verbosity) diff --git a/guix/scripts/graph.scm b/guix/scripts/graph.scm index 489931d5bb..73d9269de2 100644 --- a/guix/scripts/graph.scm +++ b/guix/scripts/graph.scm @@ -32,7 +32,8 @@ #:use-module ((guix build-system gnu) #:select (standard-packages)) #:use-module (gnu packages) #:use-module (guix sets) - #:use-module ((guix utils) #:select (location-file)) + #:use-module ((guix diagnostics) + #:select (location-file formatted-message)) #:use-module ((guix scripts build) #:select (show-transformation-options-help options->transformation @@ -90,10 +91,8 @@ name." package) (x (raise - (condition - (&message - (message (format #f (G_ "~a: invalid argument (package name expected)") - x)))))))) + (formatted-message (G_ "~a: invalid argument (package name expected)") + x))))) (define nodes-from-package ;; The default conversion method. diff --git a/guix/scripts/lint.scm b/guix/scripts/lint.scm index 97ffd57301..5168a1ca17 100644 --- a/guix/scripts/lint.scm +++ b/guix/scripts/lint.scm @@ -1,7 +1,7 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2014 Cyril Roelandt <tipecaml@gmail.com> ;;; Copyright © 2014, 2015 Eric Bavier <bavier@member.fsf.org> -;;; 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 © 2015, 2016 Mathieu Lirzin <mthl@gnu.org> ;;; Copyright © 2016 Danny Milosavljevic <dannym+a@scratchpost.org> ;;; Copyright © 2016 Hartmut Goebel <h.goebel@crazy-compilers.com> @@ -174,23 +174,24 @@ run the checkers on all packages.\n")) (when (assoc-ref opts 'list?) (list-checkers-and-exit checkers)) - (let ((any-lint-checker-requires-store? - (any lint-checker-requires-store? checkers))) + (with-error-handling + (let ((any-lint-checker-requires-store? + (any lint-checker-requires-store? checkers))) - (define (call-maybe-with-store proc) - (if any-lint-checker-requires-store? - (with-store store - (proc store)) - (proc #f))) + (define (call-maybe-with-store proc) + (if any-lint-checker-requires-store? + (with-store store + (proc store)) + (proc #f))) - (call-maybe-with-store - (lambda (store) - (cond - ((null? args) - (fold-packages (lambda (p r) (run-checkers p checkers - #:store store)) '())) - (else - (for-each (lambda (spec) - (run-checkers (specification->package spec) checkers - #:store store)) - args)))))))) + (call-maybe-with-store + (lambda (store) + (cond + ((null? args) + (fold-packages (lambda (p r) (run-checkers p checkers + #:store store)) '())) + (else + (for-each (lambda (spec) + (run-checkers (specification->package spec) checkers + #:store store)) + args))))))))) diff --git a/guix/scripts/offload.scm b/guix/scripts/offload.scm index e81b6c25f2..1e0e9d7905 100644 --- a/guix/scripts/offload.scm +++ b/guix/scripts/offload.scm @@ -1,6 +1,7 @@ ;;; 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 Ricardo Wurmus <rekado@elephly.net> +;;; Copyright © 2020 Maxim Cournoyer <maxim.cournoyer@gmail.com> ;;; ;;; This file is part of GNU Guix. ;;; @@ -33,11 +34,12 @@ #:use-module ((guix serialization) #:select (nar-error? nar-error-file)) #:use-module (guix nar) - #:use-module (guix utils) + #:use-module ((guix utils) #:select (%current-system)) #:use-module ((guix build syscalls) #:select (fcntl-flock set-thread-name)) #:use-module ((guix build utils) #:select (which mkdir-p)) #:use-module (guix ui) + #:use-module (guix diagnostics) #:use-module (srfi srfi-1) #:use-module (srfi srfi-11) #:use-module (srfi srfi-26) @@ -65,14 +67,16 @@ ;;; ;;; Code: - (define-record-type* <build-machine> build-machine make-build-machine build-machine? (name build-machine-name) ; string (port build-machine-port ; number (default 22)) - (system build-machine-system) ; string + (systems %build-machine-systems ; list of strings + (default #f)) ; drop default after system is removed + (system %build-machine-system ; deprecated + (default #f)) (user build-machine-user) ; string (private-key build-machine-private-key ; file name (default (user-openssh-private-key))) @@ -90,6 +94,19 @@ (features build-machine-features ; list of strings (default '()))) +;;; Deprecated. +(define (build-machine-system machine) + (warning (G_ "The 'system' field is deprecated, \ +please use 'systems' instead.~%")) + (%build-machine-system machine)) + +;;; TODO: Remove after the deprecated 'system' field is removed. +(define (build-machine-systems machine) + (or (%build-machine-systems machine) + (list (build-machine-system machine)) + (leave (G_ "The build-machine object lacks a value for its 'systems' +field.")))) + (define-record-type* <build-requirements> build-requirements make-build-requirements build-requirements? @@ -156,10 +173,9 @@ can interpret meaningfully." (lambda () (private-key-from-file file)) (lambda (key proc str . rest) - (raise (condition - (&message (message (format #f (G_ "failed to load SSH \ + (raise (formatted-message (G_ "failed to load SSH \ private key from '~a': ~a") - file str)))))))) + file str))))) (define* (open-ssh-session machine #:optional (max-silent-time -1)) "Open an SSH session for MACHINE and return it. Throw an error on failure." @@ -349,6 +365,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))) @@ -359,8 +377,8 @@ of free disk space on '~a'~%") (define (machine-matches? machine requirements) "Return #t if MACHINE matches REQUIREMENTS." - (and (string=? (build-requirements-system requirements) - (build-machine-system machine)) + (and (member (build-requirements-system requirements) + (build-machine-systems machine)) (lset<= string=? (build-requirements-features requirements) (build-machine-features machine)))) @@ -779,7 +797,8 @@ machine." (("--version") (show-version-and-exit "guix offload")) (("--help") - (format #t (G_ "Usage: guix offload SYSTEM PRINT-BUILD-TRACE + (format #t (G_ "Usage: guix offload SYSTEM MAX-SILENT-TIME \ +PRINT-BUILD-TRACE? BUILD-TIMEOUT Process build offload requests written on the standard input, possibly offloading builds to the machines listed in '~a'.~%") %machine-file) diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm index 5fb6aaae0c..9d6881fdaf 100644 --- a/guix/scripts/pack.scm +++ b/guix/scripts/pack.scm @@ -744,11 +744,13 @@ last resort for relocation." (with-imported-modules (source-module-closure '((guix build utils) (guix build union) + (guix build gremlin) (guix elf))) #~(begin (use-modules (guix build utils) ((guix build union) #:select (relative-file-name)) (guix elf) + (guix build gremlin) (ice-9 binary-ports) (ice-9 ftw) (ice-9 match) @@ -786,6 +788,14 @@ last resort for relocation." bv 0 (bytevector-length bv)) (utf8->string bv))))) + (define (runpath file) + ;; Return the RUNPATH of FILE as a list of directories. + (let* ((bv (call-with-input-file file get-bytevector-all)) + (elf (parse-elf bv)) + (dyninfo (elf-dynamic-info elf))) + (or (and=> dyninfo elf-dynamic-info-runpath) + '()))) + (define (elf-loader-compile-flags program) ;; Return the cpp flags defining macros for the ld.so/fakechroot ;; wrapper of PROGRAM. @@ -807,6 +817,13 @@ last resort for relocation." (string-append "-DLOADER_AUDIT_MODULE=\"" #$(audit-module) "\"") + (string-append "-DLOADER_AUDIT_RUNPATH={ " + (string-join + (map object->string + (runpath + #$(audit-module))) + ", " 'suffix) + "NULL }") (if gconv (string-append "-DGCONV_DIRECTORY=\"" gconv "\"") @@ -1136,6 +1153,8 @@ Create a bundle of PACKAGE.\n")) (with-build-handler (build-notifier #:dry-run? (assoc-ref opts 'dry-run?) + #:verbosity + (assoc-ref opts 'verbosity) #:use-substitutes? (assoc-ref opts 'substitutes?)) (parameterize ((%graft? (assoc-ref opts 'graft?)) diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm index 1246147798..ac8dedb5f3 100644 --- a/guix/scripts/package.scm +++ b/guix/scripts/package.scm @@ -965,6 +965,8 @@ option processing with 'parse-command-line'." (set-build-options-from-command-line (%store) opts) (with-build-handler (build-notifier #:use-substitutes? (assoc-ref opts 'substitutes?) + #:verbosity + (assoc-ref opts 'verbosity) #:dry-run? (assoc-ref opts 'dry-run?)) (parameterize ((%guile-for-build diff --git a/guix/scripts/processes.scm b/guix/scripts/processes.scm index 01f7213e8c..35698a0216 100644 --- a/guix/scripts/processes.scm +++ b/guix/scripts/processes.scm @@ -235,4 +235,7 @@ List the current Guix sessions and their processes.")) (for-each (lambda (session) (daemon-session->recutils session port) (newline port)) - (daemon-sessions)))) + (daemon-sessions)) + + ;; Pass 'R' (instead of 'r') so 'less' correctly estimates line length. + #:less-options "FRX")) diff --git a/guix/scripts/publish.scm b/guix/scripts/publish.scm index a00f08f9d9..61542f83a0 100644 --- a/guix/scripts/publish.scm +++ b/guix/scripts/publish.scm @@ -50,10 +50,9 @@ #:use-module (guix workers) #:use-module (guix store) #:use-module ((guix serialization) #:select (write-file)) - #:use-module (guix zlib) - #:autoload (guix lzlib) (lzlib-available? - call-with-lzip-output-port - make-lzip-output-port) + #:use-module (zlib) + #:autoload (lzlib) (call-with-lzip-output-port + make-lzip-output-port) #:use-module (guix cache) #:use-module (guix ui) #:use-module (guix scripts) @@ -880,8 +879,8 @@ blocking." "Return a symbol denoting the compression method expressed by STRING; return #f if STRING doesn't match any supported method." (match string - ("gzip" (and (zlib-available?) 'gzip)) - ("lzip" (and (lzlib-available?) 'lzip)) + ("gzip" 'gzip) + ("lzip" 'lzip) (_ #f))) (define (effective-compression requested-type compressions) @@ -1032,9 +1031,7 @@ methods, return the applicable compression." opts) (() ;; Default to fast & low compression. - (list (if (zlib-available?) - %default-gzip-compression - %no-compression))) + (list %default-gzip-compression)) (lst (reverse lst)))) (address (let ((addr (assoc-ref opts 'address))) (make-socket-address (sockaddr:fam addr) diff --git a/guix/scripts/pull.scm b/guix/scripts/pull.scm index 807daec593..3b980b8f3f 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)))) @@ -773,6 +774,8 @@ Use '~/.config/guix/channels.scm' instead.")) (%graft? (assoc-ref opts 'graft?))) (with-build-handler (build-notifier #:use-substitutes? substitutes? + #:verbosity + (assoc-ref opts 'verbosity) #:dry-run? dry-run?) (set-build-options-from-command-line store opts) (ensure-default-profile) diff --git a/guix/scripts/substitute.scm b/guix/scripts/substitute.scm index ba2b2d2d4e..117d824449 100755 --- a/guix/scripts/substitute.scm +++ b/guix/scripts/substitute.scm @@ -41,7 +41,6 @@ #:use-module (guix progress) #:use-module ((guix build syscalls) #:select (set-thread-name)) - #:autoload (guix lzlib) (lzlib-available?) #:use-module (ice-9 rdelim) #:use-module (ice-9 regex) #:use-module (ice-9 match) @@ -912,7 +911,7 @@ authorized substitutes." ;; Known compression methods and a thunk to determine whether they're ;; supported. See 'decompressed-port' in (guix utils). `(("gzip" . ,(const #t)) - ("lzip" . ,lzlib-available?) + ("lzip" . ,(const #t)) ("xz" . ,(const #t)) ("bzip2" . ,(const #t)) ("none" . ,(const #t)))) @@ -1127,12 +1126,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 79bfcd7db2..b75b0e5b60 100644 --- a/guix/scripts/system.scm +++ b/guix/scripts/system.scm @@ -6,6 +6,7 @@ ;;; 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> ;;; ;;; This file is part of GNU Guix. ;;; @@ -271,28 +272,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 @@ -565,16 +571,14 @@ any, are available. Raise an error if they're not." (define fail? #f) (define (file-system-location* fs) - (location->string - (source-properties->location - (file-system-location fs)))) + (and=> (file-system-location fs) + source-properties->location)) (let-syntax ((error (syntax-rules () ((_ args ...) (begin (set! fail? #t) - (format (current-error-port) - args ...)))))) + (report-error args ...)))))) (for-each (lambda (fs) (catch 'system-error (lambda () @@ -582,9 +586,9 @@ any, are available. Raise an error if they're not." (lambda args (let ((errno (system-error-errno args)) (device (file-system-device fs))) - (error (G_ "~a: error: device '~a' not found: ~a~%") - (file-system-location* fs) device - (strerror errno)) + (error (file-system-location* fs) + (G_ "device '~a' not found: ~a~%") + device (strerror errno)) (unless (string-prefix? "/" device) (display-hint (format #f (G_ "If '~a' is a file system label, write @code{(file-system-label ~s)} in your @code{device} field.") @@ -594,13 +598,14 @@ label, write @code{(file-system-label ~s)} in your @code{device} field.") (let ((label (file-system-label->string (file-system-device fs)))) (unless (find-partition-by-label label) - (error (G_ "~a: error: file system with label '~a' not found~%") - (file-system-location* fs) label)))) + (error (file-system-location* fs) + (G_ "file system with label '~a' not found~%") + label)))) labeled) (for-each (lambda (fs) (unless (find-partition-by-uuid (file-system-device fs)) - (error (G_ "~a: error: file system with UUID '~a' not found~%") - (file-system-location* fs) + (error (file-system-location* fs) + (G_ "file system with UUID '~a' not found~%") (uuid->string (file-system-device fs))))) uuid) @@ -663,7 +668,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) @@ -687,7 +692,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) @@ -742,7 +747,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)) @@ -796,6 +801,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? @@ -836,7 +842,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'...~%") @@ -944,6 +952,8 @@ 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")) @@ -1009,6 +1019,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))) @@ -1066,7 +1079,14 @@ 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." + (or (assoc-ref opts 'verbosity) + (if (eq? (assoc-ref opts 'action) 'build) + 2 1))) ;;; @@ -1114,6 +1134,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))) @@ -1127,6 +1148,8 @@ resulting from command-line parsing." (with-build-handler (build-notifier #:use-substitutes? (assoc-ref opts 'substitutes?) + #:verbosity + (verbosity-level opts) #:dry-run? (assoc-ref opts 'dry-run?)) (run-with-store store @@ -1162,6 +1185,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))))) @@ -1283,8 +1307,7 @@ argument list and OPTS is the option alist." (args (option-arguments opts)) (command (assoc-ref opts 'action))) (parameterize ((%graft? (assoc-ref opts 'graft?))) - (with-status-verbosity (or (assoc-ref opts 'verbosity) - (if (eq? command 'build) 2 1)) + (with-status-verbosity (verbosity-level opts) (process-command command args opts)))))) ;;; Local Variables: diff --git a/guix/scripts/system/reconfigure.scm b/guix/scripts/system/reconfigure.scm index 9013e035f7..45bb1d5d3b 100644 --- a/guix/scripts/system/reconfigure.scm +++ b/guix/scripts/system/reconfigure.scm @@ -39,7 +39,6 @@ #:autoload (guix git) (update-cached-checkout) #:use-module (guix i18n) #:use-module (guix diagnostics) - #:use-module ((guix utils) #:select (&fix-hint)) #:use-module (ice-9 match) #:use-module (srfi srfi-1) #:use-module (srfi srfi-11) @@ -340,24 +339,25 @@ to commits of channels in NEW." old)) (define* (check-forward-update #:optional - (validate-reconfigure ensure-forward-reconfigure)) + (validate-reconfigure + ensure-forward-reconfigure) + #:key + (current-channels + (system-provenance "/run/current-system"))) "Call VALIDATE-RECONFIGURE passing it, for each channel, the channel, the -currently-deployed commit (as returned by 'guix system describe') and the -target commit (as returned by 'guix describe')." - ;; TODO: Make that functionality available to 'guix deploy'. +currently-deployed commit (from CURRENT-CHANNELS, which is as returned by +'guix system describe' by default) and the target commit (as returned by 'guix +describe')." (define new (or (and=> (current-profile) profile-channels) '())) - (define old - (system-provenance "/run/current-system")) - - (when (null? old) - (warning (G_ "cannot determine provenance for /run/current-system~%"))) + (when (null? current-channels) + (warning (G_ "cannot determine provenance for current system~%"))) (when (and (null? new) (not (getenv "GUIX_UNINSTALLED"))) (warning (G_ "cannot determine provenance of ~a~%") %guix-package-name)) (for-each (match-lambda ((channel old new relation) (validate-reconfigure channel old new relation))) - (channel-relations old new))) + (channel-relations current-channels new))) diff --git a/guix/scripts/upgrade.scm b/guix/scripts/upgrade.scm index 7f14a2fdbe..d2784669be 100644 --- a/guix/scripts/upgrade.scm +++ b/guix/scripts/upgrade.scm @@ -1,5 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2019 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2020 Jakub Kądziołka <kuba@kadziolka.net> ;;; ;;; This file is part of GNU Guix. ;;; @@ -60,7 +61,7 @@ This is an alias for 'guix package -u'.\n")) ;; Preserve some of the 'guix package' options. (append (filter (lambda (option) (any (cut member <> (option-names option)) - '("profile" "dry-run" "verbosity"))) + '("profile" "dry-run" "verbosity" "do-not-upgrade"))) %package-options) %transformation-options |