diff options
| -rw-r--r-- | gnu/services/herd.scm | 14 | ||||
| -rw-r--r-- | guix/scripts/system.scm | 84 |
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)) |