X-Git-Url: https://git.hcoop.net/jackhill/guix/guix.git/blobdiff_plain/69913ed0e62692ff149e312434980c2fc2c1ac89..5c3d77c3b14a9e87b4075efa4d7a877181e25665:/gnu/services/herd.scm diff --git a/gnu/services/herd.scm b/gnu/services/herd.scm index 03bfbf1d78..112a7dc104 100644 --- a/gnu/services/herd.scm +++ b/gnu/services/herd.scm @@ -1,5 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2016 Ludovic Courtès +;;; Copyright © 2016, 2017, 2018, 2019 Ludovic Courtès +;;; Copyright © 2017 Mathieu Othacehe ;;; ;;; This file is part of GNU Guix. ;;; @@ -23,7 +24,10 @@ #:use-module (srfi srfi-34) #:use-module (srfi srfi-35) #:use-module (ice-9 match) - #:export (shepherd-error? + #:export (%shepherd-socket-file + shepherd-message-port + + shepherd-error? service-not-found-error? service-not-found-error-service action-not-found-error? @@ -37,16 +41,21 @@ 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)) ;;; Commentary: ;;; @@ -58,9 +67,9 @@ ;;; 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. @@ -70,7 +79,7 @@ return the socket." (catch 'system-error (lambda () (connect sock address) - (setvbuf sock _IOFBF 1024) + (setvbuf sock 'block 1024) sock) (lambda args (close-port sock) @@ -79,7 +88,12 @@ return the socket." (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?) @@ -127,12 +141,17 @@ does not denote an 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) - (format (current-error-port) "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) @@ -143,7 +162,7 @@ result. Otherwise return #f." (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)) @@ -158,6 +177,8 @@ result. Otherwise return #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 ...))) @@ -178,34 +199,42 @@ of pairs." (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 the list of currently defined Shepherd services, represented as objects. Return #f if the list of services could not be obtained." - (with-shepherd-action 'root ('status) services - (match services - ((('service ('version 0 _ ...) _ ...) ...) - (map (lambda (service) - (alist-let* service (provides requires running) - (live-service provides requires running))) - services)) - (x - #f)))) + (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 @@ -215,8 +244,32 @@ returns a shepherd object." `(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 ))) + (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)) ;; Local Variables: