Commit | Line | Data |
---|---|---|
db4fdc04 | 1 | ;;; GNU Guix --- Functional package management for GNU |
e87f0591 | 2 | ;;; Copyright © 2013, 2014, 2015 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 | ||
19 | (define-module (gnu services dmd) | |
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 LC |
47 | dmd-service-auto-start? |
48 | ||
49 | dmd-service-back-edges)) | |
db4fdc04 LC |
50 | |
51 | ;;; Commentary: | |
52 | ;;; | |
53 | ;;; Instantiating system services as a dmd configuration file. | |
54 | ;;; | |
55 | ;;; Code: | |
56 | ||
0adfe95a LC |
57 | |
58 | (define (dmd-boot-gexp services) | |
59 | (mlet %store-monad ((dmd-conf (dmd-configuration-file services))) | |
60 | (return #~(begin | |
61 | ;; Keep track of the booted system. | |
62 | (false-if-exception (delete-file "/run/booted-system")) | |
63 | (symlink (readlink "/run/current-system") | |
64 | "/run/booted-system") | |
65 | ||
66 | ;; Close any remaining open file descriptors to be on the safe | |
67 | ;; side. This must be the very last thing we do, because | |
68 | ;; Guile has internal FDs such as 'sleep_pipe' that need to be | |
69 | ;; alive. | |
70 | (let loop ((fd 3)) | |
71 | (when (< fd 1024) | |
72 | (false-if-exception (close-fdes fd)) | |
73 | (loop (+ 1 fd)))) | |
74 | ||
75 | ;; Start dmd. | |
76 | (execl (string-append #$dmd "/bin/dmd") | |
77 | "dmd" "--config" #$dmd-conf))))) | |
78 | ||
79 | (define dmd-root-service-type | |
80 | (service-type | |
81 | (name 'dmd-root) | |
82 | ;; Extending the root dmd service (aka. PID 1) happens by concatenating the | |
83 | ;; list of services provided by the extensions. | |
84 | (compose concatenate) | |
85 | (extend append) | |
86 | (extensions (list (service-extension boot-service-type dmd-boot-gexp))))) | |
87 | ||
88 | (define %dmd-root-service | |
89 | ;; The root dmd service, aka. PID 1. Its parameter is a list of | |
90 | ;; <dmd-service> objects. | |
91 | (service dmd-root-service-type '())) | |
92 | ||
00184239 | 93 | (define-syntax-rule (dmd-service-type service-name proc) |
0adfe95a LC |
94 | "Return a <service-type> denoting a simple dmd service--i.e., the type for a |
95 | service that extends DMD-ROOT-SERVICE-TYPE and nothing else." | |
96 | (service-type | |
00184239 | 97 | (name service-name) |
0adfe95a LC |
98 | (extensions |
99 | (list (service-extension dmd-root-service-type | |
100 | (compose list proc)))))) | |
101 | ||
102 | (define-record-type* <dmd-service> | |
103 | dmd-service make-dmd-service | |
104 | dmd-service? | |
c5d735f7 | 105 | (documentation dmd-service-documentation ;string |
0adfe95a | 106 | (default "[No documentation.]")) |
c5d735f7 LC |
107 | (provision dmd-service-provision) ;list of symbols |
108 | (requirement dmd-service-requirement ;list of symbols | |
0adfe95a | 109 | (default '())) |
c5d735f7 | 110 | (respawn? dmd-service-respawn? ;Boolean |
0adfe95a | 111 | (default #t)) |
c5d735f7 LC |
112 | (start dmd-service-start) ;g-expression (procedure) |
113 | (stop dmd-service-stop ;g-expression (procedure) | |
0adfe95a | 114 | (default #~(const #f))) |
c5d735f7 | 115 | (auto-start? dmd-service-auto-start? ;Boolean |
0adfe95a LC |
116 | (default #t))) |
117 | ||
118 | ||
116244df LC |
119 | (define (assert-no-duplicates services) |
120 | "Raise an error if SERVICES provide the same dmd service more than once. | |
121 | ||
122 | This is a constraint that dmd's 'register-service' verifies but we'd better | |
123 | verify it here statically than wait until PID 1 halts with an assertion | |
124 | failure." | |
125 | (fold (lambda (service set) | |
126 | (define (assert-unique symbol) | |
127 | (when (set-contains? set symbol) | |
128 | (raise (condition | |
129 | (&message | |
130 | (message | |
131 | (format #f (_ "service '~a' provided more than once") | |
132 | symbol))))))) | |
133 | ||
c5d735f7 LC |
134 | (for-each assert-unique (dmd-service-provision service)) |
135 | (fold set-insert set (dmd-service-provision service))) | |
116244df LC |
136 | (setq) |
137 | services)) | |
138 | ||
4dfe6c58 LC |
139 | (define (dmd-configuration-file services) |
140 | "Return the dmd configuration file for SERVICES." | |
23ed63a1 LC |
141 | (define modules |
142 | ;; Extra modules visible to dmd.conf. | |
023f391c | 143 | '((guix build syscalls) |
e2f4b305 | 144 | (gnu build file-systems) |
023f391c | 145 | (guix build utils))) |
23ed63a1 | 146 | |
116244df LC |
147 | (assert-no-duplicates services) |
148 | ||
23ed63a1 LC |
149 | (mlet %store-monad ((modules (imported-modules modules)) |
150 | (compiled (compiled-modules modules))) | |
151 | (define config | |
152 | #~(begin | |
153 | (eval-when (expand load eval) | |
154 | (set! %load-path (cons #$modules %load-path)) | |
155 | (set! %load-compiled-path | |
156 | (cons #$compiled %load-compiled-path))) | |
157 | ||
158 | (use-modules (ice-9 ftw) | |
023f391c | 159 | (guix build syscalls) |
83a17b62 | 160 | (guix build utils) |
e2f4b305 | 161 | ((gnu build file-systems) |
d4c87617 | 162 | #:select (check-file-system canonicalize-device-spec))) |
23ed63a1 LC |
163 | |
164 | (register-services | |
165 | #$@(map (lambda (service) | |
166 | #~(make <service> | |
c5d735f7 LC |
167 | #:docstring '#$(dmd-service-documentation service) |
168 | #:provides '#$(dmd-service-provision service) | |
169 | #:requires '#$(dmd-service-requirement service) | |
170 | #:respawn? '#$(dmd-service-respawn? service) | |
171 | #:start #$(dmd-service-start service) | |
172 | #:stop #$(dmd-service-stop service))) | |
23ed63a1 LC |
173 | services)) |
174 | ||
175 | ;; guix-daemon 0.6 aborts if 'PATH' is undefined, so work around it. | |
b4140694 | 176 | (setenv "PATH" "/run/current-system/profile/bin") |
23ed63a1 LC |
177 | |
178 | (format #t "starting services...~%") | |
fdaacbad | 179 | (for-each start |
c5d735f7 LC |
180 | '#$(append-map dmd-service-provision |
181 | (filter dmd-service-auto-start? | |
182 | services))))) | |
23ed63a1 LC |
183 | |
184 | (gexp->file "dmd.conf" config))) | |
db4fdc04 | 185 | |
80a67734 LC |
186 | (define (dmd-service-back-edges services) |
187 | "Return a procedure that, when given a <dmd-service> from SERVICES, returns | |
188 | the list of <dmd-service> that depend on it." | |
189 | (define provision->service | |
190 | (let ((services (fold (lambda (service result) | |
191 | (fold (cut vhash-consq <> service <>) | |
192 | result | |
193 | (dmd-service-provision service))) | |
194 | vlist-null | |
195 | services))) | |
196 | (lambda (name) | |
197 | (match (vhash-assq name services) | |
198 | ((_ . service) service) | |
199 | (#f #f))))) | |
200 | ||
201 | (define edges | |
202 | (fold (lambda (service edges) | |
203 | (fold (lambda (requirement edges) | |
204 | (vhash-consq (provision->service requirement) service | |
205 | edges)) | |
206 | edges | |
207 | (dmd-service-requirement service))) | |
208 | vlist-null | |
209 | services)) | |
210 | ||
211 | (lambda (service) | |
212 | (vhash-foldq* cons '() service edges))) | |
213 | ||
db4fdc04 | 214 | ;;; dmd.scm ends here |