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.
This commit is contained in:
Ludovic Courtès
parent
af5640d1dd
commit
8bf92e3904
@ -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)
|
||||
|
||||
@ -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 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)
|
||||
|
||||
;; 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)))))
|
||||
(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 (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))))))))
|
||||
(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
|
||||
|
||||
Loading…
Reference in New Issue
Block a user