;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2016 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2016, 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2017, 2020 Mathieu Othacehe <m.othacehe@gmail.com>
;;;
;;; This file is part of GNU Guix.
;;;
;;; 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-9)
#: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-socket-file
+ shepherd-message-port
+
+ 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
+
+ live-service
+ live-service?
+ live-service-provision
+ live-service-requirement
+ live-service-running
+ live-service-canonical-name
+
+ with-shepherd-action
+ current-services
unload-services
unload-service
load-services
- start-service))
+ load-services/safe
+ start-service
+ stop-service
+ restart-service))
;;; Commentary:
;;;
;;; Code:
(define %shepherd-socket-file
- "/var/run/shepherd/socket")
+ (make-parameter "/var/run/shepherd/socket"))
-(define* (open-connection #:optional (file %shepherd-socket-file))
+(define* (open-connection #:optional (file (%shepherd-socket-file)))
"Open a connection to the daemon, using the Unix-domain socket at FILE, and
return the socket."
;; The protocol is sexp-based and UTF-8-encoded.
(catch 'system-error
(lambda ()
(connect sock address)
- (setvbuf sock _IOFBF 1024)
+ (setvbuf sock 'block 1024)
sock)
(lambda args
(close-port sock)
(define-syntax-rule (with-shepherd connection body ...)
"Evaluate BODY... with CONNECTION bound to an open socket to PID 1."
(let ((connection (open-connection)))
- body ...))
+ (dynamic-wind
+ (const #t)
+ (lambda ()
+ body ...)
+ (lambda ()
+ (close-port connection)))))
+
+(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 (report-action-error error)
- "Report ERROR, an sexp received by a shepherd client in reply to COMMAND, a
-command object."
+(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 shepherd-message-port
+ ;; Port where messages coming from shepherd are printed.
+ (make-parameter (current-error-port)))
+
(define (display-message message)
- ;; TRANSLATORS: Nothing to translate here.
- (info (_ "shepherd: ~a~%") message))
+ (format (shepherd-message-port) "shepherd: ~a~%" message))
(define* (invoke-action service action arguments cont)
"Invoke ACTION on SERVICE with ARGUMENTS. On success, call CONT with the
-result. Otherwise return #f."
+list of results (one result per instance with the name SERVICE). Otherwise
+return #f."
(with-shepherd sock
(write `(shepherd-command (version 0)
(action ,action)
(force-output sock)
(match (read sock)
- (('reply ('version 0 _ ...) ('result (result)) ('error #f)
+ (('reply ('version 0 _ ...) ('result result) ('error #f)
('messages messages))
(for-each display-message messages)
(cont result))
(('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 ...)
result body ...)
+ "Invoke ACTION on SERVICE with the given ARGS, and evaluate BODY with RESULT
+bound to the action's result."
(invoke-action service action (list args ...)
(lambda (result) body ...)))
(let ((key (and=> (assoc-ref alist 'key) car)) ...)
exp ...))))
+;; Information about live Shepherd services.
+(define-record-type <live-service>
+ (live-service provision requirement running)
+ live-service?
+ (provision live-service-provision) ;list of symbols
+ (requirement live-service-requirement) ;list of symbols
+ (running live-service-running)) ;#f | object
+
+(define (live-service-canonical-name service)
+ "Return the 'canonical name' of SERVICE."
+ (first (live-service-provision service)))
+
(define (current-services)
- "Return two lists: the list of currently running services, and the list of
-currently stopped services."
- (with-shepherd-action 'root ('status) services
- (match services
- ((('service ('version 0 _ ...) _ ...) ...)
- (fold2 (lambda (service running-services stopped-services)
- (alist-let* service (provides running)
- (if running
- (values (cons (first provides) running-services)
- stopped-services)
- (values running-services
- (cons (first provides) stopped-services)))))
- '()
- '()
- services))
- (x
- (warning (_ "failed to obtain list of shepherd services~%"))
- (values #f #f)))))
+ "Return the list of currently defined Shepherd services, represented as
+<live-service> objects. Return #f if the list of services could not be
+obtained."
+ (with-shepherd-action 'root ('status) results
+ ;; We get a list of results, one for each service with the name 'root'.
+ ;; In practice there's only one such service though.
+ (match results
+ ((services _ ...)
+ (match services
+ ((('service ('version 0 _ ...) _ ...) ...)
+ (map (lambda (service)
+ (alist-let* service (provides requires running)
+ (live-service provides requires running)))
+ services))
+ (x
+ #f))))))
(define (unload-service service)
"Unload SERVICE, a symbol name; return #t on success."
(with-shepherd-action 'root ('unload (symbol->string service)) result
- result))
+ (first result)))
(define (%load-file file)
"Load FILE in the Shepherd."
(with-shepherd-action 'root ('load file) result
- result))
+ (first result)))
(define (eval-there exp)
"Eval EXP in the Shepherd."
(with-shepherd-action 'root ('eval (object->string exp)) result
- result))
+ (first result)))
(define (load-services files)
"Load and register the services from FILES, where FILES contain code that
`(primitive-load ,file))
files))))
-(define (start-service name)
- (with-shepherd-action name ('start) result
+(define (load-services/safe files)
+ "This is like 'load-services', but make sure only the subset of FILES that
+can be safely reloaded is actually reloaded.
+
+This is done to accommodate the Shepherd < 0.15.0 where services lacked the
+'replacement' slot, and where 'register-services' would throw an exception
+when passed a service with an already-registered name."
+ (eval-there `(let* ((services (map primitive-load ',files))
+ (slots (map slot-definition-name
+ (class-slots <service>)))
+ (can-replace? (memq 'replacement slots)))
+ (define (registered? service)
+ (not (null? (lookup-services (canonical-name service)))))
+
+ (apply register-services
+ (if can-replace?
+ services
+ (remove registered? services))))))
+
+(define* (start-service name #:optional (arguments '()))
+ (invoke-action name 'start arguments
+ (lambda (result)
+ result)))
+
+(define (stop-service name)
+ (with-shepherd-action name ('stop) result
+ result))
+
+(define (restart-service name)
+ (with-shepherd-action name ('restart) result
result))
;; Local Variables:
HCoop / jackhill / guix / guix.git / blobdiff