| 1 | ;;; GNU Guix --- Functional package management for GNU |
| 2 | ;;; Copyright © 2016 Ludovic Courtès <ludo@gnu.org> |
| 3 | ;;; |
| 4 | ;;; This file is part of GNU Guix. |
| 5 | ;;; |
| 6 | ;;; GNU Guix is free software; you can redistribute it and/or modify it |
| 7 | ;;; under the terms of the GNU General Public License as published by |
| 8 | ;;; the Free Software Foundation; either version 3 of the License, or (at |
| 9 | ;;; your option) any later version. |
| 10 | ;;; |
| 11 | ;;; GNU Guix is distributed in the hope that it will be useful, but |
| 12 | ;;; WITHOUT ANY WARRANTY; without even the implied warranty of |
| 13 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the |
| 14 | ;;; GNU General Public License for more details. |
| 15 | ;;; |
| 16 | ;;; You should have received a copy of the GNU General Public License |
| 17 | ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. |
| 18 | |
| 19 | (define-module (gnu services herd) |
| 20 | #:use-module (srfi srfi-1) |
| 21 | #:use-module (srfi srfi-9) |
| 22 | #:use-module (srfi srfi-11) |
| 23 | #:use-module (srfi srfi-34) |
| 24 | #:use-module (srfi srfi-35) |
| 25 | #:use-module (ice-9 match) |
| 26 | #:export (shepherd-error? |
| 27 | service-not-found-error? |
| 28 | service-not-found-error-service |
| 29 | action-not-found-error? |
| 30 | action-not-found-error-service |
| 31 | action-not-found-error-action |
| 32 | action-exception-error? |
| 33 | action-exception-error-service |
| 34 | action-exception-error-action |
| 35 | action-exception-error-key |
| 36 | action-exception-error-arguments |
| 37 | unknown-shepherd-error? |
| 38 | unknown-shepherd-error-sexp |
| 39 | |
| 40 | live-service? |
| 41 | live-service-provision |
| 42 | live-service-requirement |
| 43 | live-service-running |
| 44 | |
| 45 | current-services |
| 46 | unload-services |
| 47 | unload-service |
| 48 | load-services |
| 49 | start-service)) |
| 50 | |
| 51 | ;;; Commentary: |
| 52 | ;;; |
| 53 | ;;; This module provides an interface to the GNU Shepherd, similar to the |
| 54 | ;;; 'herd' command. Essentially it implements a subset of the (shepherd comm) |
| 55 | ;;; module, but focusing only on the parts relevant to 'guix system |
| 56 | ;;; reconfigure'. |
| 57 | ;;; |
| 58 | ;;; Code: |
| 59 | |
| 60 | (define %shepherd-socket-file |
| 61 | "/var/run/shepherd/socket") |
| 62 | |
| 63 | (define* (open-connection #:optional (file %shepherd-socket-file)) |
| 64 | "Open a connection to the daemon, using the Unix-domain socket at FILE, and |
| 65 | return the socket." |
| 66 | ;; The protocol is sexp-based and UTF-8-encoded. |
| 67 | (with-fluids ((%default-port-encoding "UTF-8")) |
| 68 | (let ((sock (socket PF_UNIX SOCK_STREAM 0)) |
| 69 | (address (make-socket-address PF_UNIX file))) |
| 70 | (catch 'system-error |
| 71 | (lambda () |
| 72 | (connect sock address) |
| 73 | (setvbuf sock _IOFBF 1024) |
| 74 | sock) |
| 75 | (lambda args |
| 76 | (close-port sock) |
| 77 | (apply throw args)))))) |
| 78 | |
| 79 | (define-syntax-rule (with-shepherd connection body ...) |
| 80 | "Evaluate BODY... with CONNECTION bound to an open socket to PID 1." |
| 81 | (let ((connection (open-connection))) |
| 82 | body ...)) |
| 83 | |
| 84 | (define-condition-type &shepherd-error &error |
| 85 | shepherd-error?) |
| 86 | |
| 87 | (define-condition-type &service-not-found-error &shepherd-error |
| 88 | service-not-found-error? |
| 89 | (service service-not-found-error-service)) |
| 90 | |
| 91 | (define-condition-type &action-not-found-error &shepherd-error |
| 92 | action-not-found-error? |
| 93 | (service action-not-found-error-service) |
| 94 | (action action-not-found-error-action)) |
| 95 | |
| 96 | (define-condition-type &action-exception-error &shepherd-error |
| 97 | action-exception-error? |
| 98 | (service action-exception-error-service) |
| 99 | (action action-exception-error-action) |
| 100 | (key action-exception-error-key) |
| 101 | (args action-exception-error-arguments)) |
| 102 | |
| 103 | (define-condition-type &unknown-shepherd-error &shepherd-error |
| 104 | unknown-shepherd-error? |
| 105 | (sexp unknown-shepherd-error-sexp)) |
| 106 | |
| 107 | (define (raise-shepherd-error error) |
| 108 | "Raise an error condition corresponding to ERROR, an sexp received by a |
| 109 | shepherd client in reply to COMMAND, a command object. Return #t if ERROR |
| 110 | does not denote an error." |
| 111 | (match error |
| 112 | (('error ('version 0 x ...) 'service-not-found service) |
| 113 | (raise (condition (&service-not-found-error |
| 114 | (service service))))) |
| 115 | (('error ('version 0 x ...) 'action-not-found action service) |
| 116 | (raise (condition (&action-not-found-error |
| 117 | (service service) |
| 118 | (action action))))) |
| 119 | (('error ('version 0 x ...) 'action-exception action service |
| 120 | key (args ...)) |
| 121 | (raise (condition (&action-exception-error |
| 122 | (service service) |
| 123 | (action action) |
| 124 | (key key) (args args))))) |
| 125 | (('error . _) |
| 126 | (raise (condition (&unknown-shepherd-error (sexp error))))) |
| 127 | (#f ;not an error |
| 128 | #t))) |
| 129 | |
| 130 | (define (display-message message) |
| 131 | (format (current-error-port) "shepherd: ~a~%" message)) |
| 132 | |
| 133 | (define* (invoke-action service action arguments cont) |
| 134 | "Invoke ACTION on SERVICE with ARGUMENTS. On success, call CONT with the |
| 135 | result. Otherwise return #f." |
| 136 | (with-shepherd sock |
| 137 | (write `(shepherd-command (version 0) |
| 138 | (action ,action) |
| 139 | (service ,service) |
| 140 | (arguments ,arguments) |
| 141 | (directory ,(getcwd))) |
| 142 | sock) |
| 143 | (force-output sock) |
| 144 | |
| 145 | (match (read sock) |
| 146 | (('reply ('version 0 _ ...) ('result (result)) ('error #f) |
| 147 | ('messages messages)) |
| 148 | (for-each display-message messages) |
| 149 | (cont result)) |
| 150 | (('reply ('version 0 x ...) ('result y) ('error error) |
| 151 | ('messages messages)) |
| 152 | (for-each display-message messages) |
| 153 | (raise-shepherd-error error) |
| 154 | #f) |
| 155 | (x |
| 156 | ;; invalid reply |
| 157 | #f)))) |
| 158 | |
| 159 | (define-syntax-rule (with-shepherd-action service (action args ...) |
| 160 | result body ...) |
| 161 | (invoke-action service action (list args ...) |
| 162 | (lambda (result) body ...))) |
| 163 | |
| 164 | (define-syntax alist-let* |
| 165 | (syntax-rules () |
| 166 | "Bind the given KEYs in EXP to the corresponding items in ALIST. ALIST |
| 167 | is assumed to be a list of two-element tuples rather than a traditional list |
| 168 | of pairs." |
| 169 | ((_ alist (key ...) exp ...) |
| 170 | (let ((key (and=> (assoc-ref alist 'key) car)) ...) |
| 171 | exp ...)))) |
| 172 | |
| 173 | ;; Information about live Shepherd services. |
| 174 | (define-record-type <live-service> |
| 175 | (live-service provision requirement running) |
| 176 | live-service? |
| 177 | (provision live-service-provision) ;list of symbols |
| 178 | (requirement live-service-requirement) ;list of symbols |
| 179 | (running live-service-running)) ;#f | object |
| 180 | |
| 181 | (define (current-services) |
| 182 | "Return the list of currently defined Shepherd services, represented as |
| 183 | <live-service> objects. Return #f if the list of services could not be |
| 184 | obtained." |
| 185 | (with-shepherd-action 'root ('status) services |
| 186 | (match services |
| 187 | ((('service ('version 0 _ ...) _ ...) ...) |
| 188 | (map (lambda (service) |
| 189 | (alist-let* service (provides requires running) |
| 190 | (live-service provides requires running))) |
| 191 | services)) |
| 192 | (x |
| 193 | #f)))) |
| 194 | |
| 195 | (define (unload-service service) |
| 196 | "Unload SERVICE, a symbol name; return #t on success." |
| 197 | (with-shepherd-action 'root ('unload (symbol->string service)) result |
| 198 | result)) |
| 199 | |
| 200 | (define (%load-file file) |
| 201 | "Load FILE in the Shepherd." |
| 202 | (with-shepherd-action 'root ('load file) result |
| 203 | result)) |
| 204 | |
| 205 | (define (eval-there exp) |
| 206 | "Eval EXP in the Shepherd." |
| 207 | (with-shepherd-action 'root ('eval (object->string exp)) result |
| 208 | result)) |
| 209 | |
| 210 | (define (load-services files) |
| 211 | "Load and register the services from FILES, where FILES contain code that |
| 212 | returns a shepherd <service> object." |
| 213 | (eval-there `(register-services |
| 214 | ,@(map (lambda (file) |
| 215 | `(primitive-load ,file)) |
| 216 | files)))) |
| 217 | |
| 218 | (define (start-service name) |
| 219 | (with-shepherd-action name ('start) result |
| 220 | result)) |
| 221 | |
| 222 | ;; Local Variables: |
| 223 | ;; eval: (put 'alist-let* 'scheme-indent-function 2) |
| 224 | ;; eval: (put 'with-shepherd 'scheme-indent-function 1) |
| 225 | ;; eval: (put 'with-shepherd-action 'scheme-indent-function 3) |
| 226 | ;; End: |
| 227 | |
| 228 | ;;; herd.scm ends here |