From 0c9d22c13fef9056413338293747c0d32f0cd5a4 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 27 Aug 2020 14:58:45 +0200 Subject: pull: Avoid "Migrating profile" message on the first run. * guix/scripts/pull.scm (ensure-default-profile): Do not call 'migrate-generations' when %USER-PROFILE-DIRECTORY (~/.config/guix/current) does not exist. This avoids a confusing "Migrating profile" message when the user runs 'guix pull' for the first time. --- guix/scripts/pull.scm | 1 + 1 file changed, 1 insertion(+) (limited to 'guix') diff --git a/guix/scripts/pull.scm b/guix/scripts/pull.scm index 5b4ccf13fe..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 ;; . (unless (or (getenv "SUDO_USER") + (not (file-exists? %user-profile-directory)) (string=? %profile-directory (dirname (canonicalize-profile %user-profile-directory)))) -- cgit v1.2.3 From 3d9ea605c8dfb7fc43689e12975218b032b3175a Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 28 Aug 2020 15:05:17 +0200 Subject: store: 'with-store' returns as many values as its body. Fixes . Reported by Ricardo Wurmus . * guix/store.scm (call-with-store)[thunk]: Wrap call to PROC in 'call-with-values'. * tests/store.scm ("with-store, multiple values"): New test. --- guix/store.scm | 7 ++++--- tests/store.scm | 9 +++++++++ 2 files changed, 13 insertions(+), 3 deletions(-) (limited to 'guix') diff --git a/guix/store.scm b/guix/store.scm index 683e125b20..495dc1692c 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 diff --git a/tests/store.scm b/tests/store.scm index ee3e01f33b..e168d3dcf6 100644 --- a/tests/store.scm +++ b/tests/store.scm @@ -141,6 +141,15 @@ (string-append (%store-prefix) "/" (make-string 32 #\e) "-foobar")))) +(test-equal "with-store, multiple values" ; + '(1 2 3) + (call-with-values + (lambda () + (with-store s + (add-text-to-store s "foo" "bar") + (values 1 2 3))) + list)) + (test-assert "valid-path? error" (with-store s (guard (c ((store-protocol-error? c) #t)) -- cgit v1.2.3 From 3e339c44103f494174d9c20405563135a95cecf9 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 28 Aug 2020 18:31:40 +0200 Subject: derivations: Avoid uses of 'display' in 'write-derivation'. This yields a 4% improvement on the wall-clock time of: guix build -e '(@@ (gnu packages libreoffice) libreoffice)' --no-grafts -d * guix/derivations.scm (write-sequence, write-list, write-tuple): Use 'put-char' instead of 'display'. (write-derivation): Use 'put-string' and 'put-char', and remove unused 'format' binding. --- guix/derivations.scm | 43 +++++++++++++++++++++---------------------- 1 file changed, 21 insertions(+), 22 deletions(-) (limited to 'guix') diff --git a/guix/derivations.scm b/guix/derivations.scm index 7db61d272f..4fc2e9e768 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,30 +562,29 @@ 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 (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'. (define (write-string-list lst) (write-list lst write port)) @@ -605,42 +605,41 @@ that form." (define (write-input input port) (match input (($ obj sub-drvs) - (display "(\"" port) + (put-string port "(\"") ;; 'derivation/masked-inputs' produces objects that contain a string ;; instead of a , 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) + (put-string port "(") (write name port) - (display "," port) + (put-string port ",") (write value port) - (display ")" port)))) + (put-string port ")")))) ;; Assume all the lists we are writing are already sorted. (match drv (($ 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) -- cgit v1.2.3 From 4ec66950f05e99f785c11fea2cbc1f2b079a7dbf Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 28 Aug 2020 19:19:04 +0200 Subject: derivations: Avoid uses of 'write' in 'write-derivation'. This leads a 4% improvement on the wall-clock time of: guix build -e '(@@ (gnu packages libreoffice) libreoffice)' --no-grafts -d * guix/derivations.scm (escaped-string): New procedure. (write-derivation)[write-escaped-string]: New procedure. [write-string-list, write-output, write-env-var]: Use it. --- guix/derivations.scm | 47 ++++++++++++++++++++++++++++++++++++++++------- 1 file changed, 40 insertions(+), 7 deletions(-) (limited to 'guix') diff --git a/guix/derivations.scm b/guix/derivations.scm index 4fc2e9e768..2fe684cc18 100644 --- a/guix/derivations.scm +++ b/guix/derivations.scm @@ -579,15 +579,48 @@ things as appropriate and is thus more efficient." (write-sequence lst write-item 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." ;; 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,7 +632,7 @@ that form." "") (or (and=> hash bytevector->base16-string) "")) - write + write-escaped-string port)))) (define (write-input input port) @@ -619,11 +652,11 @@ that form." (define (write-env-var env-var port) (match env-var ((name . value) - (put-string port "(") - (write name port) - (put-string port ",") - (write value port) - (put-string 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 -- cgit v1.2.3 From 61fe9ced7da7eefceb931af0cb7363b721f5bdd6 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sat, 29 Aug 2020 16:05:05 +0200 Subject: copy, offload: Explicitly close SSH channels and sessions. Fixes . * guix/scripts/copy.scm (send-to-remote-host): Keep the result of 'connect-to-remote-daemon' in scope, and explicitly close it after the call to 'send-files'. (retrieve-from-remote-host): Explicitly close REMOTE and disconnect SESSION. * guix/scripts/offload.scm (transfer-and-offload): Explicitly close STORE and disconnect SESSION upon completion. --- guix/scripts/copy.scm | 8 ++++++-- guix/scripts/offload.scm | 2 ++ 2 files changed, 8 insertions(+), 2 deletions(-) (limited to 'guix') diff --git a/guix/scripts/copy.scm b/guix/scripts/copy.scm index 16d2de30f7..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))) diff --git a/guix/scripts/offload.scm b/guix/scripts/offload.scm index a56701f07a..1e0e9d7905 100644 --- a/guix/scripts/offload.scm +++ b/guix/scripts/offload.scm @@ -365,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))) -- cgit v1.2.3 From bc8be17c4dd1e7bb8eb98a0b7e5bcb0a536719b0 Mon Sep 17 00:00:00 2001 From: Lars-Dominik Braun Date: Tue, 25 Aug 2020 10:52:21 +0200 Subject: environment: Set USER and LOGNAME in container MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit * guix/scripts/environment.scm (launch-environment/container): Set username environment variables. Signed-off-by: Ludovic Courtès --- guix/scripts/environment.scm | 5 +++++ 1 file changed, 5 insertions(+) (limited to 'guix') diff --git a/guix/scripts/environment.scm b/guix/scripts/environment.scm index b8979cac19..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) -- cgit v1.2.3 From b03267df6d5ec44e9617b6aab0df14a2e79f822e Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 31 Aug 2020 11:36:26 +0200 Subject: ssh: 'send-files' displays a progress bar. * guix/store.scm (export-paths): Add #:start, #:progress, and #:finish parameters and honor them. * guix/ssh.scm (prepare-to-send, notify-transfer-progress) (notify-transfer-completion): New procedures. (send-files): Pass #:start, #:progress, and #:finish to 'export-paths'. --- guix/ssh.scm | 77 +++++++++++++++++++++++++++++++++++++++++++++++----------- guix/store.scm | 24 +++++++++++++++--- 2 files changed, 83 insertions(+), 18 deletions(-) (limited to 'guix') diff --git a/guix/ssh.scm b/guix/ssh.scm index 24db171374..5f94528520 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,55 @@ 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)) + + (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? @@ -412,7 +466,7 @@ Return the list of store items actually sent." ;; Compute the subset of FILES missing on SESSION and send them. (let* ((files (if recursive? (requisites local files) files)) (session (channel-get-session (store-connection-socket remote))) - (missing (inferior-remote-eval + (missing (take files 20) #;(inferior-remote-eval `(begin (use-modules (guix) (srfi srfi-1) (srfi srfi-26)) @@ -421,11 +475,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 +484,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 495dc1692c..6bb6f43f56 100644 --- a/guix/store.scm +++ b/guix/store.scm @@ -1728,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. @@ -1739,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. -- cgit v1.2.3 From 83ec969cc7170634872d4ff3ffc0d4099a6765a4 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 31 Aug 2020 12:24:21 +0200 Subject: packages: printer gracefully handle #f values. Suggested by Robin Green . * guix/packages.scm (print-content-hash): Gracefully deal with cases with 'content-hash-value' returns #f, as is the case for 'linux-libre'. --- guix/packages.scm | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) (limited to 'guix') 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-algorithm hash) - (bytevector->nix-base32-string (content-hash-value hash)))) + (and=> (content-hash-value hash) + bytevector->nix-base32-string))) (set-record-type-printer! print-content-hash) -- cgit v1.2.3 From a4e81ff325aa1e0381ec73a57e41a208317b60d6 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 31 Aug 2020 14:54:52 +0200 Subject: guix system: reconfigure: Tell users about 'herd status'. * guix/scripts/system.scm (perform-action): Mention 'herd status' when 'upgrade-shepherd-services' completes. --- guix/scripts/system.scm | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm index f6d20382b6..7d6fc63a98 100644 --- a/guix/scripts/system.scm +++ b/guix/scripts/system.scm @@ -835,7 +835,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'...~%") -- cgit v1.2.3 From 7e90e28a156ddc25e3822b931a608890caf3efee Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 31 Aug 2020 15:09:55 +0200 Subject: guix system: Clarify what happens where service upgrade fails. * guix/scripts/system.scm (report-shepherd-error): Use 'warning' instead of 'report-error'. Add extra 'warning' and 'display-hint' calls. --- guix/scripts/system.scm | 47 ++++++++++++++++++++++++++--------------------- 1 file changed, 26 insertions(+), 21 deletions(-) (limited to 'guix') diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm index 7d6fc63a98..3222a53c8f 100644 --- a/guix/scripts/system.scm +++ b/guix/scripts/system.scm @@ -271,28 +271,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 -- cgit v1.2.3 From 036f23f053ee6bd34c6d387debb4a9166561dd02 Mon Sep 17 00:00:00 2001 From: Julien Lepiller Date: Sat, 29 Aug 2020 15:34:56 +0200 Subject: guix: system: Add `--label' option. * guix/scripts/system.scm (%options): Add `--label'. (system-derivation-for-action): Take a #:label key to set volume ID. (perform-action): Take a #:label key. (%default-options): Add default label value. (process-action): Pass label value from command-line to perform-action. * gnu/system/image.scm (image-with-label): New procedure. --- doc/guix.texi | 4 +++- gnu/system/image.scm | 17 ++++++++++++++++- guix/scripts/system.scm | 18 ++++++++++++++---- 3 files changed, 33 insertions(+), 6 deletions(-) (limited to 'guix') diff --git a/doc/guix.texi b/doc/guix.texi index 6206a93857..56b1cd8976 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -28836,7 +28836,9 @@ the @option{--image-size} option is ignored in the case of @code{docker-image}. You can specify the root file system type by using the -@option{--file-system-type} option. It defaults to @code{ext4}. +@option{--file-system-type} option. It defaults to @code{ext4}. When its +value is @code{iso9660}, the @option{--label} option can be used to specify +a volume ID with @code{disk-image}. When using @code{vm-image}, the returned image is in qcow2 format, which the QEMU emulator can efficiently use. @xref{Running Guix in a VM}, diff --git a/gnu/system/image.scm b/gnu/system/image.scm index c1a718d607..733f2bfa8d 100644 --- a/gnu/system/image.scm +++ b/gnu/system/image.scm @@ -63,7 +63,8 @@ iso9660-image find-image - system-image)) + system-image + image-with-label)) ;;; @@ -407,6 +408,20 @@ used in the image. " #:references-graphs ,inputs #:substitutable? ,substitutable?)))) +(define (image-with-label base-image label) + "The volume ID of an ISO is the label of the first partition. This procedure +returns an image record where the first partition's label is set to