gnu: Use 'gexp->file' in conjunction with 'with-imported-modules'.
[jackhill/guix/guix.git] / gnu / services / base.scm
CommitLineData
db4fdc04 1;;; GNU Guix --- Functional package management for GNU
9a8b9eb8 2;;; Copyright © 2013, 2014, 2015, 2016 Ludovic Courtès <ludo@gnu.org>
34044d55 3;;; Copyright © 2015, 2016 Alex Kost <alezost@gmail.com>
4307c476 4;;; Copyright © 2015 Mark H Weaver <mhw@netris.org>
e10964ef 5;;; Copyright © 2015 Sou Bunnbu <iyzsong@gmail.com>
a535e122 6;;; Copyright © 2016 Leo Famulari <leo@famulari.name>
b58cbf9a 7;;; Copyright © 2016 David Craven <david@craven.ch>
db4fdc04
LC
8;;;
9;;; This file is part of GNU Guix.
10;;;
11;;; GNU Guix is free software; you can redistribute it and/or modify it
12;;; under the terms of the GNU General Public License as published by
13;;; the Free Software Foundation; either version 3 of the License, or (at
14;;; your option) any later version.
15;;;
16;;; GNU Guix is distributed in the hope that it will be useful, but
17;;; WITHOUT ANY WARRANTY; without even the implied warranty of
18;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
19;;; GNU General Public License for more details.
20;;;
21;;; You should have received a copy of the GNU General Public License
22;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
23
24(define-module (gnu services base)
e87f0591 25 #:use-module (guix store)
db4fdc04 26 #:use-module (gnu services)
0190c1c0 27 #:use-module (gnu services shepherd)
4a3b3b07 28 #:use-module (gnu services networking)
6e828634 29 #:use-module (gnu system pam)
db4fdc04 30 #:use-module (gnu system shadow) ; 'user-account', etc.
0adfe95a 31 #:use-module (gnu system file-systems) ; 'file-system', etc.
060d62a7 32 #:use-module (gnu system mapped-devices)
db4fdc04 33 #:use-module (gnu packages admin)
151a2c07 34 #:use-module ((gnu packages linux)
b58cbf9a 35 #:select (alsa-utils crda eudev e2fsprogs fuse gpm kbd lvm2 rng-tools))
db4fdc04 36 #:use-module ((gnu packages base)
bdb36958 37 #:select (canonical-package glibc))
db4fdc04 38 #:use-module (gnu packages package-management)
2d1d2dd8
LC
39 #:use-module (gnu packages lsh)
40 #:use-module (gnu packages lsof)
e2f4b305 41 #:use-module ((gnu build file-systems)
2c071ce9 42 #:select (mount-flags->bit-mask))
b5f4e686 43 #:use-module (guix gexp)
6454b333 44 #:use-module (guix records)
db4fdc04
LC
45 #:use-module (srfi srfi-1)
46 #:use-module (srfi srfi-26)
6454b333 47 #:use-module (ice-9 match)
db4fdc04 48 #:use-module (ice-9 format)
e43e84ba
LC
49 #:export (fstab-service-type
50 root-file-system-service
023f391c 51 file-system-service
d6e2a622 52 user-unmount-service
2a13d05e 53 swap-service
a00dd9fb 54 user-processes-service
e10964ef
SB
55 session-environment-service
56 session-environment-service-type
a00dd9fb 57 host-name-service
5eca9459 58 console-keymap-service
62ca0fdf 59 console-font-service
c797fabe
RW
60
61 udev-configuration
62 udev-configuration?
63 udev-configuration-rules
0adfe95a 64 udev-service-type
151a2c07 65 udev-service
80e6f37e 66 udev-rule
66e4f01c
LC
67
68 mingetty-configuration
69 mingetty-configuration?
db4fdc04 70 mingetty-service
cd6f6c22 71 mingetty-service-type
6454b333
LC
72
73 %nscd-default-caches
74 %nscd-default-configuration
75
76 nscd-configuration
77 nscd-configuration?
78
79 nscd-cache
80 nscd-cache?
81
0adfe95a 82 nscd-service-type
db4fdc04
LC
83 nscd-service
84 syslog-service
9009538d 85 syslog-service-type
44abcb28 86 %default-syslog.conf
0adfe95a
LC
87
88 guix-configuration
89 guix-configuration?
8b198abe 90 guix-service
cd6f6c22 91 guix-service-type
1c52181f
LC
92 guix-publish-configuration
93 guix-publish-configuration?
94 guix-publish-service
95 guix-publish-service-type
8664cc88
LC
96 gpm-service-type
97 gpm-service
0adfe95a 98
9009538d 99 urandom-seed-service-type
a535e122 100 urandom-seed-service
b58cbf9a
DC
101 rngd-service-type
102 rngd-service
a535e122 103
8b198abe 104 %base-services))
db4fdc04
LC
105
106;;; Commentary:
107;;;
108;;; Base system services---i.e., services that 99% of the users will want to
109;;; use.
110;;;
111;;; Code:
112
0adfe95a
LC
113\f
114;;;
115;;; File systems.
116;;;
a00dd9fb 117
e43e84ba
LC
118(define (file-system->fstab-entry file-system)
119 "Return a @file{/etc/fstab} entry for @var{file-system}."
120 (string-append (case (file-system-title file-system)
121 ((label)
122 (string-append "LABEL=" (file-system-device file-system)))
123 ((uuid)
124 (string-append
125 "UUID="
126 (uuid->string (file-system-device file-system))))
127 (else
128 (file-system-device file-system)))
129 "\t"
130 (file-system-mount-point file-system) "\t"
131 (file-system-type file-system) "\t"
132 (or (file-system-options file-system) "defaults") "\t"
133
134 ;; XXX: Omit the 'fs_freq' and 'fs_passno' fields because we
135 ;; don't have anything sensible to put in there.
136 ))
137
138(define (file-systems->fstab file-systems)
139 "Return a @file{/etc} entry for an @file{fstab} describing
140@var{file-systems}."
141 `(("fstab" ,(plain-file "fstab"
142 (string-append
143 "\
144# This file was generated from your GuixSD configuration. Any changes
145# will be lost upon reboot or reconfiguration.\n\n"
146 (string-join (map file-system->fstab-entry
147 file-systems)
148 "\n")
149 "\n")))))
150
151(define fstab-service-type
152 ;; The /etc/fstab service.
153 (service-type (name 'fstab)
154 (extensions
155 (list (service-extension etc-service-type
156 file-systems->fstab)))
157 (compose identity)
158 (extend append)))
159
d4053c71
AK
160(define %root-file-system-shepherd-service
161 (shepherd-service
be1c2c54
LC
162 (documentation "Take care of the root file system.")
163 (provision '(root-file-system))
164 (start #~(const #t))
165 (stop #~(lambda _
166 ;; Return #f if successfully stopped.
167 (sync)
168
169 (call-with-blocked-asyncs
170 (lambda ()
171 (let ((null (%make-void-port "w")))
34044d55 172 ;; Close 'shepherd.log'.
be1c2c54 173 (display "closing log\n")
34044d55 174 ((@ (shepherd comm) stop-logging))
be1c2c54
LC
175
176 ;; Redirect the default output ports..
177 (set-current-output-port null)
178 (set-current-error-port null)
179
180 ;; Close /dev/console.
181 (for-each close-fdes '(0 1 2))
182
183 ;; At this point, there are no open files left, so the
184 ;; root file system can be re-mounted read-only.
185 (mount #f "/" #f
186 (logior MS_REMOUNT MS_RDONLY)
187 #:update-mtab? #f)
188
189 #f)))))
190 (respawn? #f)))
a00dd9fb 191
0adfe95a 192(define root-file-system-service-type
d4053c71
AK
193 (shepherd-service-type 'root-file-system
194 (const %root-file-system-shepherd-service)))
0adfe95a
LC
195
196(define (root-file-system-service)
197 "Return a service whose sole purpose is to re-mount read-only the root file
198system upon shutdown (aka. cleanly \"umounting\" root.)
199
200This service must be the root of the service dependency graph so that its
d4053c71 201'stop' action is invoked when shepherd is the only process left."
0adfe95a
LC
202 (service root-file-system-service-type #f))
203
d4053c71 204(define (file-system->shepherd-service-name file-system)
0adfe95a
LC
205 "Return the symbol that denotes the service mounting and unmounting
206FILE-SYSTEM."
207 (symbol-append 'file-system-
208 (string->symbol (file-system-mount-point file-system))))
209
d4053c71
AK
210(define (mapped-device->shepherd-service-name md)
211 "Return the symbol that denotes the shepherd service of MD, a <mapped-device>."
e502bf89
LC
212 (symbol-append 'device-mapping-
213 (string->symbol (mapped-device-target md))))
214
d4053c71 215(define dependency->shepherd-service-name
e502bf89
LC
216 (match-lambda
217 ((? mapped-device? md)
d4053c71 218 (mapped-device->shepherd-service-name md))
e502bf89 219 ((? file-system? fs)
d4053c71 220 (file-system->shepherd-service-name fs))))
e502bf89 221
d4053c71
AK
222(define (file-system-shepherd-service file-system)
223 "Return a list containing the shepherd service for @var{file-system}."
e43e84ba
LC
224 (let ((target (file-system-mount-point file-system))
225 (device (file-system-device file-system))
226 (type (file-system-type file-system))
227 (title (file-system-title file-system))
228 (check? (file-system-check? file-system))
229 (create? (file-system-create-mount-point? file-system))
230 (dependencies (file-system-dependencies file-system)))
be21979d
LC
231 (if (file-system-mount? file-system)
232 (list
d4053c71
AK
233 (shepherd-service
234 (provision (list (file-system->shepherd-service-name file-system)))
be21979d 235 (requirement `(root-file-system
d4053c71 236 ,@(map dependency->shepherd-service-name dependencies)))
be21979d
LC
237 (documentation "Check, mount, and unmount the given file system.")
238 (start #~(lambda args
239 ;; FIXME: Use or factorize with 'mount-file-system'.
240 (let ((device (canonicalize-device-spec #$device '#$title))
241 (flags #$(mount-flags->bit-mask
242 (file-system-flags file-system))))
243 #$(if create?
244 #~(mkdir-p #$target)
245 #~#t)
246 #$(if check?
247 #~(begin
248 ;; Make sure fsck.ext2 & co. can be found.
249 (setenv "PATH"
250 (string-append
251 #$e2fsprogs "/sbin:"
252 "/run/current-system/profile/sbin:"
253 (getenv "PATH")))
254 (check-file-system device #$type))
255 #~#t)
256
257 (mount device #$target #$type flags
258 #$(file-system-options file-system))
259
260 ;; For read-only bind mounts, an extra remount is
261 ;; needed, as per <http://lwn.net/Articles/281157/>,
262 ;; which still applies to Linux 4.0.
263 (when (and (= MS_BIND (logand flags MS_BIND))
264 (= MS_RDONLY (logand flags MS_RDONLY)))
265 (mount device #$target #$type
266 (logior MS_BIND MS_REMOUNT MS_RDONLY))))
267 #t))
268 (stop #~(lambda args
269 ;; Normally there are no processes left at this point, so
270 ;; TARGET can be safely unmounted.
271
272 ;; Make sure PID 1 doesn't keep TARGET busy.
273 (chdir "/")
274
275 (umount #$target)
276 #f))
277
278 ;; We need an additional module.
279 (modules `(((gnu build file-systems)
280 #:select (check-file-system canonicalize-device-spec))
281 ,@%default-modules))
282 (imported-modules `((gnu build file-systems)
6eb43907 283 (guix build bournish)
be21979d
LC
284 ,@%default-imported-modules))))
285 '())))
e43e84ba 286
0adfe95a
LC
287(define file-system-service-type
288 ;; TODO(?): Make this an extensible service that takes <file-system> objects
d4053c71 289 ;; and returns a list of <shepherd-service>.
e43e84ba
LC
290 (service-type (name 'file-system)
291 (extensions
d4053c71
AK
292 (list (service-extension shepherd-root-service-type
293 file-system-shepherd-service)
e43e84ba
LC
294 (service-extension fstab-service-type
295 identity)))))
0adfe95a
LC
296
297(define* (file-system-service file-system)
298 "Return a service that mounts @var{file-system}, a @code{<file-system>}
299object."
300 (service file-system-service-type file-system))
301
302(define user-unmount-service-type
d4053c71 303 (shepherd-service-type
5f44ee4f 304 'user-file-systems
0adfe95a 305 (lambda (known-mount-points)
d4053c71 306 (shepherd-service
0adfe95a 307 (documentation "Unmount manually-mounted file systems.")
5f44ee4f 308 (provision '(user-file-systems))
0adfe95a
LC
309 (start #~(const #t))
310 (stop #~(lambda args
311 (define (known? mount-point)
312 (member mount-point
313 (cons* "/proc" "/sys" '#$known-mount-points)))
314
315 ;; Make sure we don't keep the user's mount points busy.
316 (chdir "/")
317
318 (for-each (lambda (mount-point)
319 (format #t "unmounting '~a'...~%" mount-point)
320 (catch 'system-error
321 (lambda ()
322 (umount mount-point))
323 (lambda args
324 (let ((errno (system-error-errno args)))
325 (format #t "failed to unmount '~a': ~a~%"
326 mount-point (strerror errno))))))
327 (filter (negate known?) (mount-points)))
328 #f))))))
023f391c 329
d6e2a622
LC
330(define (user-unmount-service known-mount-points)
331 "Return a service whose sole purpose is to unmount file systems not listed
332in KNOWN-MOUNT-POINTS when it is stopped."
0adfe95a 333 (service user-unmount-service-type known-mount-points))
d6e2a622 334
7d57cfd3
LC
335(define %do-not-kill-file
336 ;; Name of the file listing PIDs of processes that must survive when halting
337 ;; the system. Typical example is user-space file systems.
b8c02c18 338 "/etc/shepherd/do-not-kill")
7d57cfd3 339
0adfe95a 340(define user-processes-service-type
d4053c71 341 (shepherd-service-type
00184239 342 'user-processes
0adfe95a
LC
343 (match-lambda
344 ((requirements grace-delay)
d4053c71 345 (shepherd-service
0adfe95a
LC
346 (documentation "When stopped, terminate all user processes.")
347 (provision '(user-processes))
5f44ee4f 348 (requirement (cons* 'root-file-system 'user-file-systems
d4053c71 349 (map file-system->shepherd-service-name
5f44ee4f 350 requirements)))
0adfe95a
LC
351 (start #~(const #t))
352 (stop #~(lambda _
353 (define (kill-except omit signal)
354 ;; Kill all the processes with SIGNAL except those listed
355 ;; in OMIT and the current process.
356 (let ((omit (cons (getpid) omit)))
357 (for-each (lambda (pid)
358 (unless (memv pid omit)
359 (false-if-exception
360 (kill pid signal))))
361 (processes))))
362
363 (define omitted-pids
364 ;; List of PIDs that must not be killed.
365 (if (file-exists? #$%do-not-kill-file)
366 (map string->number
367 (call-with-input-file #$%do-not-kill-file
368 (compose string-tokenize
369 (@ (ice-9 rdelim) read-string))))
370 '()))
371
372 (define (now)
373 (car (gettimeofday)))
374
375 (define (sleep* n)
376 ;; Really sleep N seconds.
377 ;; Work around <http://bugs.gnu.org/19581>.
378 (define start (now))
379 (let loop ((elapsed 0))
380 (when (> n elapsed)
381 (sleep (- n elapsed))
382 (loop (- (now) start)))))
383
384 (define lset= (@ (srfi srfi-1) lset=))
385
386 (display "sending all processes the TERM signal\n")
387
388 (if (null? omitted-pids)
389 (begin
390 ;; Easy: terminate all of them.
391 (kill -1 SIGTERM)
392 (sleep* #$grace-delay)
393 (kill -1 SIGKILL))
394 (begin
395 ;; Kill them all except OMITTED-PIDS. XXX: We would
396 ;; like to (kill -1 SIGSTOP) to get a fixed list of
397 ;; processes, like 'killall5' does, but that seems
398 ;; unreliable.
399 (kill-except omitted-pids SIGTERM)
400 (sleep* #$grace-delay)
401 (kill-except omitted-pids SIGKILL)
402 (delete-file #$%do-not-kill-file)))
403
404 (let wait ()
405 (let ((pids (processes)))
406 (unless (lset= = pids (cons 1 omitted-pids))
407 (format #t "waiting for process termination\
408 (processes left: ~s)~%"
409 pids)
410 (sleep* 2)
411 (wait))))
412
413 (display "all processes have been terminated\n")
414 #f))
415 (respawn? #f))))))
416
417(define* (user-processes-service file-systems #:key (grace-delay 4))
a00dd9fb
LC
418 "Return the service that is responsible for terminating all the processes so
419that the root file system can be re-mounted read-only, just before
420rebooting/halting. Processes still running GRACE-DELAY seconds after SIGTERM
421has been sent are terminated with SIGKILL.
422
d4053c71 423The returned service will depend on 'root-file-system' and on all the shepherd
0adfe95a 424services corresponding to FILE-SYSTEMS.
023f391c 425
a00dd9fb
LC
426All the services that spawn processes must depend on this one so that they are
427stopped before 'kill' is called."
0adfe95a 428 (service user-processes-service-type
be21979d 429 (list (filter file-system-mount? file-systems) grace-delay)))
d656c14e 430
0adfe95a 431\f
a535e122
LF
432;;;
433;;; Preserve entropy to seed /dev/urandom on boot.
434;;;
435
436(define %random-seed-file
437 "/var/lib/random-seed")
438
a535e122
LF
439(define (urandom-seed-shepherd-service _)
440 "Return a shepherd service for the /dev/urandom seed."
441 (list (shepherd-service
442 (documentation "Preserve entropy across reboots for /dev/urandom.")
443 (provision '(urandom-seed))
444 (requirement '(user-processes))
445 (start #~(lambda _
446 ;; On boot, write random seed into /dev/urandom.
447 (when (file-exists? #$%random-seed-file)
448 (call-with-input-file #$%random-seed-file
449 (lambda (seed)
450 (call-with-output-file "/dev/urandom"
451 (lambda (urandom)
452 (dump-port seed urandom))))))
71cb237a
LF
453 ;; Immediately refresh the seed in case the system doesn't
454 ;; shut down cleanly.
455 (call-with-input-file "/dev/urandom"
456 (lambda (urandom)
457 (let ((previous-umask (umask #o077))
458 (buf (make-bytevector 512)))
459 (mkdir-p (dirname #$%random-seed-file))
460 (get-bytevector-n! urandom buf 0 512)
461 (call-with-output-file #$%random-seed-file
462 (lambda (seed)
463 (put-bytevector seed buf)))
464 (umask previous-umask))))
a535e122
LF
465 #t))
466 (stop #~(lambda _
467 ;; During shutdown, write from /dev/urandom into random seed.
468 (let ((buf (make-bytevector 512)))
469 (call-with-input-file "/dev/urandom"
470 (lambda (urandom)
8fe5d95e
LF
471 (let ((previous-umask (umask #o077)))
472 (get-bytevector-n! urandom buf 0 512)
71cb237a 473 (mkdir-p (dirname #$%random-seed-file))
8fe5d95e
LF
474 (call-with-output-file #$%random-seed-file
475 (lambda (seed)
476 (put-bytevector seed buf)))
477 (umask previous-umask))
a535e122
LF
478 #t)))))
479 (modules `((rnrs bytevectors)
480 (rnrs io ports)
481 ,@%default-modules)))))
482
483(define urandom-seed-service-type
484 (service-type (name 'urandom-seed)
485 (extensions
486 (list (service-extension shepherd-root-service-type
71cb237a 487 urandom-seed-shepherd-service)))))
a535e122
LF
488
489(define (urandom-seed-service)
490 (service urandom-seed-service-type #f))
491
b58cbf9a
DC
492
493;;;
494;;; Add hardware random number generator to entropy pool.
495;;;
496
497(define-record-type* <rngd-configuration>
498 rngd-configuration make-rngd-configuration
499 rngd-configuration?
500 (rng-tools rngd-configuration-rng-tools) ;package
501 (device rngd-configuration-device)) ;string
502
503(define rngd-service-type
504 (shepherd-service-type
505 'rngd
506 (lambda (config)
507 (define rng-tools (rngd-configuration-rng-tools config))
508 (define device (rngd-configuration-device config))
509
510 (define rngd-command
511 (list #~(string-append #$rng-tools "/sbin/rngd")
512 "-f" "-r" device))
513
514 (shepherd-service
515 (documentation "Add TRNG to entropy pool.")
516 (requirement '(udev))
517 (provision '(trng))
518 (start #~(make-forkexec-constructor #$@rngd-command))
519 (stop #~(make-kill-destructor))))))
520
521(define* (rngd-service #:key
522 (rng-tools rng-tools)
523 (device "/dev/hwrng"))
524 "Return a service that runs the @command{rngd} program from @var{rng-tools}
525to add @var{device} to the kernel's entropy pool. The service will fail if
526@var{device} does not exist."
527 (service rngd-service-type
528 (rngd-configuration
529 (rng-tools rng-tools)
530 (device device))))
531
532
e10964ef
SB
533;;;
534;;; System-wide environment variables.
535;;;
536
537(define (environment-variables->environment-file vars)
538 "Return a file for pam_env(8) that contains environment variables VARS."
539 (apply mixed-text-file "environment"
540 (append-map (match-lambda
541 ((key . value)
542 (list key "=" value "\n")))
543 vars)))
544
545(define session-environment-service-type
546 (service-type
547 (name 'session-environment)
548 (extensions
549 (list (service-extension
550 etc-service-type
551 (lambda (vars)
552 (list `("environment"
553 ,(environment-variables->environment-file vars)))))))
554 (compose concatenate)
555 (extend append)))
556
557(define (session-environment-service vars)
558 "Return a service that builds the @file{/etc/environment}, which can be read
559by PAM-aware applications to set environment variables for sessions.
560
561VARS should be an association list in which both the keys and the values are
562strings or string-valued gexps."
563 (service session-environment-service-type vars))
564
565\f
0adfe95a
LC
566;;;
567;;; Console & co.
568;;;
569
570(define host-name-service-type
d4053c71 571 (shepherd-service-type
00184239 572 'host-name
0adfe95a 573 (lambda (name)
d4053c71 574 (shepherd-service
0adfe95a
LC
575 (documentation "Initialize the machine's host name.")
576 (provision '(host-name))
577 (start #~(lambda _
578 (sethostname #$name)))
579 (respawn? #f)))))
a00dd9fb 580
db4fdc04 581(define (host-name-service name)
51da7ca0 582 "Return a service that sets the host name to @var{name}."
0adfe95a 583 (service host-name-service-type name))
db4fdc04 584
62ca0fdf
LC
585(define (unicode-start tty)
586 "Return a gexp to start Unicode support on @var{tty}."
587
588 ;; We have to run 'unicode_start' in a pipe so that when it invokes the
589 ;; 'tty' command, that command returns TTY.
590 #~(begin
591 (let ((pid (primitive-fork)))
592 (case pid
593 ((0)
594 (close-fdes 0)
595 (dup2 (open-fdes #$tty O_RDONLY) 0)
596 (close-fdes 1)
597 (dup2 (open-fdes #$tty O_WRONLY) 1)
598 (execl (string-append #$kbd "/bin/unicode_start")
599 "unicode_start"))
600 (else
601 (zero? (cdr (waitpid pid))))))))
602
0adfe95a 603(define console-keymap-service-type
d4053c71 604 (shepherd-service-type
00184239 605 'console-keymap
b3d05f48 606 (lambda (files)
d4053c71 607 (shepherd-service
0adfe95a
LC
608 (documentation (string-append "Load console keymap (loadkeys)."))
609 (provision '(console-keymap))
610 (start #~(lambda _
611 (zero? (system* (string-append #$kbd "/bin/loadkeys")
b3d05f48 612 #$@files))))
0adfe95a
LC
613 (respawn? #f)))))
614
b3d05f48
AK
615(define (console-keymap-service . files)
616 "Return a service to load console keymaps from @var{files}."
617 (service console-keymap-service-type files))
0adfe95a
LC
618
619(define console-font-service-type
d4053c71 620 (shepherd-service-type
00184239 621 'console-font
0adfe95a
LC
622 (match-lambda
623 ((tty font)
624 (let ((device (string-append "/dev/" tty)))
d4053c71 625 (shepherd-service
0adfe95a
LC
626 (documentation "Load a Unicode console font.")
627 (provision (list (symbol-append 'console-font-
628 (string->symbol tty))))
629
630 ;; Start after mingetty has been started on TTY, otherwise the settings
631 ;; are ignored.
632 (requirement (list (symbol-append 'term-
633 (string->symbol tty))))
634
635 (start #~(lambda _
636 (and #$(unicode-start device)
637 (zero?
638 (system* (string-append #$kbd "/bin/setfont")
639 "-C" #$device #$font)))))
640 (stop #~(const #t))
641 (respawn? #f)))))))
5eca9459 642
62ca0fdf
LC
643(define* (console-font-service tty #:optional (font "LatGrkCyr-8x16"))
644 "Return a service that sets up Unicode support in @var{tty} and loads
645@var{font} for that tty (fonts are per virtual console in Linux.)"
646 ;; Note: 'LatGrkCyr-8x16' has the advantage of providing three common
647 ;; scripts as well as glyphs for em dash, quotation marks, and other Unicode
648 ;; codepoints notably found in the UTF-8 manual.
0adfe95a 649 (service console-font-service-type (list tty font)))
62ca0fdf 650
66e4f01c
LC
651(define-record-type* <mingetty-configuration>
652 mingetty-configuration make-mingetty-configuration
653 mingetty-configuration?
654 (mingetty mingetty-configuration-mingetty ;<package>
655 (default mingetty))
656 (tty mingetty-configuration-tty) ;string
657 (motd mingetty-configuration-motd ;file-like
658 (default (plain-file "motd" "Welcome.\n")))
659 (auto-login mingetty-auto-login ;string | #f
660 (default #f))
661 (login-program mingetty-login-program ;gexp
662 (default #f))
663 (login-pause? mingetty-login-pause? ;Boolean
664 (default #f))
665
666 ;; Allow empty passwords by default so that first-time users can log in when
667 ;; the 'root' account has just been created.
668 (allow-empty-passwords? mingetty-configuration-allow-empty-passwords?
669 (default #t))) ;Boolean
670
0adfe95a
LC
671(define (mingetty-pam-service conf)
672 "Return the list of PAM service needed for CONF."
673 ;; Let 'login' be known to PAM. All the mingetty services will have that
674 ;; PAM service, but that's fine because they're all identical and duplicates
675 ;; are removed.
676 (list (unix-pam-service "login"
677 #:allow-empty-passwords?
678 (mingetty-configuration-allow-empty-passwords? conf)
679 #:motd
680 (mingetty-configuration-motd conf))))
681
d4053c71 682(define mingetty-shepherd-service
0adfe95a 683 (match-lambda
66e4f01c
LC
684 (($ <mingetty-configuration> mingetty tty motd auto-login login-program
685 login-pause? allow-empty-passwords?)
0adfe95a 686 (list
d4053c71 687 (shepherd-service
0adfe95a
LC
688 (documentation "Run mingetty on an tty.")
689 (provision (list (symbol-append 'term- (string->symbol tty))))
690
691 ;; Since the login prompt shows the host name, wait for the 'host-name'
692 ;; service to be done. Also wait for udev essentially so that the tty
693 ;; text is not lost in the middle of kernel messages (XXX).
694 (requirement '(user-processes host-name udev))
695
696 (start #~(make-forkexec-constructor
697 (list (string-append #$mingetty "/sbin/mingetty")
698 "--noclear" #$tty
699 #$@(if auto-login
700 #~("--autologin" #$auto-login)
701 #~())
702 #$@(if login-program
703 #~("--loginprog" #$login-program)
704 #~())
705 #$@(if login-pause?
706 #~("--loginpause")
707 #~()))))
708 (stop #~(make-kill-destructor)))))))
709
710(define mingetty-service-type
711 (service-type (name 'mingetty)
d4053c71
AK
712 (extensions (list (service-extension shepherd-root-service-type
713 mingetty-shepherd-service)
0adfe95a
LC
714 (service-extension pam-root-service-type
715 mingetty-pam-service)))))
716
717(define* (mingetty-service config)
718 "Return a service to run mingetty according to @var{config}, which specifies
719the tty to run, among other things."
720 (service mingetty-service-type config))
db4fdc04 721
6454b333
LC
722(define-record-type* <nscd-configuration> nscd-configuration
723 make-nscd-configuration
724 nscd-configuration?
725 (log-file nscd-configuration-log-file ;string
726 (default "/var/log/nscd.log"))
727 (debug-level nscd-debug-level ;integer
728 (default 0))
729 ;; TODO: See nscd.conf in glibc for other options to add.
730 (caches nscd-configuration-caches ;list of <nscd-cache>
b893f1ae
LC
731 (default %nscd-default-caches))
732 (name-services nscd-configuration-name-services ;list of <packages>
733 (default '()))
734 (glibc nscd-configuration-glibc ;<package>
735 (default (canonical-package glibc))))
6454b333
LC
736
737(define-record-type* <nscd-cache> nscd-cache make-nscd-cache
738 nscd-cache?
739 (database nscd-cache-database) ;symbol
740 (positive-time-to-live nscd-cache-positive-time-to-live) ;integer
741 (negative-time-to-live nscd-cache-negative-time-to-live
742 (default 20)) ;integer
743 (suggested-size nscd-cache-suggested-size ;integer ("default module
744 ;of hash table")
745 (default 211))
746 (check-files? nscd-cache-check-files? ;Boolean
747 (default #t))
748 (persistent? nscd-cache-persistent? ;Boolean
749 (default #t))
750 (shared? nscd-cache-shared? ;Boolean
751 (default #t))
752 (max-database-size nscd-cache-max-database-size ;integer
753 (default (* 32 (expt 2 20))))
754 (auto-propagate? nscd-cache-auto-propagate? ;Boolean
755 (default #t)))
756
757(define %nscd-default-caches
758 ;; Caches that we want to enable by default. Note that when providing an
759 ;; empty nscd.conf, all caches are disabled.
760 (list (nscd-cache (database 'hosts)
761
762 ;; Aggressively cache the host name cache to improve
763 ;; privacy and resilience.
764 (positive-time-to-live (* 3600 12))
765 (negative-time-to-live 20)
766 (persistent? #t))
767
768 (nscd-cache (database 'services)
769
770 ;; Services are unlikely to change, so we can be even more
771 ;; aggressive.
772 (positive-time-to-live (* 3600 24))
773 (negative-time-to-live 3600)
774 (check-files? #t) ;check /etc/services changes
775 (persistent? #t))))
776
777(define %nscd-default-configuration
778 ;; Default nscd configuration.
779 (nscd-configuration))
780
781(define (nscd.conf-file config)
782 "Return the @file{nscd.conf} configuration file for @var{config}, an
783@code{<nscd-configuration>} object."
784 (define cache->config
785 (match-lambda
be1c2c54
LC
786 (($ <nscd-cache> (= symbol->string database)
787 positive-ttl negative-ttl size check-files?
788 persistent? shared? max-size propagate?)
789 (string-append "\nenable-cache\t" database "\tyes\n"
790
791 "positive-time-to-live\t" database "\t"
792 (number->string positive-ttl) "\n"
793 "negative-time-to-live\t" database "\t"
794 (number->string negative-ttl) "\n"
795 "suggested-size\t" database "\t"
796 (number->string size) "\n"
797 "check-files\t" database "\t"
798 (if check-files? "yes\n" "no\n")
799 "persistent\t" database "\t"
800 (if persistent? "yes\n" "no\n")
801 "shared\t" database "\t"
802 (if shared? "yes\n" "no\n")
803 "max-db-size\t" database "\t"
804 (number->string max-size) "\n"
805 "auto-propagate\t" database "\t"
806 (if propagate? "yes\n" "no\n")))))
6454b333
LC
807
808 (match config
809 (($ <nscd-configuration> log-file debug-level caches)
be1c2c54
LC
810 (plain-file "nscd.conf"
811 (string-append "\
6454b333 812# Configuration of libc's name service cache daemon (nscd).\n\n"
be1c2c54
LC
813 (if log-file
814 (string-append "logfile\t" log-file)
815 "")
816 "\n"
817 (if debug-level
818 (string-append "debug-level\t"
819 (number->string debug-level))
820 "")
821 "\n"
822 (string-concatenate
823 (map cache->config caches)))))))
6454b333 824
d4053c71
AK
825(define (nscd-shepherd-service config)
826 "Return a shepherd service for CONFIG, an <nscd-configuration> object."
0adfe95a
LC
827 (let ((nscd.conf (nscd.conf-file config))
828 (name-services (nscd-configuration-name-services config)))
d4053c71 829 (list (shepherd-service
0adfe95a
LC
830 (documentation "Run libc's name service cache daemon (nscd).")
831 (provision '(nscd))
832 (requirement '(user-processes))
833 (start #~(make-forkexec-constructor
834 (list (string-append #$(nscd-configuration-glibc config)
835 "/sbin/nscd")
836 "-f" #$nscd.conf "--foreground")
837
04101d99
LC
838 ;; Wait for the PID file. However, the PID file is
839 ;; written before nscd is actually listening on its
840 ;; socket (XXX).
841 #:pid-file "/var/run/nscd/nscd.pid"
842
0adfe95a
LC
843 #:environment-variables
844 (list (string-append "LD_LIBRARY_PATH="
845 (string-join
846 (map (lambda (dir)
847 (string-append dir "/lib"))
848 (list #$@name-services))
849 ":")))))
cc7234ae 850 (stop #~(make-kill-destructor))))))
0adfe95a
LC
851
852(define nscd-activation
853 ;; Actions to take before starting nscd.
854 #~(begin
855 (use-modules (guix build utils))
856 (mkdir-p "/var/run/nscd")
857 (mkdir-p "/var/db/nscd"))) ;for the persistent cache
858
859(define nscd-service-type
860 (service-type (name 'nscd)
861 (extensions
862 (list (service-extension activation-service-type
863 (const nscd-activation))
d4053c71
AK
864 (service-extension shepherd-root-service-type
865 nscd-shepherd-service)))
0adfe95a
LC
866
867 ;; This can be extended by providing additional name services
868 ;; such as nss-mdns.
869 (compose concatenate)
870 (extend (lambda (config name-services)
871 (nscd-configuration
872 (inherit config)
873 (name-services (append
874 (nscd-configuration-name-services config)
875 name-services)))))))
876
b893f1ae 877(define* (nscd-service #:optional (config %nscd-default-configuration))
6454b333 878 "Return a service that runs libc's name service cache daemon (nscd) with the
b893f1ae
LC
879given @var{config}---an @code{<nscd-configuration>} object. @xref{Name
880Service Switch}, for an example."
0adfe95a
LC
881 (service nscd-service-type config))
882
883(define syslog-service-type
d4053c71 884 (shepherd-service-type
00184239 885 'syslog
0adfe95a 886 (lambda (config-file)
d4053c71 887 (shepherd-service
0adfe95a
LC
888 (documentation "Run the syslog daemon (syslogd).")
889 (provision '(syslogd))
890 (requirement '(user-processes))
891 (start #~(make-forkexec-constructor
892 (list (string-append #$inetutils "/libexec/syslogd")
893 "--no-detach" "--rcfile" #$config-file)))
894 (stop #~(make-kill-destructor))))))
be1c2c54
LC
895
896;; Snippet adapted from the GNU inetutils manual.
897(define %default-syslog.conf
898 (plain-file "syslog.conf" "
1f3fc60d 899 # Log all error messages, authentication messages of
db4fdc04
LC
900 # level notice or higher and anything of level err or
901 # higher to the console.
902 # Don't log private authentication messages!
6a191274 903 *.alert;auth.notice;authpriv.none /dev/console
db4fdc04
LC
904
905 # Log anything (except mail) of level info or higher.
906 # Don't log private authentication messages!
907 *.info;mail.none;authpriv.none /var/log/messages
908
909 # Same, in a different place.
910 *.info;mail.none;authpriv.none /dev/tty12
911
912 # The authpriv file has restricted access.
913 authpriv.* /var/log/secure
914
915 # Log all the mail messages in one place.
916 mail.* /var/log/maillog
be1c2c54 917"))
0adfe95a 918
be1c2c54 919(define* (syslog-service #:key (config-file %default-syslog.conf))
44abcb28
LC
920 "Return a service that runs @command{syslogd}. If configuration file
921name @var{config-file} is not specified, use some reasonable default
922settings.
923
924@xref{syslogd invocation,,, inetutils, GNU Inetutils}, for more
925information on the configuration file syntax."
0adfe95a 926 (service syslog-service-type config-file))
db4fdc04 927
1c52181f
LC
928\f
929;;;
930;;; Guix services.
931;;;
932
db4fdc04 933(define* (guix-build-accounts count #:key
ab6a279a 934 (group "guixbuild")
db4fdc04 935 (first-uid 30001)
db4fdc04
LC
936 (shadow shadow))
937 "Return a list of COUNT user accounts for Guix build users, with UIDs
938starting at FIRST-UID, and under GID."
5250a4f2
LC
939 (unfold (cut > <> count)
940 (lambda (n)
941 (user-account
942 (name (format #f "guixbuilder~2,'0d" n))
943 (system? #t)
944 (uid (+ first-uid n -1))
945 (group group)
946
947 ;; guix-daemon expects GROUP to be listed as a
948 ;; supplementary group too:
949 ;; <http://lists.gnu.org/archive/html/bug-guix/2013-01/msg00239.html>.
950 (supplementary-groups (list group "kvm"))
951
952 (comment (format #f "Guix Build User ~2d" n))
953 (home-directory "/var/empty")
954 (shell #~(string-append #$shadow "/sbin/nologin"))))
955 1+
956 1))
db4fdc04 957
2c5c696c
LC
958(define (hydra-key-authorization guix)
959 "Return a gexp with code to register the hydra.gnu.org public key with
960GUIX."
961 #~(unless (file-exists? "/etc/guix/acl")
962 (let ((pid (primitive-fork)))
963 (case pid
964 ((0)
965 (let* ((key (string-append #$guix
966 "/share/guix/hydra.gnu.org.pub"))
967 (port (open-file key "r0b")))
968 (format #t "registering public key '~a'...~%" key)
969 (close-port (current-input-port))
2c5c696c
LC
970 (dup port 0)
971 (execl (string-append #$guix "/bin/guix")
972 "guix" "archive" "--authorize")
973 (exit 1)))
974 (else
975 (let ((status (cdr (waitpid pid))))
976 (unless (zero? status)
977 (format (current-error-port) "warning: \
978failed to register hydra.gnu.org public key: ~a~%" status))))))))
979
0adfe95a
LC
980(define-record-type* <guix-configuration>
981 guix-configuration make-guix-configuration
982 guix-configuration?
983 (guix guix-configuration-guix ;<package>
984 (default guix))
985 (build-group guix-configuration-build-group ;string
986 (default "guixbuild"))
987 (build-accounts guix-configuration-build-accounts ;integer
988 (default 10))
989 (authorize-key? guix-configuration-authorize-key? ;Boolean
990 (default #t))
991 (use-substitutes? guix-configuration-use-substitutes? ;Boolean
992 (default #t))
b0b9f6e0
LC
993 (substitute-urls guix-configuration-substitute-urls ;list of strings
994 (default %default-substitute-urls))
0adfe95a
LC
995 (extra-options guix-configuration-extra-options ;list of strings
996 (default '()))
997 (lsof guix-configuration-lsof ;<package>
998 (default lsof))
999 (lsh guix-configuration-lsh ;<package>
1000 (default lsh)))
1001
1002(define %default-guix-configuration
1003 (guix-configuration))
1004
d4053c71
AK
1005(define (guix-shepherd-service config)
1006 "Return a <shepherd-service> for the Guix daemon service with CONFIG."
0adfe95a
LC
1007 (match config
1008 (($ <guix-configuration> guix build-group build-accounts authorize-key?
b0b9f6e0
LC
1009 use-substitutes? substitute-urls extra-options
1010 lsof lsh)
d4053c71 1011 (list (shepherd-service
0adfe95a
LC
1012 (documentation "Run the Guix daemon.")
1013 (provision '(guix-daemon))
1014 (requirement '(user-processes))
1015 (start
1016 #~(make-forkexec-constructor
1017 (list (string-append #$guix "/bin/guix-daemon")
1018 "--build-users-group" #$build-group
1019 #$@(if use-substitutes?
1020 '()
1021 '("--no-substitutes"))
b0b9f6e0 1022 "--substitute-urls" #$(string-join substitute-urls)
0adfe95a
LC
1023 #$@extra-options)
1024
1025 ;; Add 'lsof' (for the GC) and 'lsh' (for offloading) to the
1026 ;; daemon's $PATH.
1027 #:environment-variables
1028 (list (string-append "PATH=" #$lsof "/bin:" #$lsh "/bin"))))
1029 (stop #~(make-kill-destructor)))))))
1030
1031(define (guix-accounts config)
1032 "Return the user accounts and user groups for CONFIG."
1033 (match config
1034 (($ <guix-configuration> _ build-group build-accounts)
1035 (cons (user-group
1036 (name build-group)
1037 (system? #t)
1038
1039 ;; Use a fixed GID so that we can create the store with the right
1040 ;; owner.
1041 (id 30000))
1042 (guix-build-accounts build-accounts
1043 #:group build-group)))))
1044
1045(define (guix-activation config)
1046 "Return the activation gexp for CONFIG."
1047 (match config
1048 (($ <guix-configuration> guix build-group build-accounts authorize-key?)
1049 ;; Assume that the store has BUILD-GROUP as its group. We could
1050 ;; otherwise call 'chown' here, but the problem is that on a COW unionfs,
1051 ;; chown leads to an entire copy of the tree, which is a bad idea.
1052
1053 ;; Optionally authorize hydra.gnu.org's key.
1054 (and authorize-key?
1055 (hydra-key-authorization guix)))))
1056
1057(define guix-service-type
1058 (service-type
1059 (name 'guix)
1060 (extensions
d4053c71 1061 (list (service-extension shepherd-root-service-type guix-shepherd-service)
0adfe95a 1062 (service-extension account-service-type guix-accounts)
9a8b9eb8
LC
1063 (service-extension activation-service-type guix-activation)
1064 (service-extension profile-service-type
1065 (compose list guix-configuration-guix))))))
0adfe95a
LC
1066
1067(define* (guix-service #:optional (config %default-guix-configuration))
1068 "Return a service that runs the Guix build daemon according to
1069@var{config}."
1070 (service guix-service-type config))
1071
1c52181f
LC
1072
1073(define-record-type* <guix-publish-configuration>
1074 guix-publish-configuration make-guix-publish-configuration
1075 guix-publish-configuration?
1076 (guix guix-publish-configuration-guix ;package
1077 (default guix))
1078 (port guix-publish-configuration-port ;number
1079 (default 80))
1080 (host guix-publish-configuration-host ;string
1081 (default "localhost")))
1082
d4053c71 1083(define guix-publish-shepherd-service
1c52181f
LC
1084 (match-lambda
1085 (($ <guix-publish-configuration> guix port host)
d4053c71 1086 (list (shepherd-service
1c52181f
LC
1087 (provision '(guix-publish))
1088 (requirement '(guix-daemon))
1089 (start #~(make-forkexec-constructor
1090 (list (string-append #$guix "/bin/guix")
1091 "publish" "-u" "guix-publish"
1092 "-p" #$(number->string port)
1093 (string-append "--listen=" #$host))))
1094 (stop #~(make-kill-destructor)))))))
1095
1096(define %guix-publish-accounts
1097 (list (user-group (name "guix-publish") (system? #t))
1098 (user-account
1099 (name "guix-publish")
1100 (group "guix-publish")
1101 (system? #t)
1102 (comment "guix publish user")
1103 (home-directory "/var/empty")
1104 (shell #~(string-append #$shadow "/sbin/nologin")))))
1105
1106(define guix-publish-service-type
1107 (service-type (name 'guix-publish)
1108 (extensions
d4053c71
AK
1109 (list (service-extension shepherd-root-service-type
1110 guix-publish-shepherd-service)
1c52181f
LC
1111 (service-extension account-service-type
1112 (const %guix-publish-accounts))))))
1113
1114(define* (guix-publish-service #:key (guix guix) (port 80) (host "localhost"))
1115 "Return a service that runs @command{guix publish} listening on @var{host}
1116and @var{port} (@pxref{Invoking guix publish}).
1117
1118This assumes that @file{/etc/guix} already contains a signing key pair as
1119created by @command{guix archive --generate-key} (@pxref{Invoking guix
1120archive}). If that is not the case, the service will fail to start."
1121 (service guix-publish-service-type
1122 (guix-publish-configuration (guix guix) (port port) (host host))))
1123
0adfe95a
LC
1124\f
1125;;;
1126;;; Udev.
1127;;;
1128
1129(define-record-type* <udev-configuration>
1130 udev-configuration make-udev-configuration
1131 udev-configuration?
1132 (udev udev-configuration-udev ;<package>
1133 (default udev))
1134 (rules udev-configuration-rules ;list of <package>
1135 (default '())))
db4fdc04 1136
ecd06ca9
LC
1137(define (udev-rules-union packages)
1138 "Return the union of the @code{lib/udev/rules.d} directories found in each
1139item of @var{packages}."
1140 (define build
4ee96a79
LC
1141 (with-imported-modules '((guix build union)
1142 (guix build utils))
1143 #~(begin
1144 (use-modules (guix build union)
1145 (guix build utils)
1146 (srfi srfi-1)
1147 (srfi srfi-26))
ecd06ca9 1148
4ee96a79
LC
1149 (define %standard-locations
1150 '("/lib/udev/rules.d" "/libexec/udev/rules.d"))
ecd06ca9 1151
4ee96a79
LC
1152 (define (rules-sub-directory directory)
1153 ;; Return the sub-directory of DIRECTORY containing udev rules, or
1154 ;; #f if none was found.
1155 (find directory-exists?
1156 (map (cut string-append directory <>) %standard-locations)))
ecd06ca9 1157
4ee96a79
LC
1158 (mkdir-p (string-append #$output "/lib/udev"))
1159 (union-build (string-append #$output "/lib/udev/rules.d")
1160 (filter-map rules-sub-directory '#$packages)))))
ecd06ca9 1161
4ee96a79 1162 (computed-file "udev-rules" build))
ecd06ca9 1163
80e6f37e
RW
1164(define (udev-rule file-name contents)
1165 "Return a directory with a udev rule file FILE-NAME containing CONTENTS."
1166 (computed-file file-name
4ee96a79
LC
1167 (with-imported-modules '((guix build utils))
1168 #~(begin
1169 (use-modules (guix build utils))
1170
1171 (define rules.d
1172 (string-append #$output "/lib/udev/rules.d"))
1173
1174 (mkdir-p rules.d)
1175 (call-with-output-file
1176 (string-append rules.d "/" #$file-name)
1177 (lambda (port)
1178 (display #$contents port)))))))
7f28bf9a 1179
80e6f37e
RW
1180(define kvm-udev-rule
1181 ;; Return a directory with a udev rule that changes the group of /dev/kvm to
1182 ;; "kvm" and makes it #o660. Apparently QEMU-KVM used to ship this rule,
1183 ;; but now we have to add it by ourselves.
1184
1185 ;; Build users are part of the "kvm" group, so we can fearlessly make
1186 ;; /dev/kvm 660 (see <http://bugs.gnu.org/18994>, for background.)
1187 (udev-rule "90-kvm.rules"
1188 "KERNEL==\"kvm\", GROUP=\"kvm\", MODE=\"0660\"\n"))
1189
d4053c71
AK
1190(define udev-shepherd-service
1191 ;; Return a <shepherd-service> for UDEV with RULES.
0adfe95a
LC
1192 (match-lambda
1193 (($ <udev-configuration> udev rules)
80e6f37e 1194 (let* ((rules (udev-rules-union (cons* udev kvm-udev-rule rules)))
0adfe95a
LC
1195 (udev.conf (computed-file "udev.conf"
1196 #~(call-with-output-file #$output
1197 (lambda (port)
1198 (format port
1199 "udev_rules=\"~a/lib/udev/rules.d\"\n"
1200 #$rules))))))
1201 (list
d4053c71 1202 (shepherd-service
0adfe95a
LC
1203 (provision '(udev))
1204
1205 ;; Udev needs /dev to be a 'devtmpfs' mount so that new device nodes can
1206 ;; be added: see
1207 ;; <http://www.linuxfromscratch.org/lfs/view/development/chapter07/udev.html>.
1208 (requirement '(root-file-system))
1209
1210 (documentation "Populate the /dev directory, dynamically.")
1211 (start #~(lambda ()
1212 (define find
1213 (@ (srfi srfi-1) find))
1214
1215 (define udevd
1216 ;; Choose the right 'udevd'.
1217 (find file-exists?
1218 (map (lambda (suffix)
1219 (string-append #$udev suffix))
1220 '("/libexec/udev/udevd" ;udev
1221 "/sbin/udevd")))) ;eudev
1222
1223 (define (wait-for-udevd)
1224 ;; Wait until someone's listening on udevd's control
1225 ;; socket.
1226 (let ((sock (socket AF_UNIX SOCK_SEQPACKET 0)))
1227 (let try ()
1228 (catch 'system-error
1229 (lambda ()
1230 (connect sock PF_UNIX "/run/udev/control")
1231 (close-port sock))
1232 (lambda args
1233 (format #t "waiting for udevd...~%")
1234 (usleep 500000)
1235 (try))))))
1236
1237 ;; Allow udev to find the modules.
1238 (setenv "LINUX_MODULE_DIRECTORY"
1239 "/run/booted-system/kernel/lib/modules")
1240
1241 ;; The first one is for udev, the second one for eudev.
1242 (setenv "UDEV_CONFIG_FILE" #$udev.conf)
1243 (setenv "EUDEV_RULES_DIRECTORY"
1244 (string-append #$rules "/lib/udev/rules.d"))
1245
1246 (let ((pid (primitive-fork)))
1247 (case pid
1248 ((0)
1249 (exec-command (list udevd)))
1250 (else
1251 ;; Wait until udevd is up and running. This
1252 ;; appears to be needed so that the events
1253 ;; triggered below are actually handled.
1254 (wait-for-udevd)
1255
1256 ;; Trigger device node creation.
1257 (system* (string-append #$udev "/bin/udevadm")
1258 "trigger" "--action=add")
1259
1260 ;; Wait for things to settle down.
1261 (system* (string-append #$udev "/bin/udevadm")
1262 "settle")
1263 pid)))))
1264 (stop #~(make-kill-destructor))
1265
1266 ;; When halting the system, 'udev' is actually killed by
1267 ;; 'user-processes', i.e., before its own 'stop' method was called.
1268 ;; Thus, make sure it is not respawned.
1269 (respawn? #f)))))))
1270
1271(define udev-service-type
1272 (service-type (name 'udev)
1273 (extensions
d4053c71
AK
1274 (list (service-extension shepherd-root-service-type
1275 udev-shepherd-service)))
0adfe95a
LC
1276
1277 (compose concatenate) ;concatenate the list of rules
1278 (extend (lambda (config rules)
1279 (match config
1280 (($ <udev-configuration> udev initial-rules)
1281 (udev-configuration
1282 (udev udev)
1283 (rules (append initial-rules rules)))))))))
1284
255f7308 1285(define* (udev-service #:key (udev eudev) (rules '()))
ecd06ca9
LC
1286 "Run @var{udev}, which populates the @file{/dev} directory dynamically. Get
1287extra rules from the packages listed in @var{rules}."
0adfe95a
LC
1288 (service udev-service-type
1289 (udev-configuration (udev udev) (rules rules))))
1290
0adfe95a 1291(define swap-service-type
d4053c71 1292 (shepherd-service-type
00184239 1293 'swap
0adfe95a
LC
1294 (lambda (device)
1295 (define requirement
1296 (if (string-prefix? "/dev/mapper/" device)
1297 (list (symbol-append 'device-mapping-
1298 (string->symbol (basename device))))
1299 '()))
1300
d4053c71 1301 (shepherd-service
0adfe95a
LC
1302 (provision (list (symbol-append 'swap- (string->symbol device))))
1303 (requirement `(udev ,@requirement))
1304 (documentation "Enable the given swap device.")
1305 (start #~(lambda ()
1306 (restart-on-EINTR (swapon #$device))
1307 #t))
1308 (stop #~(lambda _
1309 (restart-on-EINTR (swapoff #$device))
1310 #f))
1311 (respawn? #f)))))
5dae0186 1312
2a13d05e
LC
1313(define (swap-service device)
1314 "Return a service that uses @var{device} as a swap device."
0adfe95a 1315 (service swap-service-type device))
2a13d05e 1316
8664cc88
LC
1317(define-record-type* <gpm-configuration>
1318 gpm-configuration make-gpm-configuration gpm-configuration?
1319 (gpm gpm-configuration-gpm) ;package
1320 (options gpm-configuration-options)) ;list of strings
1321
d4053c71 1322(define gpm-shepherd-service
8664cc88 1323 (match-lambda
a907d997 1324 (($ <gpm-configuration> gpm options)
d4053c71 1325 (list (shepherd-service
8664cc88
LC
1326 (requirement '(udev))
1327 (provision '(gpm))
1328 (start #~(lambda ()
1329 ;; 'gpm' runs in the background and sets a PID file.
1330 ;; Note that it requires running as "root".
1331 (false-if-exception (delete-file "/var/run/gpm.pid"))
1332 (fork+exec-command (list (string-append #$gpm "/sbin/gpm")
1333 #$@options))
1334
1335 ;; Wait for the PID file to appear; declare failure if
1336 ;; it doesn't show up.
1337 (let loop ((i 3))
1338 (or (file-exists? "/var/run/gpm.pid")
1339 (if (zero? i)
1340 #f
1341 (begin
1342 (sleep 1)
1343 (loop (1- i))))))))
1344
1345 (stop #~(lambda (_)
1346 ;; Return #f if successfully stopped.
1347 (not (zero? (system* (string-append #$gpm "/sbin/gpm")
1348 "-k"))))))))))
1349
1350(define gpm-service-type
1351 (service-type (name 'gpm)
1352 (extensions
d4053c71
AK
1353 (list (service-extension shepherd-root-service-type
1354 gpm-shepherd-service)))))
8664cc88
LC
1355
1356(define* (gpm-service #:key (gpm gpm)
1357 (options '("-m" "/dev/input/mice" "-t" "ps2")))
1358 "Run @var{gpm}, the general-purpose mouse daemon, with the given
1359command-line @var{options}. GPM allows users to use the mouse in the console,
1360notably to select, copy, and paste text. The default value of @var{options}
1361uses the @code{ps2} protocol, which works for both USB and PS/2 mice.
1362
1363This service is not part of @var{%base-services}."
1364 ;; To test in QEMU, use "-usbdevice mouse" and then, in the monitor, use
1365 ;; "info mice" and "mouse_set X" to use the right mouse.
1366 (service gpm-service-type
1367 (gpm-configuration (gpm gpm) (options options))))
1368
1369\f
8b198abe
LC
1370(define %base-services
1371 ;; Convenience variable holding the basic services.
ce8a6dfc 1372 (let ((motd (plain-file "motd" "
8b198abe 1373This is the GNU operating system, welcome!\n\n")))
62ca0fdf
LC
1374 (list (console-font-service "tty1")
1375 (console-font-service "tty2")
1376 (console-font-service "tty3")
1377 (console-font-service "tty4")
1378 (console-font-service "tty5")
1379 (console-font-service "tty6")
1380
66e4f01c
LC
1381 (mingetty-service (mingetty-configuration
1382 (tty "tty1") (motd motd)))
1383 (mingetty-service (mingetty-configuration
1384 (tty "tty2") (motd motd)))
1385 (mingetty-service (mingetty-configuration
1386 (tty "tty3") (motd motd)))
1387 (mingetty-service (mingetty-configuration
1388 (tty "tty4") (motd motd)))
1389 (mingetty-service (mingetty-configuration
1390 (tty "tty5") (motd motd)))
1391 (mingetty-service (mingetty-configuration
1392 (tty "tty6") (motd motd)))
1393
4a3b3b07
LC
1394 (static-networking-service "lo" "127.0.0.1"
1395 #:provision '(loopback))
8b198abe 1396 (syslog-service)
a535e122 1397 (urandom-seed-service)
8b198abe 1398 (guix-service)
151a2c07 1399 (nscd-service)
ecd06ca9 1400
52bd5734
LC
1401 ;; The LVM2 rules are needed as soon as LVM2 or the device-mapper is
1402 ;; used, so enable them by default. The FUSE and ALSA rules are
1403 ;; less critical, but handy.
68ac258b 1404 (udev-service #:rules (list lvm2 fuse alsa-utils crda)))))
8b198abe 1405
db4fdc04 1406;;; base.scm ends here