02/04: guix system: Simply warn if we cannot talk to the shepherd.

[Ludovic Courtès]

civodul pushed a commit to branch master
in repository guix.

commit 1d6b7d584736ff0ad9e852a39c7c151e10713580
Author: Ludovic Courtès <address@hidden>
Date:   Fri Feb 5 11:39:27 2016 +0100

    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'.
---
 gnu/services/herd.scm   |   14 ++-----
 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 89a93a1..a3a9bf0 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 e13355d..7279be0 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))