Commit | Line | Data |
---|---|---|
db4fdc04 | 1 | ;;; GNU Guix --- Functional package management for GNU |
c273d81b | 2 | ;;; Copyright © 2013, 2014, 2015, 2016 Ludovic Courtès <ludo@gnu.org> |
db4fdc04 LC |
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 | ||
0190c1c0 | 19 | (define-module (gnu services shepherd) |
116244df LC |
20 | #:use-module (guix ui) |
21 | #:use-module (guix sets) | |
b5f4e686 | 22 | #:use-module (guix gexp) |
e87f0591 | 23 | #:use-module (guix store) |
db4fdc04 | 24 | #:use-module (guix monads) |
0adfe95a | 25 | #:use-module (guix records) |
e87f0591 | 26 | #:use-module (guix derivations) ;imported-modules, etc. |
db4fdc04 | 27 | #:use-module (gnu services) |
0adfe95a | 28 | #:use-module (gnu packages admin) |
db4fdc04 | 29 | #:use-module (ice-9 match) |
80a67734 | 30 | #:use-module (ice-9 vlist) |
db4fdc04 | 31 | #:use-module (srfi srfi-1) |
80a67734 | 32 | #:use-module (srfi srfi-26) |
116244df LC |
33 | #:use-module (srfi srfi-34) |
34 | #:use-module (srfi srfi-35) | |
0adfe95a LC |
35 | #:export (dmd-root-service-type |
36 | %dmd-root-service | |
37 | dmd-service-type | |
38 | ||
39 | dmd-service | |
40 | dmd-service? | |
41 | dmd-service-documentation | |
42 | dmd-service-provision | |
43 | dmd-service-requirement | |
44 | dmd-service-respawn? | |
45 | dmd-service-start | |
46 | dmd-service-stop | |
80a67734 | 47 | dmd-service-auto-start? |
fae685b9 LC |
48 | dmd-service-modules |
49 | dmd-service-imported-modules | |
50 | ||
51 | %default-imported-modules | |
52 | %default-modules | |
80a67734 LC |
53 | |
54 | dmd-service-back-edges)) | |
db4fdc04 LC |
55 | |
56 | ;;; Commentary: | |
57 | ;;; | |
fe1ad5f5 | 58 | ;;; Instantiating system services as a shepherd configuration file. |
db4fdc04 LC |
59 | ;;; |
60 | ;;; Code: | |
61 | ||
0adfe95a LC |
62 | |
63 | (define (dmd-boot-gexp services) | |
fe1ad5f5 | 64 | (mlet %store-monad ((shepherd-conf (shepherd-configuration-file services))) |
0adfe95a LC |
65 | (return #~(begin |
66 | ;; Keep track of the booted system. | |
67 | (false-if-exception (delete-file "/run/booted-system")) | |
68 | (symlink (readlink "/run/current-system") | |
69 | "/run/booted-system") | |
70 | ||
71 | ;; Close any remaining open file descriptors to be on the safe | |
72 | ;; side. This must be the very last thing we do, because | |
73 | ;; Guile has internal FDs such as 'sleep_pipe' that need to be | |
74 | ;; alive. | |
75 | (let loop ((fd 3)) | |
76 | (when (< fd 1024) | |
77 | (false-if-exception (close-fdes fd)) | |
78 | (loop (+ 1 fd)))) | |
79 | ||
34044d55 AK |
80 | ;; Start shepherd. |
81 | (execl (string-append #$shepherd "/bin/shepherd") | |
fe1ad5f5 | 82 | "shepherd" "--config" #$shepherd-conf))))) |
0adfe95a LC |
83 | |
84 | (define dmd-root-service-type | |
85 | (service-type | |
86 | (name 'dmd-root) | |
87 | ;; Extending the root dmd service (aka. PID 1) happens by concatenating the | |
88 | ;; list of services provided by the extensions. | |
89 | (compose concatenate) | |
90 | (extend append) | |
c273d81b LC |
91 | (extensions (list (service-extension boot-service-type dmd-boot-gexp) |
92 | (service-extension profile-service-type | |
34044d55 | 93 | (const (list shepherd))))))) |
0adfe95a LC |
94 | |
95 | (define %dmd-root-service | |
96 | ;; The root dmd service, aka. PID 1. Its parameter is a list of | |
97 | ;; <dmd-service> objects. | |
98 | (service dmd-root-service-type '())) | |
99 | ||
00184239 | 100 | (define-syntax-rule (dmd-service-type service-name proc) |
0adfe95a LC |
101 | "Return a <service-type> denoting a simple dmd service--i.e., the type for a |
102 | service that extends DMD-ROOT-SERVICE-TYPE and nothing else." | |
103 | (service-type | |
00184239 | 104 | (name service-name) |
0adfe95a LC |
105 | (extensions |
106 | (list (service-extension dmd-root-service-type | |
107 | (compose list proc)))))) | |
108 | ||
fae685b9 LC |
109 | (define %default-imported-modules |
110 | ;; Default set of modules imported for a service's consumption. | |
111 | '((guix build utils) | |
479b417b | 112 | (guix build syscalls))) |
fae685b9 LC |
113 | |
114 | (define %default-modules | |
115 | ;; Default set of modules visible in a service's file. | |
34044d55 | 116 | `((shepherd service) |
fae685b9 | 117 | (oop goops) |
fae685b9 | 118 | (guix build utils) |
479b417b | 119 | (guix build syscalls))) |
fae685b9 | 120 | |
0adfe95a LC |
121 | (define-record-type* <dmd-service> |
122 | dmd-service make-dmd-service | |
123 | dmd-service? | |
c5d735f7 | 124 | (documentation dmd-service-documentation ;string |
0adfe95a | 125 | (default "[No documentation.]")) |
c5d735f7 LC |
126 | (provision dmd-service-provision) ;list of symbols |
127 | (requirement dmd-service-requirement ;list of symbols | |
0adfe95a | 128 | (default '())) |
c5d735f7 | 129 | (respawn? dmd-service-respawn? ;Boolean |
0adfe95a | 130 | (default #t)) |
c5d735f7 LC |
131 | (start dmd-service-start) ;g-expression (procedure) |
132 | (stop dmd-service-stop ;g-expression (procedure) | |
0adfe95a | 133 | (default #~(const #f))) |
c5d735f7 | 134 | (auto-start? dmd-service-auto-start? ;Boolean |
fae685b9 LC |
135 | (default #t)) |
136 | (modules dmd-service-modules ;list of module names | |
137 | (default %default-modules)) | |
138 | (imported-modules dmd-service-imported-modules ;list of module names | |
139 | (default %default-imported-modules))) | |
0adfe95a LC |
140 | |
141 | ||
2d2651e7 LC |
142 | (define (assert-valid-graph services) |
143 | "Raise an error if SERVICES does not define a valid dmd service graph, for | |
144 | instance if a service requires a nonexistent service, or if more than one | |
145 | service uses a given name. | |
116244df | 146 | |
2d2651e7 LC |
147 | These are constraints that dmd's 'register-service' verifies but we'd better |
148 | verify them here statically than wait until PID 1 halts with an assertion | |
116244df | 149 | failure." |
2d2651e7 LC |
150 | (define provisions |
151 | ;; The set of provisions (symbols). Bail out if a symbol is given more | |
152 | ;; than once. | |
153 | (fold (lambda (service set) | |
154 | (define (assert-unique symbol) | |
155 | (when (set-contains? set symbol) | |
156 | (raise (condition | |
157 | (&message | |
158 | (message | |
159 | (format #f (_ "service '~a' provided more than once") | |
160 | symbol))))))) | |
161 | ||
162 | (for-each assert-unique (dmd-service-provision service)) | |
163 | (fold set-insert set (dmd-service-provision service))) | |
164 | (setq 'dmd) | |
165 | services)) | |
166 | ||
167 | (define (assert-satisfied-requirements service) | |
168 | ;; Bail out if the requirements of SERVICE aren't satisfied. | |
169 | (for-each (lambda (requirement) | |
170 | (unless (set-contains? provisions requirement) | |
171 | (raise (condition | |
172 | (&message | |
173 | (message | |
174 | (format #f (_ "service '~a' requires '~a', \ | |
175 | which is undefined") | |
176 | (match (dmd-service-provision service) | |
177 | ((head . _) head) | |
178 | (_ service)) | |
179 | requirement))))))) | |
180 | (dmd-service-requirement service))) | |
181 | ||
182 | (for-each assert-satisfied-requirements services)) | |
116244df | 183 | |
fae685b9 LC |
184 | (define (dmd-service-file-name service) |
185 | "Return the file name where the initialization code for SERVICE is to be | |
186 | stored." | |
187 | (let ((provisions (string-join (map symbol->string | |
188 | (dmd-service-provision service))))) | |
189 | (string-append "dmd-" | |
190 | (string-map (match-lambda | |
191 | (#\/ #\-) | |
192 | (chr chr)) | |
193 | provisions) | |
194 | ".scm"))) | |
195 | ||
196 | (define (dmd-service-file service) | |
197 | "Return a file defining SERVICE." | |
198 | (gexp->file (dmd-service-file-name service) | |
199 | #~(begin | |
200 | (use-modules #$@(dmd-service-modules service)) | |
201 | ||
202 | (make <service> | |
203 | #:docstring '#$(dmd-service-documentation service) | |
204 | #:provides '#$(dmd-service-provision service) | |
205 | #:requires '#$(dmd-service-requirement service) | |
206 | #:respawn? '#$(dmd-service-respawn? service) | |
207 | #:start #$(dmd-service-start service) | |
208 | #:stop #$(dmd-service-stop service))))) | |
209 | ||
fe1ad5f5 AK |
210 | (define (shepherd-configuration-file services) |
211 | "Return the shepherd configuration file for SERVICES." | |
23ed63a1 | 212 | (define modules |
fae685b9 LC |
213 | (delete-duplicates |
214 | (append-map dmd-service-imported-modules services))) | |
23ed63a1 | 215 | |
2d2651e7 | 216 | (assert-valid-graph services) |
116244df | 217 | |
23ed63a1 | 218 | (mlet %store-monad ((modules (imported-modules modules)) |
fae685b9 LC |
219 | (compiled (compiled-modules modules)) |
220 | (files (mapm %store-monad dmd-service-file services))) | |
23ed63a1 LC |
221 | (define config |
222 | #~(begin | |
223 | (eval-when (expand load eval) | |
224 | (set! %load-path (cons #$modules %load-path)) | |
225 | (set! %load-compiled-path | |
fae685b9 LC |
226 | (cons #$compiled %load-compiled-path))) |
227 | ||
b9c7ed71 LC |
228 | (use-modules (system repl error-handling)) |
229 | ||
230 | ;; Arrange to spawn a REPL if loading one of FILES fails. This is | |
231 | ;; better than a kernel panic. | |
232 | (call-with-error-handling | |
233 | (lambda () | |
234 | (apply register-services (map primitive-load '#$files)))) | |
23ed63a1 LC |
235 | |
236 | ;; guix-daemon 0.6 aborts if 'PATH' is undefined, so work around it. | |
b4140694 | 237 | (setenv "PATH" "/run/current-system/profile/bin") |
23ed63a1 LC |
238 | |
239 | (format #t "starting services...~%") | |
fdaacbad | 240 | (for-each start |
c5d735f7 LC |
241 | '#$(append-map dmd-service-provision |
242 | (filter dmd-service-auto-start? | |
243 | services))))) | |
23ed63a1 | 244 | |
fe1ad5f5 | 245 | (gexp->file "shepherd.conf" config))) |
db4fdc04 | 246 | |
80a67734 LC |
247 | (define (dmd-service-back-edges services) |
248 | "Return a procedure that, when given a <dmd-service> from SERVICES, returns | |
249 | the list of <dmd-service> that depend on it." | |
250 | (define provision->service | |
251 | (let ((services (fold (lambda (service result) | |
252 | (fold (cut vhash-consq <> service <>) | |
253 | result | |
254 | (dmd-service-provision service))) | |
255 | vlist-null | |
256 | services))) | |
257 | (lambda (name) | |
258 | (match (vhash-assq name services) | |
259 | ((_ . service) service) | |
260 | (#f #f))))) | |
261 | ||
262 | (define edges | |
263 | (fold (lambda (service edges) | |
264 | (fold (lambda (requirement edges) | |
265 | (vhash-consq (provision->service requirement) service | |
266 | edges)) | |
267 | edges | |
268 | (dmd-service-requirement service))) | |
269 | vlist-null | |
270 | services)) | |
271 | ||
272 | (lambda (service) | |
273 | (vhash-foldq* cons '() service edges))) | |
274 | ||
0190c1c0 | 275 | ;;; shepherd.scm ends here |