[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
01/09: services: herd: Move UI handling to 'guix system'.
From: |
Ludovic Courtès |
Subject: |
01/09: services: herd: Move UI handling to 'guix system'. |
Date: |
Wed, 04 May 2016 21:37:20 +0000 |
civodul pushed a commit to branch master
in repository guix.
commit 8bf92e3904cb656d4c2160fc8befebaf21a65492
Author: Ludovic Courtès <address@hidden>
Date: Wed May 4 16:38:22 2016 +0200
services: herd: Move UI handling to 'guix system'.
This makes (gnu services herd) independent of (guix ui).
* gnu/services/herd.scm (&shepherd-error, &service-not-found-error)
(&action-not-found-error, &action-exception-error)
(&unknown-shepherd-error): New error condition types.
(report-action-error): Remove.
(raise-shepherd-error): New procedure.
(display-message): Do not use 'info' and '_'.
(invoke-action): Use 'raise-shepherd-error' instead of
'report-action-error'. Do not use 'warning'.
(current-services): Do not use 'warning'.
* guix/scripts/system.scm (with-shepherd-error-handling): New macro.
(report-shepherd-error, call-with-service-upgrade-info): New
procedures.
(upgrade-shepherd-services): Use it.
---
gnu/services/herd.scm | 80 +++++++++++++++++++-------
guix/scripts/system.scm | 142 +++++++++++++++++++++++++++++++----------------
2 files changed, 153 insertions(+), 69 deletions(-)
diff --git a/gnu/services/herd.scm b/gnu/services/herd.scm
index 9cb33a9..c06e988 100644
--- a/gnu/services/herd.scm
+++ b/gnu/services/herd.scm
@@ -17,12 +17,27 @@
;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
(define-module (gnu services herd)
- #:use-module (guix ui)
#:use-module (guix utils)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-11)
+ #:use-module (srfi srfi-34)
+ #:use-module (srfi srfi-35)
#:use-module (ice-9 match)
- #:export (current-services
+ #:export (shepherd-error?
+ service-not-found-error?
+ service-not-found-error-service
+ action-not-found-error?
+ action-not-found-error-service
+ action-not-found-error-action
+ action-exception-error?
+ action-exception-error-service
+ action-exception-error-action
+ action-exception-error-key
+ action-exception-error-arguments
+ unknown-shepherd-error?
+ unknown-shepherd-error-sexp
+
+ current-services
unload-services
unload-service
load-services
@@ -61,31 +76,54 @@ return the socket."
(let ((connection (open-connection)))
body ...))
-(define (report-action-error error)
- "Report ERROR, an sexp received by a shepherd client in reply to COMMAND, a
-command object."
+(define-condition-type &shepherd-error &error
+ shepherd-error?)
+
+(define-condition-type &service-not-found-error &shepherd-error
+ service-not-found-error?
+ (service service-not-found-error-service))
+
+(define-condition-type &action-not-found-error &shepherd-error
+ action-not-found-error?
+ (service action-not-found-error-service)
+ (action action-not-found-error-action))
+
+(define-condition-type &action-exception-error &shepherd-error
+ action-exception-error?
+ (service action-exception-error-service)
+ (action action-exception-error-action)
+ (key action-exception-error-key)
+ (args action-exception-error-arguments))
+
+(define-condition-type &unknown-shepherd-error &shepherd-error
+ unknown-shepherd-error?
+ (sexp unknown-shepherd-error-sexp))
+
+(define (raise-shepherd-error error)
+ "Raise an error condition corresponding to ERROR, an sexp received by a
+shepherd client in reply to COMMAND, a command object. Return #t if ERROR
+does not denote an error."
(match error
(('error ('version 0 x ...) 'service-not-found service)
- (report-error (_ "service '~a' could not be found~%")
- service))
+ (raise (condition (&service-not-found-error
+ (service service)))))
(('error ('version 0 x ...) 'action-not-found action service)
- (report-error (_ "service '~a' does not have an action '~a'~%")
- service action))
+ (raise (condition (&action-not-found-error
+ (service service)
+ (action action)))))
(('error ('version 0 x ...) 'action-exception action service
key (args ...))
- (report-error (_ "exception caught while executing '~a' \
-on service '~a':~%")
- action service)
- (print-exception (current-error-port) #f key args))
+ (raise (condition (&action-exception-error
+ (service service)
+ (action action)
+ (key key) (args args)))))
(('error . _)
- (report-error (_ "something went wrong: ~s~%")
- error))
+ (raise (condition (&unknown-shepherd-error (sexp error)))))
(#f ;not an error
#t)))
(define (display-message message)
- ;; TRANSLATORS: Nothing to translate here.
- (info (_ "shepherd: ~a~%") message))
+ (format (current-error-port) "shepherd: ~a~%" message))
(define* (invoke-action service action arguments cont)
"Invoke ACTION on SERVICE with ARGUMENTS. On success, call CONT with the
@@ -107,10 +145,10 @@ result. Otherwise return #f."
(('reply ('version 0 x ...) ('result y) ('error error)
('messages messages))
(for-each display-message messages)
- (report-action-error error)
+ (raise-shepherd-error error)
#f)
(x
- (warning (_ "invalid shepherd reply~%"))
+ ;; invalid reply
#f))))
(define-syntax-rule (with-shepherd-action service (action args ...)
@@ -129,7 +167,8 @@ of pairs."
(define (current-services)
"Return two lists: the list of currently running services, and the list of
-currently stopped services."
+currently stopped services. Return #f and #f if the list of services could
+not be obtained."
(with-shepherd-action 'root ('status) services
(match services
((('service ('version 0 _ ...) _ ...) ...)
@@ -144,7 +183,6 @@ currently stopped services."
'()
services))
(x
- (warning (_ "failed to obtain list of shepherd services~%"))
(values #f #f)))))
(define (unload-service service)
diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm
index e5d754a..dd1e534 100644
--- a/guix/scripts/system.scm
+++ b/guix/scripts/system.scm
@@ -236,6 +236,72 @@ BODY..., and restore them."
(with-monad %store-monad
(return #f)))))
+(define-syntax-rule (with-shepherd-error-handling body ...)
+ (warn-on-system-error
+ (guard (c ((shepherd-error? c)
+ (report-shepherd-error c)))
+ body ...)))
+
+(define (report-shepherd-error error)
+ "Report ERROR, a '&shepherd-error' error condition object."
+ (cond ((service-not-found-error? error)
+ (report-error (_ "service '~a' could not be found~%")
+ (service-not-found-error-service error)))
+ ((action-not-found-error? error)
+ (report-error (_ "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 (_ "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 (_ "something went wrong: ~s~%")
+ (unknown-shepherd-error-sexp error)))
+ ((shepherd-error? error)
+ (report-error (_ "shepherd error~%")))
+ ((not error) ;not an error
+ #t)))
+
+(define (call-with-service-upgrade-info new-services mproc)
+ "Call MPROC, a monadic procedure in %STORE-MONAD, passing it the list of
+names of services to load (upgrade), and the list of names of services to
+unload."
+ (define (essential? service)
+ (memq service '(root shepherd)))
+
+ (define new-service-names
+ (map (compose first shepherd-service-provision)
+ new-services))
+
+ (let-values (((running stopped) (current-services)))
+ (if (and running stopped)
+ (let* ((to-load
+ ;; Only load services that are either new or currently stopped.
+ (remove (lambda (service)
+ (memq (first (shepherd-service-provision service))
+ running))
+ new-services))
+ (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))))))
+ (mproc to-load to-unload))
+ (with-monad %store-monad
+ (warning (_ "failed to obtain list of shepherd services~%"))
+ (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.
@@ -243,59 +309,35 @@ services specified in OS and not currently running.
This is currently very conservative in that it does not stop or unload any
running service. Unloading or stopping the wrong service ('udev', say) could
bring the system down."
- (define (essential? service)
- (memq service '(root shepherd)))
-
(define new-services
(service-parameters
(fold-services (operating-system-services os)
#:target-type shepherd-root-service-type)))
- (define new-service-names
- (map (compose first shepherd-service-provision)
- new-services))
-
- ;; 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)))
- ;; Here we assume that FILES are exactly those that were computed
- ;; as part of the derivation that built OS, which is normally the
- ;; case.
- (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 the service upgrade fails.
+ (with-shepherd-error-handling
+ (call-with-service-upgrade-info new-services
+ (lambda (to-load to-unload)
+ (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)))
+ ;; Here we assume that FILES are exactly those that were
computed
+ ;; as part of the derivation that built OS, which is normally
the
+ ;; case.
+ (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))
@@ -839,4 +881,8 @@ argument list and OPTS is the option alist."
(parameterize ((%graft? (assoc-ref opts 'graft?)))
(process-command command args opts)))))
+;;; Local Variables:
+;;; eval: (put 'call-with-service-upgrade-info 'scheme-indent-function 1)
+;;; End:
+
;;; system.scm ends here
- branch master updated (af5640d -> e9f693d), Ludovic Courtès, 2016/05/04
- 06/09: gnu: java-qdox: Escape "@" in description., Ludovic Courtès, 2016/05/04
- 02/09: environment: Use 'break' instead of 'split'., Ludovic Courtès, 2016/05/04
- 03/09: utils: Remove 'split'., Ludovic Courtès, 2016/05/04
- 05/09: build: Preserve stderr for shell tests., Ludovic Courtès, 2016/05/04
- 01/09: services: herd: Move UI handling to 'guix system'.,
Ludovic Courtès <=
- 07/09: system: Add procedures to access user accounts and service names., Ludovic Courtès, 2016/05/04
- 08/09: Add (gnu tests) and (gnu build marionette)., Ludovic Courtès, 2016/05/04
- 09/09: tests: Add whole-system test., Ludovic Courtès, 2016/05/04
- 04/09: utils: Move combinators to (guix combinators)., Ludovic Courtès, 2016/05/04