diff options
Diffstat (limited to 'gnu/services/herd.scm')
| -rw-r--r-- | gnu/services/herd.scm | 189 |
1 files changed, 189 insertions, 0 deletions
diff --git a/gnu/services/herd.scm b/gnu/services/herd.scm new file mode 100644 index 0000000000..89a93a1969 --- /dev/null +++ b/gnu/services/herd.scm @@ -0,0 +1,189 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2016 Ludovic Courtès <ludo@gnu.org> +;;; +;;; This file is part of GNU Guix. +;;; +;;; GNU Guix is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; GNU Guix is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; 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 (ice-9 match) + #:export (current-services + unload-services + unload-service + load-services + start-service)) + +;;; Commentary: +;;; +;;; This module provides an interface to the GNU Shepherd, similar to the +;;; 'herd' command. Essentially it implements a subset of the (shepherd comm) +;;; module, but focusing only on the parts relevant to 'guix system +;;; reconfigure'. +;;; +;;; Code: + +(define %shepherd-socket-file + "/var/run/shepherd/socket") + +(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. + (with-fluids ((%default-port-encoding "UTF-8")) + (let ((sock (socket PF_UNIX SOCK_STREAM 0)) + (address (make-socket-address PF_UNIX file))) + (catch 'system-error + (lambda () + (connect sock address) + (setvbuf sock _IOFBF 1024) + sock) + (lambda (key proc format-string format-args errno . rest) + (warning (_ "cannot connect to ~a: ~a~%") file + (apply format #f format-string format-args)) + #f))))) + +(define-syntax-rule (with-shepherd connection body ...) + "Evaluate BODY... with CONNECTION bound to an open socket to PID 1." + (let ((connection (open-connection))) + (and connection + (dynamic-wind + (const #t) + (lambda () + body ...) + (const #t))))) + +(define (report-action-error error) + "Report ERROR, an sexp received by a shepherd client in reply to COMMAND, a +command object." + (match error + (('error ('version 0 x ...) 'service-not-found service) + (report-error (_ "service '~a' could not be found") + service)) + (('error ('version 0 x ...) 'action-not-found action service) + (report-error (_ "service '~a' does not have an action '~a'") + service 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)) + (('error . _) + (report-error (_ "something went wrong: ~s") + error)) + (#f ;not an error + #t))) + +(define (display-message message) + ;; TRANSLATORS: Nothing to translate here. + (info (_ "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." + (with-shepherd sock + (write `(shepherd-command (version 0) + (action ,action) + (service ,service) + (arguments ,arguments) + (directory ,(getcwd))) + sock) + (force-output sock) + + (match (read sock) + (('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) + #f) + (x + (warning (_ "invalid shepherd reply~%")) + #f)))) + +(define-syntax-rule (with-shepherd-action service (action args ...) + result body ...) + (invoke-action service action (list args ...) + (lambda (result) body ...))) + +(define-syntax alist-let* + (syntax-rules () + "Bind the given KEYs in EXP to the corresponding items in ALIST. ALIST +is assumed to be a list of two-element tuples rather than a traditional list +of pairs." + ((_ alist (key ...) exp ...) + (let ((key (and=> (assoc-ref alist 'key) car)) ...) + exp ...)))) + +(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))))) + +(define (unload-service service) + "Unload SERVICE, a symbol name; return #t on success." + (with-shepherd-action 'root ('unload (symbol->string service)) result + result)) + +(define (%load-file file) + "Load FILE in the Shepherd." + (with-shepherd-action 'root ('load file) result + result)) + +(define (eval-there exp) + "Eval EXP in the Shepherd." + (with-shepherd-action 'root ('eval (object->string exp)) result + result)) + +(define (load-services files) + "Load and register the services from FILES, where FILES contain code that +returns a shepherd <service> object." + (eval-there `(register-services + ,@(map (lambda (file) + `(primitive-load ,file)) + files)))) + +(define (start-service name) + (with-shepherd-action name ('start) result + result)) + +;; Local Variables: +;; eval: (put 'alist-let* 'scheme-indent-function 2) +;; eval: (put 'with-shepherd 'scheme-indent-function 1) +;; eval: (put 'with-shepherd-action 'scheme-indent-function 3) +;; End: + +;;; herd.scm ends here |