| blob | 11f55c588cf85dc9d26a9f4df936bd1ad6fced0d |
1 ;;; GNU Guix --- Functional package management for GNU
2 ;;; Copyright © 2013, 2014, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org>
3 ;;; Copyright © 2015, 2016 Alex Kost <alezost@gmail.com>
4 ;;; Copyright © 2015, 2016 Mark H Weaver <mhw@netris.org>
5 ;;; Copyright © 2015 Sou Bunnbu <iyzsong@gmail.com>
6 ;;; Copyright © 2016, 2017 Leo Famulari <leo@famulari.name>
7 ;;; Copyright © 2016 David Craven <david@craven.ch>
8 ;;; Copyright © 2016 Ricardo Wurmus <rekado@elephly.net>
9 ;;;
10 ;;; This file is part of GNU Guix.
11 ;;;
12 ;;; GNU Guix is free software; you can redistribute it and/or modify it
13 ;;; under the terms of the GNU General Public License as published by
14 ;;; the Free Software Foundation; either version 3 of the License, or (at
15 ;;; your option) any later version.
16 ;;;
17 ;;; GNU Guix is distributed in the hope that it will be useful, but
18 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
19 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
20 ;;; GNU General Public License for more details.
21 ;;;
22 ;;; You should have received a copy of the GNU General Public License
23 ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
25 (define-module (gnu services base)
26 #:use-module (guix store)
27 #:use-module (gnu services)
28 #:use-module (gnu services shepherd)
29 #:use-module (gnu services networking)
30 #:use-module (gnu system pam)
31 #:use-module (gnu system shadow) ; 'user-account', etc.
32 #:use-module (gnu system uuid)
33 #:use-module (gnu system file-systems) ; 'file-system', etc.
34 #:use-module (gnu system mapped-devices)
35 #:use-module ((gnu system linux-initrd)
36 #:select (file-system-packages))
37 #:use-module (gnu packages admin)
38 #:use-module ((gnu packages linux)
39 #:select (alsa-utils crda eudev e2fsprogs fuse gpm kbd lvm2 rng-tools))
40 #:use-module ((gnu packages base)
41 #:select (canonical-package glibc glibc-utf8-locales))
42 #:use-module (gnu packages bash)
43 #:use-module (gnu packages package-management)
44 #:use-module (gnu packages linux)
45 #:use-module (gnu packages terminals)
46 #:use-module ((gnu build file-systems)
47 #:select (mount-flags->bit-mask))
48 #:use-module (guix gexp)
49 #:use-module (guix records)
50 #:use-module (guix modules)
51 #:use-module (srfi srfi-1)
52 #:use-module (srfi srfi-26)
53 #:use-module (ice-9 match)
54 #:use-module (ice-9 format)
55 #:export (fstab-service-type
56 root-file-system-service
57 file-system-service-type
58 user-unmount-service
59 swap-service
60 user-processes-service
61 host-name-service
62 console-keymap-service
63 %default-console-font
64 console-font-service-type
65 console-font-service
67 udev-configuration
68 udev-configuration?
69 udev-configuration-rules
70 udev-service-type
71 udev-service
72 udev-rule
73 file->udev-rule
75 login-configuration
76 login-configuration?
77 login-service-type
78 login-service
80 agetty-configuration
81 agetty-configuration?
82 agetty-service
83 agetty-service-type
85 mingetty-configuration
86 mingetty-configuration?
87 mingetty-service
88 mingetty-service-type
90 %nscd-default-caches
91 %nscd-default-configuration
93 nscd-configuration
94 nscd-configuration?
96 nscd-cache
97 nscd-cache?
99 nscd-service-type
100 nscd-service
102 syslog-configuration
103 syslog-configuration?
104 syslog-service
105 syslog-service-type
106 %default-syslog.conf
108 %default-authorized-guix-keys
109 guix-configuration
110 guix-configuration?
112 guix-configuration-guix
113 guix-configuration-build-group
114 guix-configuration-build-accounts
115 guix-configuration-authorize-key?
116 guix-configuration-authorized-keys
117 guix-configuration-use-substitutes?
118 guix-configuration-substitute-urls
119 guix-configuration-extra-options
120 guix-configuration-log-file
122 guix-service
123 guix-service-type
124 guix-publish-configuration
125 guix-publish-configuration?
126 guix-publish-configuration-guix
127 guix-publish-configuration-port
128 guix-publish-configuration-host
129 guix-publish-configuration-compression-level
130 guix-publish-configuration-nar-path
131 guix-publish-configuration-cache
132 guix-publish-configuration-ttl
133 guix-publish-service
134 guix-publish-service-type
136 gpm-configuration
137 gpm-configuration?
138 gpm-service-type
139 gpm-service
141 urandom-seed-service-type
142 urandom-seed-service
144 rngd-configuration
145 rngd-configuration?
146 rngd-service-type
147 rngd-service
149 kmscon-configuration
150 kmscon-configuration?
151 kmscon-service-type
153 pam-limits-service-type
154 pam-limits-service
156 %base-services))
158 ;;; Commentary:
159 ;;;
160 ;;; Base system services---i.e., services that 99% of the users will want to
161 ;;; use.
162 ;;;
163 ;;; Code:
165 \f
166 ;;;
167 ;;; File systems.
168 ;;;
170 (define (file-system->fstab-entry file-system)
171 "Return a @file{/etc/fstab} entry for @var{file-system}."
172 (string-append (case (file-system-title file-system)
173 ((label)
174 (string-append "LABEL=" (file-system-device file-system)))
175 ((uuid)
176 (string-append
177 "UUID="
178 (uuid->string (file-system-device file-system))))
179 (else
180 (file-system-device file-system)))
181 "\t"
182 (file-system-mount-point file-system) "\t"
183 (file-system-type file-system) "\t"
184 (or (file-system-options file-system) "defaults") "\t"
186 ;; XXX: Omit the 'fs_freq' and 'fs_passno' fields because we
187 ;; don't have anything sensible to put in there.
188 ))
190 (define (file-systems->fstab file-systems)
191 "Return a @file{/etc} entry for an @file{fstab} describing
192 @var{file-systems}."
193 `(("fstab" ,(plain-file "fstab"
194 (string-append
195 "\
196 # This file was generated from your GuixSD configuration. Any changes
197 # will be lost upon reboot or reconfiguration.\n\n"
198 (string-join (map file-system->fstab-entry
199 file-systems)
200 "\n")
201 "\n")))))
203 (define fstab-service-type
204 ;; The /etc/fstab service.
205 (service-type (name 'fstab)
206 (extensions
207 (list (service-extension etc-service-type
208 file-systems->fstab)))
209 (compose concatenate)
210 (extend append)
211 (description
212 "Populate the @file{/etc/fstab} based on the given file
213 system objects.")))
215 (define %root-file-system-shepherd-service
216 (shepherd-service
217 (documentation "Take care of the root file system.")
218 (provision '(root-file-system))
219 (start #~(const #t))
220 (stop #~(lambda _
221 ;; Return #f if successfully stopped.
222 (sync)
224 (call-with-blocked-asyncs
225 (lambda ()
226 (let ((null (%make-void-port "w")))
227 ;; Close 'shepherd.log'.
228 (display "closing log\n")
229 ((@ (shepherd comm) stop-logging))
231 ;; Redirect the default output ports..
232 (set-current-output-port null)
233 (set-current-error-port null)
235 ;; Close /dev/console.
236 (for-each close-fdes '(0 1 2))
238 ;; At this point, there are no open files left, so the
239 ;; root file system can be re-mounted read-only.
240 (mount #f "/" #f
241 (logior MS_REMOUNT MS_RDONLY)
242 #:update-mtab? #f)
244 #f)))))
245 (respawn? #f)))
247 (define root-file-system-service-type
248 (shepherd-service-type 'root-file-system
249 (const %root-file-system-shepherd-service)))
251 (define (root-file-system-service)
252 "Return a service whose sole purpose is to re-mount read-only the root file
253 system upon shutdown (aka. cleanly \"umounting\" root.)
255 This service must be the root of the service dependency graph so that its
256 'stop' action is invoked when shepherd is the only process left."
257 (service root-file-system-service-type #f))
259 (define (file-system->shepherd-service-name file-system)
260 "Return the symbol that denotes the service mounting and unmounting
261 FILE-SYSTEM."
262 (symbol-append 'file-system-
263 (string->symbol (file-system-mount-point file-system))))
265 (define (mapped-device->shepherd-service-name md)
266 "Return the symbol that denotes the shepherd service of MD, a <mapped-device>."
267 (symbol-append 'device-mapping-
268 (string->symbol (mapped-device-target md))))
270 (define dependency->shepherd-service-name
271 (match-lambda
272 ((? mapped-device? md)
273 (mapped-device->shepherd-service-name md))
274 ((? file-system? fs)
275 (file-system->shepherd-service-name fs))))
277 (define (file-system-shepherd-service file-system)
278 "Return the shepherd service for @var{file-system}, or @code{#f} if
279 @var{file-system} is not auto-mounted upon boot."
280 (let ((target (file-system-mount-point file-system))
281 (create? (file-system-create-mount-point? file-system))
282 (dependencies (file-system-dependencies file-system))
283 (packages (file-system-packages (list file-system))))
284 (and (file-system-mount? file-system)
285 (with-imported-modules (source-module-closure
286 '((gnu build file-systems)))
287 (shepherd-service
288 (provision (list (file-system->shepherd-service-name file-system)))
289 (requirement `(root-file-system
290 ,@(map dependency->shepherd-service-name dependencies)))
291 (documentation "Check, mount, and unmount the given file system.")
292 (start #~(lambda args
293 #$(if create?
294 #~(mkdir-p #$target)
295 #t)
297 (let (($PATH (getenv "PATH")))
298 ;; Make sure fsck.ext2 & co. can be found.
299 (dynamic-wind
300 (lambda ()
301 ;; Don’t display the PATH settings.
302 (with-output-to-port (%make-void-port "w")
303 (lambda ()
304 (set-path-environment-variable "PATH"
305 '("bin" "sbin")
306 '#$packages))))
307 (lambda ()
308 (mount-file-system
309 (spec->file-system
310 '#$(file-system->spec file-system))
311 #:root "/"))
312 (lambda ()
313 (setenv "PATH" $PATH)))
314 #t)))
315 (stop #~(lambda args
316 ;; Normally there are no processes left at this point, so
317 ;; TARGET can be safely unmounted.
319 ;; Make sure PID 1 doesn't keep TARGET busy.
320 (chdir "/")
322 (umount #$target)
323 #f))
325 ;; We need additional modules.
326 (modules `(((gnu build file-systems)
327 #:select (mount-file-system))
328 (gnu system file-systems)
329 ,@%default-modules)))))))
331 (define (file-system-shepherd-services file-systems)
332 "Return the list of Shepherd services for FILE-SYSTEMS."
333 (let* ((file-systems (filter file-system-mount? file-systems)))
334 (define sink
335 (shepherd-service
336 (provision '(file-systems))
337 (requirement (cons* 'root-file-system 'user-file-systems
338 (map file-system->shepherd-service-name
339 file-systems)))
340 (documentation "Target for all the initially-mounted file systems")
341 (start #~(const #t))
342 (stop #~(const #f))))
344 (cons sink (map file-system-shepherd-service file-systems))))
346 (define file-system-service-type
347 (service-type (name 'file-systems)
348 (extensions
349 (list (service-extension shepherd-root-service-type
350 file-system-shepherd-services)
351 (service-extension fstab-service-type
352 identity)))
353 (compose concatenate)
354 (extend append)
355 (description
356 "Provide Shepherd services to mount and unmount the given
357 file systems, as well as corresponding @file{/etc/fstab} entries.")))
359 (define user-unmount-service-type
360 (shepherd-service-type
361 'user-file-systems
362 (lambda (known-mount-points)
363 (shepherd-service
364 (documentation "Unmount manually-mounted file systems.")
365 (provision '(user-file-systems))
366 (start #~(const #t))
367 (stop #~(lambda args
368 (define (known? mount-point)
369 (member mount-point
370 (cons* "/proc" "/sys" '#$known-mount-points)))
372 ;; Make sure we don't keep the user's mount points busy.
373 (chdir "/")
375 (for-each (lambda (mount-point)
376 (format #t "unmounting '~a'...~%" mount-point)
377 (catch 'system-error
378 (lambda ()
379 (umount mount-point))
380 (lambda args
381 (let ((errno (system-error-errno args)))
382 (format #t "failed to unmount '~a': ~a~%"
383 mount-point (strerror errno))))))
384 (filter (negate known?) (mount-points)))
385 #f))))))
387 (define (user-unmount-service known-mount-points)
388 "Return a service whose sole purpose is to unmount file systems not listed
389 in KNOWN-MOUNT-POINTS when it is stopped."
390 (service user-unmount-service-type known-mount-points))
392 (define %do-not-kill-file
393 ;; Name of the file listing PIDs of processes that must survive when halting
394 ;; the system. Typical example is user-space file systems.
395 "/etc/shepherd/do-not-kill")
397 (define user-processes-service-type
398 (shepherd-service-type
399 'user-processes
400 (lambda (grace-delay)
401 (shepherd-service
402 (documentation "When stopped, terminate all user processes.")
403 (provision '(user-processes))
404 (requirement '(file-systems))
405 (start #~(const #t))
406 (stop #~(lambda _
407 (define (kill-except omit signal)
408 ;; Kill all the processes with SIGNAL except those listed
409 ;; in OMIT and the current process.
410 (let ((omit (cons (getpid) omit)))
411 (for-each (lambda (pid)
412 (unless (memv pid omit)
413 (false-if-exception
414 (kill pid signal))))
415 (processes))))
417 (define omitted-pids
418 ;; List of PIDs that must not be killed.
419 (if (file-exists? #$%do-not-kill-file)
420 (map string->number
421 (call-with-input-file #$%do-not-kill-file
422 (compose string-tokenize
423 (@ (ice-9 rdelim) read-string))))
424 '()))
426 (define (now)
427 (car (gettimeofday)))
429 (define (sleep* n)
430 ;; Really sleep N seconds.
431 ;; Work around <http://bugs.gnu.org/19581>.
432 (define start (now))
433 (let loop ((elapsed 0))
434 (when (> n elapsed)
435 (sleep (- n elapsed))
436 (loop (- (now) start)))))
438 (define lset= (@ (srfi srfi-1) lset=))
440 (display "sending all processes the TERM signal\n")
442 (if (null? omitted-pids)
443 (begin
444 ;; Easy: terminate all of them.
445 (kill -1 SIGTERM)
446 (sleep* #$grace-delay)
447 (kill -1 SIGKILL))
448 (begin
449 ;; Kill them all except OMITTED-PIDS. XXX: We would
450 ;; like to (kill -1 SIGSTOP) to get a fixed list of
451 ;; processes, like 'killall5' does, but that seems
452 ;; unreliable.
453 (kill-except omitted-pids SIGTERM)
454 (sleep* #$grace-delay)
455 (kill-except omitted-pids SIGKILL)
456 (delete-file #$%do-not-kill-file)))
458 (let wait ()
459 ;; Reap children, if any, so that we don't end up with
460 ;; zombies and enter an infinite loop.
461 (let reap-children ()
462 (define result
463 (false-if-exception
464 (waitpid WAIT_ANY (if (null? omitted-pids)
465 0
466 WNOHANG))))
468 (when (and (pair? result)
469 (not (zero? (car result))))
470 (reap-children)))
472 (let ((pids (processes)))
473 (unless (lset= = pids (cons 1 omitted-pids))
474 (format #t "waiting for process termination\
475 (processes left: ~s)~%"
476 pids)
477 (sleep* 2)
478 (wait))))
480 (display "all processes have been terminated\n")
481 #f))
482 (respawn? #f)))))
484 (define* (user-processes-service #:key (grace-delay 4))
485 "Return the service that is responsible for terminating all the processes so
486 that the root file system can be re-mounted read-only, just before
487 rebooting/halting. Processes still running GRACE-DELAY seconds after SIGTERM
488 has been sent are terminated with SIGKILL.
490 The returned service will depend on 'file-systems', meaning that it is
491 considered started after all the auto-mount file systems have been mounted.
493 All the services that spawn processes must depend on this one so that they are
494 stopped before 'kill' is called."
495 (service user-processes-service-type grace-delay))
497 \f
498 ;;;
499 ;;; Preserve entropy to seed /dev/urandom on boot.
500 ;;;
502 (define %random-seed-file
503 "/var/lib/random-seed")
505 (define (urandom-seed-shepherd-service _)
506 "Return a shepherd service for the /dev/urandom seed."
507 (list (shepherd-service
508 (documentation "Preserve entropy across reboots for /dev/urandom.")
509 (provision '(urandom-seed))
510 (requirement '(user-processes))
511 (start #~(lambda _
512 ;; On boot, write random seed into /dev/urandom.
513 (when (file-exists? #$%random-seed-file)
514 (call-with-input-file #$%random-seed-file
515 (lambda (seed)
516 (call-with-output-file "/dev/urandom"
517 (lambda (urandom)
518 (dump-port seed urandom))))))
519 ;; Immediately refresh the seed in case the system doesn't
520 ;; shut down cleanly.
521 (call-with-input-file "/dev/urandom"
522 (lambda (urandom)
523 (let ((previous-umask (umask #o077))
524 (buf (make-bytevector 512)))
525 (mkdir-p (dirname #$%random-seed-file))
526 (get-bytevector-n! urandom buf 0 512)
527 (call-with-output-file #$%random-seed-file
528 (lambda (seed)
529 (put-bytevector seed buf)))
530 (umask previous-umask))))
531 #t))
532 (stop #~(lambda _
533 ;; During shutdown, write from /dev/urandom into random seed.
534 (let ((buf (make-bytevector 512)))
535 (call-with-input-file "/dev/urandom"
536 (lambda (urandom)
537 (let ((previous-umask (umask #o077)))
538 (get-bytevector-n! urandom buf 0 512)
539 (mkdir-p (dirname #$%random-seed-file))
540 (call-with-output-file #$%random-seed-file
541 (lambda (seed)
542 (put-bytevector seed buf)))
543 (umask previous-umask))
544 #t)))))
545 (modules `((rnrs bytevectors)
546 (rnrs io ports)
547 ,@%default-modules)))))
549 (define urandom-seed-service-type
550 (service-type (name 'urandom-seed)
551 (extensions
552 (list (service-extension shepherd-root-service-type
553 urandom-seed-shepherd-service)))
554 (description
555 "Seed the @file{/dev/urandom} pseudo-random number
556 generator (RNG) with the value recorded when the system was last shut
557 down.")))
559 (define (urandom-seed-service)
560 (service urandom-seed-service-type #f))
563 ;;;
564 ;;; Add hardware random number generator to entropy pool.
565 ;;;
567 (define-record-type* <rngd-configuration>
568 rngd-configuration make-rngd-configuration
569 rngd-configuration?
570 (rng-tools rngd-configuration-rng-tools) ;package
571 (device rngd-configuration-device)) ;string
573 (define rngd-service-type
574 (shepherd-service-type
575 'rngd
576 (lambda (config)
577 (define rng-tools (rngd-configuration-rng-tools config))
578 (define device (rngd-configuration-device config))
580 (define rngd-command
581 (list (file-append rng-tools "/sbin/rngd")
582 "-f" "-r" device))
584 (shepherd-service
585 (documentation "Add TRNG to entropy pool.")
586 (requirement '(udev))
587 (provision '(trng))
588 (start #~(make-forkexec-constructor #$@rngd-command))
589 (stop #~(make-kill-destructor))))))
591 (define* (rngd-service #:key
592 (rng-tools rng-tools)
593 (device "/dev/hwrng"))
594 "Return a service that runs the @command{rngd} program from @var{rng-tools}
595 to add @var{device} to the kernel's entropy pool. The service will fail if
596 @var{device} does not exist."
597 (service rngd-service-type
598 (rngd-configuration
599 (rng-tools rng-tools)
600 (device device))))
602 \f
603 ;;;
604 ;;; Console & co.
605 ;;;
607 (define host-name-service-type
608 (shepherd-service-type
609 'host-name
610 (lambda (name)
611 (shepherd-service
612 (documentation "Initialize the machine's host name.")
613 (provision '(host-name))
614 (start #~(lambda _
615 (sethostname #$name)))
616 (respawn? #f)))))
618 (define (host-name-service name)
619 "Return a service that sets the host name to @var{name}."
620 (service host-name-service-type name))
622 (define (unicode-start tty)
623 "Return a gexp to start Unicode support on @var{tty}."
625 ;; We have to run 'unicode_start' in a pipe so that when it invokes the
626 ;; 'tty' command, that command returns TTY.
627 #~(begin
628 (let ((pid (primitive-fork)))
629 (case pid
630 ((0)
631 (close-fdes 0)
632 (dup2 (open-fdes #$tty O_RDONLY) 0)
633 (close-fdes 1)
634 (dup2 (open-fdes #$tty O_WRONLY) 1)
635 (execl #$(file-append kbd "/bin/unicode_start")
636 "unicode_start"))
637 (else
638 (zero? (cdr (waitpid pid))))))))
640 (define console-keymap-service-type
641 (shepherd-service-type
642 'console-keymap
643 (lambda (files)
644 (shepherd-service
645 (documentation (string-append "Load console keymap (loadkeys)."))
646 (provision '(console-keymap))
647 (start #~(lambda _
648 (zero? (system* #$(file-append kbd "/bin/loadkeys")
649 #$@files))))
650 (respawn? #f)))))
652 (define (console-keymap-service . files)
653 "Return a service to load console keymaps from @var{files}."
654 (service console-keymap-service-type files))
656 (define %default-console-font
657 ;; Note: 'LatGrkCyr-8x16' has the advantage of providing three common
658 ;; scripts as well as glyphs for em dash, quotation marks, and other Unicode
659 ;; codepoints notably found in the UTF-8 manual.
660 "LatGrkCyr-8x16")
662 (define (console-font-shepherd-services tty+font)
663 "Return a list of Shepherd services for each pair in TTY+FONT."
664 (map (match-lambda
665 ((tty . font)
666 (let ((device (string-append "/dev/" tty)))
667 (shepherd-service
668 (documentation "Load a Unicode console font.")
669 (provision (list (symbol-append 'console-font-
670 (string->symbol tty))))
672 ;; Start after mingetty has been started on TTY, otherwise the settings
673 ;; are ignored.
674 (requirement (list (symbol-append 'term-
675 (string->symbol tty))))
677 (start #~(lambda _
678 (and #$(unicode-start device)
679 (zero?
680 (system* #$(file-append kbd "/bin/setfont")
681 "-C" #$device #$font)))))
682 (stop #~(const #t))
683 (respawn? #f)))))
684 tty+font))
686 (define console-font-service-type
687 (service-type (name 'console-fonts)
688 (extensions
689 (list (service-extension shepherd-root-service-type
690 console-font-shepherd-services)))
691 (compose concatenate)
692 (extend append)
693 (description
694 "Install the given fonts on the specified ttys (fonts are per
695 virtual console on GNU/Linux). The value of this service is a list of
696 tty/font pairs like:
698 @example
699 '((\"tty1\" . \"LatGrkCyr-8x16\"))
700 @end example\n")))
702 (define* (console-font-service tty #:optional (font "LatGrkCyr-8x16"))
703 "This procedure is deprecated in favor of @code{console-font-service-type}.
705 Return a service that sets up Unicode support in @var{tty} and loads
706 @var{font} for that tty (fonts are per virtual console in Linux.)"
707 (simple-service (symbol-append 'console-font- (string->symbol tty))
708 console-font-service-type `((,tty . ,font))))
710 (define %default-motd
711 (plain-file "motd" "This is the GNU operating system, welcome!\n\n"))
713 (define-record-type* <login-configuration>
714 login-configuration make-login-configuration
715 login-configuration?
716 (motd login-configuration-motd ;file-like
717 (default %default-motd))
718 ;; Allow empty passwords by default so that first-time users can log in when
719 ;; the 'root' account has just been created.
720 (allow-empty-passwords? login-configuration-allow-empty-passwords?
721 (default #t))) ;Boolean
723 (define (login-pam-service config)
724 "Return the list of PAM service needed for CONF."
725 ;; Let 'login' be known to PAM.
726 (list (unix-pam-service "login"
727 #:allow-empty-passwords?
728 (login-configuration-allow-empty-passwords? config)
729 #:motd
730 (login-configuration-motd config))))
732 (define login-service-type
733 (service-type (name 'login)
734 (extensions (list (service-extension pam-root-service-type
735 login-pam-service)))
736 (description
737 "Provide a console log-in service as specified by its
738 configuration value, a @code{login-configuration} object.")))
740 (define* (login-service #:optional (config (login-configuration)))
741 "Return a service configure login according to @var{config}, which specifies
742 the message of the day, among other things."
743 (service login-service-type config))
745 (define-record-type* <agetty-configuration>
746 agetty-configuration make-agetty-configuration
747 agetty-configuration?
748 (agetty agetty-configuration-agetty ;<package>
749 (default util-linux))
750 (tty agetty-configuration-tty) ;string
751 (term agetty-term ;string | #f
752 (default #f))
753 (baud-rate agetty-baud-rate ;string | #f
754 (default #f))
755 (auto-login agetty-auto-login ;list of strings | #f
756 (default #f))
757 (login-program agetty-login-program ;gexp
758 (default (file-append shadow "/bin/login")))
759 (login-pause? agetty-login-pause? ;Boolean
760 (default #f))
761 (eight-bits? agetty-eight-bits? ;Boolean
762 (default #f))
763 (no-reset? agetty-no-reset? ;Boolean
764 (default #f))
765 (remote? agetty-remote? ;Boolean
766 (default #f))
767 (flow-control? agetty-flow-control? ;Boolean
768 (default #f))
769 (host agetty-host ;string | #f
770 (default #f))
771 (no-issue? agetty-no-issue? ;Boolean
772 (default #f))
773 (init-string agetty-init-string ;string | #f
774 (default #f))
775 (no-clear? agetty-no-clear? ;Boolean
776 (default #f))
777 (local-line agetty-local-line ;always | never | auto
778 (default #f))
779 (extract-baud? agetty-extract-baud? ;Boolean
780 (default #f))
781 (skip-login? agetty-skip-login? ;Boolean
782 (default #f))
783 (no-newline? agetty-no-newline? ;Boolean
784 (default #f))
785 (login-options agetty-login-options ;string | #f
786 (default #f))
787 (chroot agetty-chroot ;string | #f
788 (default #f))
789 (hangup? agetty-hangup? ;Boolean
790 (default #f))
791 (keep-baud? agetty-keep-baud? ;Boolean
792 (default #f))
793 (timeout agetty-timeout ;integer | #f
794 (default #f))
795 (detect-case? agetty-detect-case? ;Boolean
796 (default #f))
797 (wait-cr? agetty-wait-cr? ;Boolean
798 (default #f))
799 (no-hints? agetty-no-hints? ;Boolean
800 (default #f))
801 (no-hostname? agetty-no hostname? ;Boolean
802 (default #f))
803 (long-hostname? agetty-long-hostname? ;Boolean
804 (default #f))
805 (erase-characters agetty-erase-characters ;string | #f
806 (default #f))
807 (kill-characters agetty-kill-characters ;string | #f
808 (default #f))
809 (chdir agetty-chdir ;string | #f
810 (default #f))
811 (delay agetty-delay ;integer | #f
812 (default #f))
813 (nice agetty-nice ;integer | #f
814 (default #f))
815 ;; "Escape hatch" for passing arbitrary command-line arguments.
816 (extra-options agetty-extra-options ;list of strings
817 (default '()))
818 ;;; XXX Unimplemented for now!
819 ;;; (issue-file agetty-issue-file ;file-like
820 ;;; (default #f))
821 )
823 (define agetty-shepherd-service
824 (match-lambda
825 (($ <agetty-configuration> agetty tty term baud-rate auto-login
826 login-program login-pause? eight-bits? no-reset? remote? flow-control?
827 host no-issue? init-string no-clear? local-line extract-baud?
828 skip-login? no-newline? login-options chroot hangup? keep-baud? timeout
829 detect-case? wait-cr? no-hints? no-hostname? long-hostname?
830 erase-characters kill-characters chdir delay nice extra-options)
831 (list
832 (shepherd-service
833 (documentation "Run agetty on a tty.")
834 (provision (list (symbol-append 'term- (string->symbol tty))))
836 ;; Since the login prompt shows the host name, wait for the 'host-name'
837 ;; service to be done. Also wait for udev essentially so that the tty
838 ;; text is not lost in the middle of kernel messages (see also
839 ;; mingetty-shepherd-service).
840 (requirement '(user-processes host-name udev))
842 (start #~(make-forkexec-constructor
843 (list #$(file-append util-linux "/sbin/agetty")
844 #$@extra-options
845 #$@(if eight-bits?
846 #~("--8bits")
847 #~())
848 #$@(if no-reset?
849 #~("--noreset")
850 #~())
851 #$@(if remote?
852 #~("--remote")
853 #~())
854 #$@(if flow-control?
855 #~("--flow-control")
856 #~())
857 #$@(if host
858 #~("--host" #$host)
859 #~())
860 #$@(if no-issue?
861 #~("--noissue")
862 #~())
863 #$@(if init-string
864 #~("--init-string" #$init-string)
865 #~())
866 #$@(if no-clear?
867 #~("--noclear")
868 #~())
869 ;;; FIXME This doesn't work as expected. According to agetty(8), if this option
870 ;;; is not passed, then the default is 'auto'. However, in my tests, when that
871 ;;; option is selected, agetty never presents the login prompt, and the
872 ;;; term-ttyS0 service respawns every few seconds.
873 #$@(if local-line
874 #~(#$(match local-line
875 ('auto "--local-line=auto")
876 ('always "--local-line=always")
877 ('never "-local-line=never")))
878 #~())
879 #$@(if extract-baud?
880 #~("--extract-baud")
881 #~())
882 #$@(if skip-login?
883 #~("--skip-login")
884 #~())
885 #$@(if no-newline?
886 #~("--nonewline")
887 #~())
888 #$@(if login-options
889 #~("--login-options" #$login-options)
890 #~())
891 #$@(if chroot
892 #~("--chroot" #$chroot)
893 #~())
894 #$@(if hangup?
895 #~("--hangup")
896 #~())
897 #$@(if keep-baud?
898 #~("--keep-baud")
899 #~())
900 #$@(if timeout
901 #~("--timeout" #$(number->string timeout))
902 #~())
903 #$@(if detect-case?
904 #~("--detect-case")
905 #~())
906 #$@(if wait-cr?
907 #~("--wait-cr")
908 #~())
909 #$@(if no-hints?
910 #~("--nohints?")
911 #~())
912 #$@(if no-hostname?
913 #~("--nohostname")
914 #~())
915 #$@(if long-hostname?
916 #~("--long-hostname")
917 #~())
918 #$@(if erase-characters
919 #~("--erase-chars" #$erase-characters)
920 #~())
921 #$@(if kill-characters
922 #~("--kill-chars" #$kill-characters)
923 #~())
924 #$@(if chdir
925 #~("--chdir" #$chdir)
926 #~())
927 #$@(if delay
928 #~("--delay" #$(number->string delay))
929 #~())
930 #$@(if nice
931 #~("--nice" #$(number->string nice))
932 #~())
933 #$@(if auto-login
934 (list "--autologin" auto-login)
935 '())
936 #$@(if login-program
937 #~("--login-program" #$login-program)
938 #~())
939 #$@(if login-pause?
940 #~("--login-pause")
941 #~())
942 #$tty
943 #$@(if baud-rate
944 #~(#$baud-rate)
945 #~())
946 #$@(if term
947 #~(#$term)
948 #~()))))
949 (stop #~(make-kill-destructor)))))))
951 (define agetty-service-type
952 (service-type (name 'agetty)
953 (extensions (list (service-extension shepherd-root-service-type
954 agetty-shepherd-service)))
955 (description
956 "Provide console login using the @command{agetty}
957 program.")))
959 (define* (agetty-service config)
960 "Return a service to run agetty according to @var{config}, which specifies
961 the tty to run, among other things."
962 (service agetty-service-type config))
964 (define-record-type* <mingetty-configuration>
965 mingetty-configuration make-mingetty-configuration
966 mingetty-configuration?
967 (mingetty mingetty-configuration-mingetty ;<package>
968 (default mingetty))
969 (tty mingetty-configuration-tty) ;string
970 (auto-login mingetty-auto-login ;string | #f
971 (default #f))
972 (login-program mingetty-login-program ;gexp
973 (default #f))
974 (login-pause? mingetty-login-pause? ;Boolean
975 (default #f)))
977 (define mingetty-shepherd-service
978 (match-lambda
979 (($ <mingetty-configuration> mingetty tty auto-login login-program
980 login-pause?)
981 (list
982 (shepherd-service
983 (documentation "Run mingetty on an tty.")
984 (provision (list (symbol-append 'term- (string->symbol tty))))
986 ;; Since the login prompt shows the host name, wait for the 'host-name'
987 ;; service to be done. Also wait for udev essentially so that the tty
988 ;; text is not lost in the middle of kernel messages (XXX).
989 (requirement '(user-processes host-name udev))
991 (start #~(make-forkexec-constructor
992 (list #$(file-append mingetty "/sbin/mingetty")
993 "--noclear" #$tty
994 #$@(if auto-login
995 #~("--autologin" #$auto-login)
996 #~())
997 #$@(if login-program
998 #~("--loginprog" #$login-program)
999 #~())
1000 #$@(if login-pause?
1001 #~("--loginpause")
1002 #~()))))
1003 (stop #~(make-kill-destructor)))))))
1005 (define mingetty-service-type
1006 (service-type (name 'mingetty)
1007 (extensions (list (service-extension shepherd-root-service-type
1008 mingetty-shepherd-service)))
1009 (description
1010 "Provide console login using the @command{mingetty}
1011 program.")))
1013 (define* (mingetty-service config)
1014 "Return a service to run mingetty according to @var{config}, which specifies
1015 the tty to run, among other things."
1016 (service mingetty-service-type config))
1018 (define-record-type* <nscd-configuration> nscd-configuration
1019 make-nscd-configuration
1020 nscd-configuration?
1021 (log-file nscd-configuration-log-file ;string
1022 (default "/var/log/nscd.log"))
1023 (debug-level nscd-debug-level ;integer
1024 (default 0))
1025 ;; TODO: See nscd.conf in glibc for other options to add.
1026 (caches nscd-configuration-caches ;list of <nscd-cache>
1027 (default %nscd-default-caches))
1028 (name-services nscd-configuration-name-services ;list of <packages>
1029 (default '()))
1030 (glibc nscd-configuration-glibc ;<package>
1031 (default (canonical-package glibc))))
1033 (define-record-type* <nscd-cache> nscd-cache make-nscd-cache
1034 nscd-cache?
1035 (database nscd-cache-database) ;symbol
1036 (positive-time-to-live nscd-cache-positive-time-to-live) ;integer
1037 (negative-time-to-live nscd-cache-negative-time-to-live
1038 (default 20)) ;integer
1039 (suggested-size nscd-cache-suggested-size ;integer ("default module
1040 ;of hash table")
1041 (default 211))
1042 (check-files? nscd-cache-check-files? ;Boolean
1043 (default #t))
1044 (persistent? nscd-cache-persistent? ;Boolean
1045 (default #t))
1046 (shared? nscd-cache-shared? ;Boolean
1047 (default #t))
1048 (max-database-size nscd-cache-max-database-size ;integer
1049 (default (* 32 (expt 2 20))))
1050 (auto-propagate? nscd-cache-auto-propagate? ;Boolean
1051 (default #t)))
1053 (define %nscd-default-caches
1054 ;; Caches that we want to enable by default. Note that when providing an
1055 ;; empty nscd.conf, all caches are disabled.
1056 (list (nscd-cache (database 'hosts)
1058 ;; Aggressively cache the host name cache to improve
1059 ;; privacy and resilience.
1060 (positive-time-to-live (* 3600 12))
1061 (negative-time-to-live 20)
1062 (persistent? #t))
1064 (nscd-cache (database 'services)
1066 ;; Services are unlikely to change, so we can be even more
1067 ;; aggressive.
1068 (positive-time-to-live (* 3600 24))
1069 (negative-time-to-live 3600)
1070 (check-files? #t) ;check /etc/services changes
1071 (persistent? #t))))
1073 (define %nscd-default-configuration
1074 ;; Default nscd configuration.
1075 (nscd-configuration))
1077 (define (nscd.conf-file config)
1078 "Return the @file{nscd.conf} configuration file for @var{config}, an
1079 @code{<nscd-configuration>} object."
1080 (define cache->config
1081 (match-lambda
1082 (($ <nscd-cache> (= symbol->string database)
1083 positive-ttl negative-ttl size check-files?
1084 persistent? shared? max-size propagate?)
1085 (string-append "\nenable-cache\t" database "\tyes\n"
1087 "positive-time-to-live\t" database "\t"
1088 (number->string positive-ttl) "\n"
1089 "negative-time-to-live\t" database "\t"
1090 (number->string negative-ttl) "\n"
1091 "suggested-size\t" database "\t"
1092 (number->string size) "\n"
1093 "check-files\t" database "\t"
1094 (if check-files? "yes\n" "no\n")
1095 "persistent\t" database "\t"
1096 (if persistent? "yes\n" "no\n")
1097 "shared\t" database "\t"
1098 (if shared? "yes\n" "no\n")
1099 "max-db-size\t" database "\t"
1100 (number->string max-size) "\n"
1101 "auto-propagate\t" database "\t"
1102 (if propagate? "yes\n" "no\n")))))
1104 (match config
1105 (($ <nscd-configuration> log-file debug-level caches)
1106 (plain-file "nscd.conf"
1107 (string-append "\
1108 # Configuration of libc's name service cache daemon (nscd).\n\n"
1109 (if log-file
1110 (string-append "logfile\t" log-file)
1111 "")
1112 "\n"
1113 (if debug-level
1114 (string-append "debug-level\t"
1115 (number->string debug-level))
1116 "")
1117 "\n"
1118 (string-concatenate
1119 (map cache->config caches)))))))
1121 (define (nscd-shepherd-service config)
1122 "Return a shepherd service for CONFIG, an <nscd-configuration> object."
1123 (let ((nscd.conf (nscd.conf-file config))
1124 (name-services (nscd-configuration-name-services config)))
1125 (list (shepherd-service
1126 (documentation "Run libc's name service cache daemon (nscd).")
1127 (provision '(nscd))
1128 (requirement '(user-processes))
1129 (start #~(make-forkexec-constructor
1130 (list #$(file-append (nscd-configuration-glibc config)
1131 "/sbin/nscd")
1132 "-f" #$nscd.conf "--foreground")
1134 ;; Wait for the PID file. However, the PID file is
1135 ;; written before nscd is actually listening on its
1136 ;; socket (XXX).
1137 #:pid-file "/var/run/nscd/nscd.pid"
1139 #:environment-variables
1140 (list (string-append "LD_LIBRARY_PATH="
1141 (string-join
1142 (map (lambda (dir)
1143 (string-append dir "/lib"))
1144 (list #$@name-services))
1145 ":")))))
1146 (stop #~(make-kill-destructor))))))
1148 (define nscd-activation
1149 ;; Actions to take before starting nscd.
1150 #~(begin
1151 (use-modules (guix build utils))
1152 (mkdir-p "/var/run/nscd")
1153 (mkdir-p "/var/db/nscd") ;for the persistent cache
1155 ;; In libc 2.25 nscd uses inotify to watch /etc/resolv.conf, but only if
1156 ;; that file exists when it is started. Thus create it here. Note: on
1157 ;; some systems, such as when NetworkManager is used, /etc/resolv.conf
1158 ;; is a symlink, hence 'lstat'.
1159 (unless (false-if-exception (lstat "/etc/resolv.conf"))
1160 (call-with-output-file "/etc/resolv.conf"
1161 (lambda (port)
1162 (display "# This is a placeholder.\n" port))))))
1164 (define nscd-service-type
1165 (service-type (name 'nscd)
1166 (extensions
1167 (list (service-extension activation-service-type
1168 (const nscd-activation))
1169 (service-extension shepherd-root-service-type
1170 nscd-shepherd-service)))
1172 ;; This can be extended by providing additional name services
1173 ;; such as nss-mdns.
1174 (compose concatenate)
1175 (extend (lambda (config name-services)
1176 (nscd-configuration
1177 (inherit config)
1178 (name-services (append
1179 (nscd-configuration-name-services config)
1180 name-services)))))
1181 (description
1182 "Runs libc's @dfn{name service cache daemon} (nscd) with the
1183 given configuration---an @code{<nscd-configuration>} object. @xref{Name
1184 Service Switch}, for an example.")))
1186 (define* (nscd-service #:optional (config %nscd-default-configuration))
1187 "Return a service that runs libc's name service cache daemon (nscd) with the
1188 given @var{config}---an @code{<nscd-configuration>} object. @xref{Name
1189 Service Switch}, for an example."
1190 (service nscd-service-type config))
1193 (define-record-type* <syslog-configuration>
1194 syslog-configuration make-syslog-configuration
1195 syslog-configuration?
1196 (syslogd syslog-configuration-syslogd
1197 (default (file-append inetutils "/libexec/syslogd")))
1198 (config-file syslog-configuration-config-file
1199 (default %default-syslog.conf)))
1201 (define syslog-service-type
1202 (shepherd-service-type
1203 'syslog
1204 (lambda (config)
1205 (shepherd-service
1206 (documentation "Run the syslog daemon (syslogd).")
1207 (provision '(syslogd))
1208 (requirement '(user-processes))
1209 (start #~(make-forkexec-constructor
1210 (list #$(syslog-configuration-syslogd config)
1211 "--rcfile" #$(syslog-configuration-config-file config))
1212 #:pid-file "/var/run/syslog.pid"))
1213 (stop #~(make-kill-destructor))))))
1215 ;; Snippet adapted from the GNU inetutils manual.
1216 (define %default-syslog.conf
1217 (plain-file "syslog.conf" "
1218 # Log all error messages, authentication messages of
1219 # level notice or higher and anything of level err or
1220 # higher to the console.
1221 # Don't log private authentication messages!
1222 *.alert;auth.notice;authpriv.none /dev/console
1224 # Log anything (except mail) of level info or higher.
1225 # Don't log private authentication messages!
1226 *.info;mail.none;authpriv.none /var/log/messages
1228 # Like /var/log/messages, but also including \"debug\"-level logs.
1229 *.debug;mail.none;authpriv.none /var/log/debug
1231 # Same, in a different place.
1232 *.info;mail.none;authpriv.none /dev/tty12
1234 # The authpriv file has restricted access.
1235 authpriv.* /var/log/secure
1237 # Log all the mail messages in one place.
1238 mail.* /var/log/maillog
1239 "))
1241 (define* (syslog-service #:optional (config (syslog-configuration)))
1242 "Return a service that runs @command{syslogd} and takes
1243 @var{<syslog-configuration>} as a parameter.
1245 @xref{syslogd invocation,,, inetutils, GNU Inetutils}, for more
1246 information on the configuration file syntax."
1247 (service syslog-service-type config))
1250 (define pam-limits-service-type
1251 (let ((security-limits
1252 ;; Create /etc/security containing the provided "limits.conf" file.
1253 (lambda (limits-file)
1254 `(("security"
1255 ,(computed-file
1256 "security"
1257 #~(begin
1258 (mkdir #$output)
1259 (stat #$limits-file)
1260 (symlink #$limits-file
1261 (string-append #$output "/limits.conf"))))))))
1262 (pam-extension
1263 (lambda (pam)
1264 (let ((pam-limits (pam-entry
1265 (control "required")
1266 (module "pam_limits.so")
1267 (arguments '("conf=/etc/security/limits.conf")))))
1268 (if (member (pam-service-name pam)
1269 '("login" "su" "slim"))
1270 (pam-service
1271 (inherit pam)
1272 (session (cons pam-limits
1273 (pam-service-session pam))))
1274 pam)))))
1275 (service-type
1276 (name 'limits)
1277 (extensions
1278 (list (service-extension etc-service-type security-limits)
1279 (service-extension pam-root-service-type
1280 (lambda _ (list pam-extension)))))
1281 (description
1282 "Install the specified resource usage limits by populating
1283 @file{/etc/security/limits.conf} and using the @code{pam_limits}
1284 authentication module."))))
1286 (define* (pam-limits-service #:optional (limits '()))
1287 "Return a service that makes selected programs respect the list of
1288 pam-limits-entry specified in LIMITS via pam_limits.so."
1289 (service pam-limits-service-type
1290 (plain-file "limits.conf"
1291 (string-join (map pam-limits-entry->string limits)
1292 "\n"))))
1294 \f
1295 ;;;
1296 ;;; Guix services.
1297 ;;;
1299 (define* (guix-build-accounts count #:key
1300 (group "guixbuild")
1301 (first-uid 30001)
1302 (shadow shadow))
1303 "Return a list of COUNT user accounts for Guix build users, with UIDs
1304 starting at FIRST-UID, and under GID."
1305 (unfold (cut > <> count)
1306 (lambda (n)
1307 (user-account
1308 (name (format #f "guixbuilder~2,'0d" n))
1309 (system? #t)
1310 (uid (+ first-uid n -1))
1311 (group group)
1313 ;; guix-daemon expects GROUP to be listed as a
1314 ;; supplementary group too:
1315 ;; <http://lists.gnu.org/archive/html/bug-guix/2013-01/msg00239.html>.
1316 (supplementary-groups (list group "kvm"))
1318 (comment (format #f "Guix Build User ~2d" n))
1319 (home-directory "/var/empty")
1320 (shell (file-append shadow "/sbin/nologin"))))
1321 1+
1322 1))
1324 (define (hydra-key-authorization key guix)
1325 "Return a gexp with code to register KEY, a file containing a 'guix archive'
1326 public key, with GUIX."
1327 #~(unless (file-exists? "/etc/guix/acl")
1328 (let ((pid (primitive-fork)))
1329 (case pid
1330 ((0)
1331 (let* ((key #$key)
1332 (port (open-file key "r0b")))
1333 (format #t "registering public key '~a'...~%" key)
1334 (close-port (current-input-port))
1335 (dup port 0)
1336 (execl #$(file-append guix "/bin/guix")
1337 "guix" "archive" "--authorize")
1338 (exit 1)))
1339 (else
1340 (let ((status (cdr (waitpid pid))))
1341 (unless (zero? status)
1342 (format (current-error-port) "warning: \
1343 failed to register hydra.gnu.org public key: ~a~%" status))))))))
1345 (define %default-authorized-guix-keys
1346 ;; List of authorized substitute keys.
1347 (list (file-append guix "/share/guix/hydra.gnu.org.pub")
1348 (file-append guix "/share/guix/berlin.guixsd.org.pub")))
1350 (define-record-type* <guix-configuration>
1351 guix-configuration make-guix-configuration
1352 guix-configuration?
1353 (guix guix-configuration-guix ;<package>
1354 (default guix))
1355 (build-group guix-configuration-build-group ;string
1356 (default "guixbuild"))
1357 (build-accounts guix-configuration-build-accounts ;integer
1358 (default 10))
1359 (authorize-key? guix-configuration-authorize-key? ;Boolean
1360 (default #t))
1361 (authorized-keys guix-configuration-authorized-keys ;list of gexps
1362 (default %default-authorized-guix-keys))
1363 (use-substitutes? guix-configuration-use-substitutes? ;Boolean
1364 (default #t))
1365 (substitute-urls guix-configuration-substitute-urls ;list of strings
1366 (default %default-substitute-urls))
1367 (max-silent-time guix-configuration-max-silent-time ;integer
1368 (default 0))
1369 (timeout guix-configuration-timeout ;integer
1370 (default 0))
1371 (extra-options guix-configuration-extra-options ;list of strings
1372 (default '()))
1373 (log-file guix-configuration-log-file ;string
1374 (default "/var/log/guix-daemon.log"))
1375 (http-proxy guix-http-proxy ;string | #f
1376 (default #f))
1377 (tmpdir guix-tmpdir ;string | #f
1378 (default #f)))
1380 (define %default-guix-configuration
1381 (guix-configuration))
1383 (define (guix-shepherd-service config)
1384 "Return a <shepherd-service> for the Guix daemon service with CONFIG."
1385 (match config
1386 (($ <guix-configuration> guix build-group build-accounts
1387 authorize-key? keys
1388 use-substitutes? substitute-urls
1389 max-silent-time timeout
1390 extra-options
1391 log-file http-proxy tmpdir)
1392 (list (shepherd-service
1393 (documentation "Run the Guix daemon.")
1394 (provision '(guix-daemon))
1395 (requirement '(user-processes))
1396 (start
1397 #~(make-forkexec-constructor
1398 (list #$(file-append guix "/bin/guix-daemon")
1399 "--build-users-group" #$build-group
1400 "--max-silent-time" #$(number->string max-silent-time)
1401 "--timeout" #$(number->string timeout)
1402 #$@(if use-substitutes?
1403 '()
1404 '("--no-substitutes"))
1405 "--substitute-urls" #$(string-join substitute-urls)
1406 #$@extra-options)
1408 #:environment-variables
1409 (list #$@(if http-proxy
1410 (list (string-append "http_proxy=" http-proxy))
1411 '())
1412 #$@(if tmpdir
1413 (list (string-append "TMPDIR=" tmpdir))
1414 '()))
1416 #:log-file #$log-file))
1417 (stop #~(make-kill-destructor)))))))
1419 (define (guix-accounts config)
1420 "Return the user accounts and user groups for CONFIG."
1421 (match config
1422 (($ <guix-configuration> _ build-group build-accounts)
1423 (cons (user-group
1424 (name build-group)
1425 (system? #t)
1427 ;; Use a fixed GID so that we can create the store with the right
1428 ;; owner.
1429 (id 30000))
1430 (guix-build-accounts build-accounts
1431 #:group build-group)))))
1433 (define (guix-activation config)
1434 "Return the activation gexp for CONFIG."
1435 (match config
1436 (($ <guix-configuration> guix build-group build-accounts authorize-key? keys)
1437 ;; Assume that the store has BUILD-GROUP as its group. We could
1438 ;; otherwise call 'chown' here, but the problem is that on a COW overlayfs,
1439 ;; chown leads to an entire copy of the tree, which is a bad idea.
1441 ;; Optionally authorize hydra.gnu.org's key.
1442 (if authorize-key?
1443 #~(begin
1444 #$@(map (cut hydra-key-authorization <> guix) keys))
1445 #~#f))))
1447 (define guix-service-type
1448 (service-type
1449 (name 'guix)
1450 (extensions
1451 (list (service-extension shepherd-root-service-type guix-shepherd-service)
1452 (service-extension account-service-type guix-accounts)
1453 (service-extension activation-service-type guix-activation)
1454 (service-extension profile-service-type
1455 (compose list guix-configuration-guix))))
1456 (default-value (guix-configuration))
1457 (description
1458 "Run the build daemon of GNU@tie{}Guix, aka. @command{guix-daemon}.")))
1460 (define* (guix-service #:optional (config %default-guix-configuration))
1461 "Return a service that runs the Guix build daemon according to
1462 @var{config}."
1463 (service guix-service-type config))
1466 (define-record-type* <guix-publish-configuration>
1467 guix-publish-configuration make-guix-publish-configuration
1468 guix-publish-configuration?
1469 (guix guix-publish-configuration-guix ;package
1470 (default guix))
1471 (port guix-publish-configuration-port ;number
1472 (default 80))
1473 (host guix-publish-configuration-host ;string
1474 (default "localhost"))
1475 (compression-level guix-publish-configuration-compression-level ;integer
1476 (default 3))
1477 (nar-path guix-publish-configuration-nar-path ;string
1478 (default "nar"))
1479 (cache guix-publish-configuration-cache ;#f | string
1480 (default #f))
1481 (workers guix-publish-configuration-workers ;#f | integer
1482 (default #f))
1483 (ttl guix-publish-configuration-ttl ;#f | integer
1484 (default #f)))
1486 (define guix-publish-shepherd-service
1487 (match-lambda
1488 (($ <guix-publish-configuration> guix port host compression
1489 nar-path cache workers ttl)
1490 (list (shepherd-service
1491 (provision '(guix-publish))
1492 (requirement '(guix-daemon))
1493 (start #~(make-forkexec-constructor
1494 (list #$(file-append guix "/bin/guix")
1495 "publish" "-u" "guix-publish"
1496 "-p" #$(number->string port)
1497 "-C" #$(number->string compression)
1498 (string-append "--nar-path=" #$nar-path)
1499 (string-append "--listen=" #$host)
1500 #$@(if workers
1501 #~((string-append "--workers="
1502 #$(number->string
1503 workers)))
1504 #~())
1505 #$@(if ttl
1506 #~((string-append "--ttl="
1507 #$(number->string ttl)
1508 "s"))
1509 #~())
1510 #$@(if cache
1511 #~((string-append "--cache=" #$cache))
1512 #~()))
1514 ;; Make sure we run in a UTF-8 locale so we can produce
1515 ;; nars for packages that contain UTF-8 file names such
1516 ;; as 'nss-certs'. See <https://bugs.gnu.org/26948>.
1517 #:environment-variables
1518 (list (string-append "GUIX_LOCPATH="
1519 #$glibc-utf8-locales "/lib/locale")
1520 "LC_ALL=en_US.utf8")))
1521 (stop #~(make-kill-destructor)))))))
1523 (define %guix-publish-accounts
1524 (list (user-group (name "guix-publish") (system? #t))
1525 (user-account
1526 (name "guix-publish")
1527 (group "guix-publish")
1528 (system? #t)
1529 (comment "guix publish user")
1530 (home-directory "/var/empty")
1531 (shell (file-append shadow "/sbin/nologin")))))
1533 (define (guix-publish-activation config)
1534 (let ((cache (guix-publish-configuration-cache config)))
1535 (if cache
1536 (with-imported-modules '((guix build utils))
1537 #~(begin
1538 (use-modules (guix build utils))
1540 (mkdir-p #$cache)
1541 (let* ((pw (getpw "guix-publish"))
1542 (uid (passwd:uid pw))
1543 (gid (passwd:gid pw)))
1544 (chown #$cache uid gid))))
1545 #t)))
1547 (define guix-publish-service-type
1548 (service-type (name 'guix-publish)
1549 (extensions
1550 (list (service-extension shepherd-root-service-type
1551 guix-publish-shepherd-service)
1552 (service-extension account-service-type
1553 (const %guix-publish-accounts))
1554 (service-extension activation-service-type
1555 guix-publish-activation)))
1556 (default-value (guix-publish-configuration))
1557 (description
1558 "Add a Shepherd service running @command{guix publish}, a
1559 command that allows you to share pre-built binaries with others over HTTP.")))
1561 (define* (guix-publish-service #:key (guix guix) (port 80) (host "localhost"))
1562 "Return a service that runs @command{guix publish} listening on @var{host}
1563 and @var{port} (@pxref{Invoking guix publish}).
1565 This assumes that @file{/etc/guix} already contains a signing key pair as
1566 created by @command{guix archive --generate-key} (@pxref{Invoking guix
1567 archive}). If that is not the case, the service will fail to start."
1568 ;; Deprecated.
1569 (service guix-publish-service-type
1570 (guix-publish-configuration (guix guix) (port port) (host host))))
1572 \f
1573 ;;;
1574 ;;; Udev.
1575 ;;;
1577 (define-record-type* <udev-configuration>
1578 udev-configuration make-udev-configuration
1579 udev-configuration?
1580 (udev udev-configuration-udev ;<package>
1581 (default udev))
1582 (rules udev-configuration-rules ;list of <package>
1583 (default '())))
1585 (define (udev-rules-union packages)
1586 "Return the union of the @code{lib/udev/rules.d} directories found in each
1587 item of @var{packages}."
1588 (define build
1589 (with-imported-modules '((guix build union)
1590 (guix build utils))
1591 #~(begin
1592 (use-modules (guix build union)
1593 (guix build utils)
1594 (srfi srfi-1)
1595 (srfi srfi-26))
1597 (define %standard-locations
1598 '("/lib/udev/rules.d" "/libexec/udev/rules.d"))
1600 (define (rules-sub-directory directory)
1601 ;; Return the sub-directory of DIRECTORY containing udev rules, or
1602 ;; #f if none was found.
1603 (find directory-exists?
1604 (map (cut string-append directory <>) %standard-locations)))
1606 (mkdir-p (string-append #$output "/lib/udev"))
1607 (union-build (string-append #$output "/lib/udev/rules.d")
1608 (filter-map rules-sub-directory '#$packages)))))
1610 (computed-file "udev-rules" build))
1612 (define (udev-rule file-name contents)
1613 "Return a directory with a udev rule file FILE-NAME containing CONTENTS."
1614 (computed-file file-name
1615 (with-imported-modules '((guix build utils))
1616 #~(begin
1617 (use-modules (guix build utils))
1619 (define rules.d
1620 (string-append #$output "/lib/udev/rules.d"))
1622 (mkdir-p rules.d)
1623 (call-with-output-file
1624 (string-append rules.d "/" #$file-name)
1625 (lambda (port)
1626 (display #$contents port)))))))
1628 (define (file->udev-rule file-name file)
1629 "Return a directory with a udev rule file FILE-NAME which is a copy of FILE."
1630 (computed-file file-name
1631 (with-imported-modules '((guix build utils))
1632 #~(begin
1633 (use-modules (guix build utils))
1635 (define rules.d
1636 (string-append #$output "/lib/udev/rules.d"))
1638 (define file-copy-dest
1639 (string-append rules.d "/" #$file-name))
1641 (mkdir-p rules.d)
1642 (copy-file #$file file-copy-dest)))))
1644 (define kvm-udev-rule
1645 ;; Return a directory with a udev rule that changes the group of /dev/kvm to
1646 ;; "kvm" and makes it #o660. Apparently QEMU-KVM used to ship this rule,
1647 ;; but now we have to add it by ourselves.
1649 ;; Build users are part of the "kvm" group, so we can fearlessly make
1650 ;; /dev/kvm 660 (see <http://bugs.gnu.org/18994>, for background.)
1651 (udev-rule "90-kvm.rules"
1652 "KERNEL==\"kvm\", GROUP=\"kvm\", MODE=\"0660\"\n"))
1654 (define udev-shepherd-service
1655 ;; Return a <shepherd-service> for UDEV with RULES.
1656 (match-lambda
1657 (($ <udev-configuration> udev rules)
1658 (let* ((rules (udev-rules-union (cons* udev kvm-udev-rule rules)))
1659 (udev.conf (computed-file "udev.conf"
1660 #~(call-with-output-file #$output
1661 (lambda (port)
1662 (format port
1663 "udev_rules=\"~a/lib/udev/rules.d\"\n"
1664 #$rules))))))
1665 (list
1666 (shepherd-service
1667 (provision '(udev))
1669 ;; Udev needs /dev to be a 'devtmpfs' mount so that new device nodes can
1670 ;; be added: see
1671 ;; <http://www.linuxfromscratch.org/lfs/view/development/chapter07/udev.html>.
1672 (requirement '(root-file-system))
1674 (documentation "Populate the /dev directory, dynamically.")
1675 (start #~(lambda ()
1676 (define find
1677 (@ (srfi srfi-1) find))
1679 (define udevd
1680 ;; Choose the right 'udevd'.
1681 (find file-exists?
1682 (map (lambda (suffix)
1683 (string-append #$udev suffix))
1684 '("/libexec/udev/udevd" ;udev
1685 "/sbin/udevd")))) ;eudev
1687 (define (wait-for-udevd)
1688 ;; Wait until someone's listening on udevd's control
1689 ;; socket.
1690 (let ((sock (socket AF_UNIX SOCK_SEQPACKET 0)))
1691 (let try ()
1692 (catch 'system-error
1693 (lambda ()
1694 (connect sock PF_UNIX "/run/udev/control")
1695 (close-port sock))
1696 (lambda args
1697 (format #t "waiting for udevd...~%")
1698 (usleep 500000)
1699 (try))))))
1701 ;; Allow udev to find the modules.
1702 (setenv "LINUX_MODULE_DIRECTORY"
1703 "/run/booted-system/kernel/lib/modules")
1705 ;; The first one is for udev, the second one for eudev.
1706 (setenv "UDEV_CONFIG_FILE" #$udev.conf)
1707 (setenv "EUDEV_RULES_DIRECTORY"
1708 #$(file-append rules "/lib/udev/rules.d"))
1710 (let ((pid (primitive-fork)))
1711 (case pid
1712 ((0)
1713 (exec-command (list udevd)))
1714 (else
1715 ;; Wait until udevd is up and running. This
1716 ;; appears to be needed so that the events
1717 ;; triggered below are actually handled.
1718 (wait-for-udevd)
1720 ;; Trigger device node creation.
1721 (system* #$(file-append udev "/bin/udevadm")
1722 "trigger" "--action=add")
1724 ;; Wait for things to settle down.
1725 (system* #$(file-append udev "/bin/udevadm")
1726 "settle")
1727 pid)))))
1728 (stop #~(make-kill-destructor))
1730 ;; When halting the system, 'udev' is actually killed by
1731 ;; 'user-processes', i.e., before its own 'stop' method was called.
1732 ;; Thus, make sure it is not respawned.
1733 (respawn? #f)))))))
1735 (define udev-service-type
1736 (service-type (name 'udev)
1737 (extensions
1738 (list (service-extension shepherd-root-service-type
1739 udev-shepherd-service)))
1741 (compose concatenate) ;concatenate the list of rules
1742 (extend (lambda (config rules)
1743 (match config
1744 (($ <udev-configuration> udev initial-rules)
1745 (udev-configuration
1746 (udev udev)
1747 (rules (append initial-rules rules)))))))
1748 (description
1749 "Run @command{udev}, which populates the @file{/dev}
1750 directory dynamically. Get extra rules from the packages listed in the
1751 @code{rules} field of its value, @code{udev-configuration} object.")))
1753 (define* (udev-service #:key (udev eudev) (rules '()))
1754 "Run @var{udev}, which populates the @file{/dev} directory dynamically. Get
1755 extra rules from the packages listed in @var{rules}."
1756 (service udev-service-type
1757 (udev-configuration (udev udev) (rules rules))))
1759 (define swap-service-type
1760 (shepherd-service-type
1761 'swap
1762 (lambda (device)
1763 (define requirement
1764 (if (string-prefix? "/dev/mapper/" device)
1765 (list (symbol-append 'device-mapping-
1766 (string->symbol (basename device))))
1767 '()))
1769 (shepherd-service
1770 (provision (list (symbol-append 'swap- (string->symbol device))))
1771 (requirement `(udev ,@requirement))
1772 (documentation "Enable the given swap device.")
1773 (start #~(lambda ()
1774 (restart-on-EINTR (swapon #$device))
1775 #t))
1776 (stop #~(lambda _
1777 (restart-on-EINTR (swapoff #$device))
1778 #f))
1779 (respawn? #f)))))
1781 (define (swap-service device)
1782 "Return a service that uses @var{device} as a swap device."
1783 (service swap-service-type device))
1785 (define-record-type* <gpm-configuration>
1786 gpm-configuration make-gpm-configuration gpm-configuration?
1787 (gpm gpm-configuration-gpm) ;package
1788 (options gpm-configuration-options)) ;list of strings
1790 (define gpm-shepherd-service
1791 (match-lambda
1792 (($ <gpm-configuration> gpm options)
1793 (list (shepherd-service
1794 (requirement '(udev))
1795 (provision '(gpm))
1796 (start #~(lambda ()
1797 ;; 'gpm' runs in the background and sets a PID file.
1798 ;; Note that it requires running as "root".
1799 (false-if-exception (delete-file "/var/run/gpm.pid"))
1800 (fork+exec-command (list #$(file-append gpm "/sbin/gpm")
1801 #$@options))
1803 ;; Wait for the PID file to appear; declare failure if
1804 ;; it doesn't show up.
1805 (let loop ((i 3))
1806 (or (file-exists? "/var/run/gpm.pid")
1807 (if (zero? i)
1808 #f
1809 (begin
1810 (sleep 1)
1811 (loop (1- i))))))))
1813 (stop #~(lambda (_)
1814 ;; Return #f if successfully stopped.
1815 (not (zero? (system* #$(file-append gpm "/sbin/gpm")
1816 "-k"))))))))))
1818 (define gpm-service-type
1819 (service-type (name 'gpm)
1820 (extensions
1821 (list (service-extension shepherd-root-service-type
1822 gpm-shepherd-service)))
1823 (description
1824 "Run GPM, the general-purpose mouse daemon, with the given
1825 command-line options. GPM allows users to use the mouse in the console,
1826 notably to select, copy, and paste text. The default options use the
1827 @code{ps2} protocol, which works for both USB and PS/2 mice.")))
1829 (define* (gpm-service #:key (gpm gpm)
1830 (options '("-m" "/dev/input/mice" "-t" "ps2")))
1831 "Run @var{gpm}, the general-purpose mouse daemon, with the given
1832 command-line @var{options}. GPM allows users to use the mouse in the console,
1833 notably to select, copy, and paste text. The default value of @var{options}
1834 uses the @code{ps2} protocol, which works for both USB and PS/2 mice.
1836 This service is not part of @var{%base-services}."
1837 ;; To test in QEMU, use "-usbdevice mouse" and then, in the monitor, use
1838 ;; "info mice" and "mouse_set X" to use the right mouse.
1839 (service gpm-service-type
1840 (gpm-configuration (gpm gpm) (options options))))
1842 (define-record-type* <kmscon-configuration>
1843 kmscon-configuration make-kmscon-configuration
1844 kmscon-configuration?
1845 (kmscon kmscon-configuration-kmscon
1846 (default kmscon))
1847 (virtual-terminal kmscon-configuration-virtual-terminal)
1848 (login-program kmscon-configuration-login-program
1849 (default (file-append shadow "/bin/login")))
1850 (login-arguments kmscon-configuration-login-arguments
1851 (default '("-p")))
1852 (hardware-acceleration? kmscon-configuration-hardware-acceleration?
1853 (default #f))) ; #t causes failure
1855 (define kmscon-service-type
1856 (shepherd-service-type
1857 'kmscon
1858 (lambda (config)
1859 (let ((kmscon (kmscon-configuration-kmscon config))
1860 (virtual-terminal (kmscon-configuration-virtual-terminal config))
1861 (login-program (kmscon-configuration-login-program config))
1862 (login-arguments (kmscon-configuration-login-arguments config))
1863 (hardware-acceleration? (kmscon-configuration-hardware-acceleration? config)))
1865 (define kmscon-command
1866 #~(list
1867 #$(file-append kmscon "/bin/kmscon") "--login"
1868 "--vt" #$virtual-terminal
1869 #$@(if hardware-acceleration? '("--hwaccel") '())
1870 "--" #$login-program #$@login-arguments))
1872 (shepherd-service
1873 (documentation "kmscon virtual terminal")
1874 (requirement '(user-processes udev dbus-system))
1875 (provision (list (symbol-append 'term- (string->symbol virtual-terminal))))
1876 (start #~(make-forkexec-constructor #$kmscon-command))
1877 (stop #~(make-kill-destructor)))))))
1879 \f
1880 (define %base-services
1881 ;; Convenience variable holding the basic services.
1882 (list (login-service)
1884 (service console-font-service-type
1885 (map (lambda (tty)
1886 (cons tty %default-console-font))
1887 '("tty1" "tty2" "tty3" "tty4" "tty5" "tty6")))
1889 (mingetty-service (mingetty-configuration
1890 (tty "tty1")))
1891 (mingetty-service (mingetty-configuration
1892 (tty "tty2")))
1893 (mingetty-service (mingetty-configuration
1894 (tty "tty3")))
1895 (mingetty-service (mingetty-configuration
1896 (tty "tty4")))
1897 (mingetty-service (mingetty-configuration
1898 (tty "tty5")))
1899 (mingetty-service (mingetty-configuration
1900 (tty "tty6")))
1902 (service static-networking-service-type
1903 (list (static-networking (interface "lo")
1904 (ip "127.0.0.1")
1905 (provision '(loopback)))))
1906 (syslog-service)
1907 (urandom-seed-service)
1908 (guix-service)
1909 (nscd-service)
1911 ;; The LVM2 rules are needed as soon as LVM2 or the device-mapper is
1912 ;; used, so enable them by default. The FUSE and ALSA rules are
1913 ;; less critical, but handy.
1914 (udev-service #:rules (list lvm2 fuse alsa-utils crda))
1916 (service special-files-service-type
1917 `(("/bin/sh" ,(file-append (canonical-package bash)
1918 "/bin/sh"))))))
1920 ;;; base.scm ends here