aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorLudovic Courtès <ludo@gnu.org>2016-02-05 11:39:27 +0100
committerLudovic Courtès <ludo@gnu.org>2016-02-05 14:01:46 +0100
commit1d6b7d584736ff0ad9e852a39c7c151e10713580 (patch)
treeb80702c38f8d07b9232fb0e3ee916fdfcf4f0a7b
parent6b55ee88890c114f9829029c7d0c0c3f03bcda03 (diff)
downloadpatches-1d6b7d584736ff0ad9e852a39c7c151e10713580.tar
patches-1d6b7d584736ff0ad9e852a39c7c151e10713580.tar.gz
guix system: Simply warn if we cannot talk to the shepherd.
Before that 'open-connection' would return #f, and thus 'current-services' would return a single #f value when its continuation expects two. Reported by calher on #guix. * gnu/services/herd.scm (open-connection): Rethrow system-error exceptions. (with-shepherd): Expect CONNECTION to always be true; remove useless 'dynamic-wind'. * guix/scripts/system.scm (warn-on-system-error): New macro. (upgrade-shepherd-services): Wrap body in 'warn-on-system-error'.
-rw-r--r--gnu/services/herd.scm14
-rw-r--r--guix/scripts/system.scm84
2 files changed, 52 insertions, 46 deletions
diff --git a/gnu/services/herd.scm b/gnu/services/herd.scm
index 89a93a1969..a3a9bf0230 100644
--- a/gnu/services/herd.scm
+++ b/gnu/services/herd.scm
@@ -52,20 +52,14 @@ return the socket."
(connect sock address)
(setvbuf sock _IOFBF 1024)
sock)
- (lambda (key proc format-string format-args errno . rest)
- (warning (_ "cannot connect to ~a: ~a~%") file
- (apply format #f format-string format-args))
- #f)))))
+ (lambda args
+ (close-port sock)
+ (apply throw args))))))
(define-syntax-rule (with-shepherd connection body ...)
"Evaluate BODY... with CONNECTION bound to an open socket to PID 1."
(let ((connection (open-connection)))
- (and connection
- (dynamic-wind
- (const #t)
- (lambda ()
- body ...)
- (const #t)))))
+ body ...))
(define (report-action-error error)
"Report ERROR, an sexp received by a shepherd client in reply to COMMAND, a
diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm
index e13355d399..7279be0c43 100644
--- a/guix/scripts/system.scm
+++ b/guix/scripts/system.scm
@@ -211,6 +211,16 @@ the ownership of '~a' may be incorrect!~%")
(lambda ()
(environ env)))))
+(define-syntax-rule (warn-on-system-error body ...)
+ (catch 'system-error
+ (lambda ()
+ body ...)
+ (lambda (key proc format-string format-args errno . rest)
+ (warning (_ "while talking to shepherd: ~a~%")
+ (apply format #f format-string format-args))
+ (with-monad %store-monad
+ (return #f)))))
+
(define (upgrade-shepherd-services os)
"Upgrade the Shepherd (PID 1) by unloading obsolete services and loading new
services specified in OS and not currently running.
@@ -230,42 +240,44 @@ bring the system down."
(map (compose first shepherd-service-provision)
new-services))
- (let-values (((running stopped) (current-services)))
- (define to-load
- ;; Only load services that are either new or currently stopped.
- (remove (lambda (service)
- (memq (first (shepherd-service-provision service))
- running))
- new-services))
- (define to-unload
- ;; Unload services that are (1) no longer required, or (2) are in
- ;; TO-LOAD.
- (remove essential?
- (append (remove (lambda (service)
- (memq service new-service-names))
- (append running stopped))
- (filter (lambda (service)
- (memq service stopped))
- (map shepherd-service-canonical-name
- to-load)))))
-
- (for-each (lambda (unload)
- (info (_ "unloading service '~a'...~%") unload)
- (unload-service unload))
- to-unload)
-
- (with-monad %store-monad
- (munless (null? to-load)
- (let ((to-load-names (map shepherd-service-canonical-name to-load))
- (to-start (filter shepherd-service-auto-start? to-load)))
- (info (_ "loading new services:~{ ~a~}...~%") to-load-names)
- (mlet %store-monad ((files (mapm %store-monad shepherd-service-file
- to-load)))
- (load-services (map derivation->output-path files))
-
- (for-each start-service
- (map shepherd-service-canonical-name to-start))
- (return #t)))))))
+ ;; Arrange to simply emit a warning if we cannot connect to the shepherd.
+ (warn-on-system-error
+ (let-values (((running stopped) (current-services)))
+ (define to-load
+ ;; Only load services that are either new or currently stopped.
+ (remove (lambda (service)
+ (memq (first (shepherd-service-provision service))
+ running))
+ new-services))
+ (define to-unload
+ ;; Unload services that are (1) no longer required, or (2) are in
+ ;; TO-LOAD.
+ (remove essential?
+ (append (remove (lambda (service)
+ (memq service new-service-names))
+ (append running stopped))
+ (filter (lambda (service)
+ (memq service stopped))
+ (map shepherd-service-canonical-name
+ to-load)))))
+
+ (for-each (lambda (unload)
+ (info (_ "unloading service '~a'...~%") unload)
+ (unload-service unload))
+ to-unload)
+
+ (with-monad %store-monad
+ (munless (null? to-load)
+ (let ((to-load-names (map shepherd-service-canonical-name to-load))
+ (to-start (filter shepherd-service-auto-start? to-load)))
+ (info (_ "loading new services:~{ ~a~}...~%") to-load-names)
+ (mlet %store-monad ((files (mapm %store-monad shepherd-service-file
+ to-load)))
+ (load-services (map derivation->output-path files))
+
+ (for-each start-service
+ (map shepherd-service-canonical-name to-start))
+ (return #t))))))))
(define* (switch-to-system os
#:optional (profile %system-profile))