aboutsummaryrefslogtreecommitdiff
path: root/gnu/services/herd.scm
diff options
context:
space:
mode:
authorLudovic Courtès <ludo@gnu.org>2016-05-04 16:38:22 +0200
committerLudovic Courtès <ludo@gnu.org>2016-05-04 23:35:55 +0200
commit8bf92e3904cb656d4c2160fc8befebaf21a65492 (patch)
tree38b708192a69da0dd2e6722250732bbd9bf2177b /gnu/services/herd.scm
parentaf5640d1dd18328dbfec5cb11f73224efd47f1aa (diff)
downloadguix-8bf92e3904cb656d4c2160fc8befebaf21a65492.tar
guix-8bf92e3904cb656d4c2160fc8befebaf21a65492.tar.gz
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.
Diffstat (limited to 'gnu/services/herd.scm')
-rw-r--r--gnu/services/herd.scm80
1 files changed, 59 insertions, 21 deletions
diff --git a/gnu/services/herd.scm b/gnu/services/herd.scm
index 9cb33a9fd0..c06e98800e 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)