| blob | 537d30add5ca204832093aa64e830c02496067ae |
1 ;;; GNU Guix --- Functional package management for GNU
2 ;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018, 2019 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 ;;; Copyright © 2018 Mathieu Othacehe <m.othacehe@gmail.com>
10 ;;; Copyright © 2019 Efraim Flashner <efraim@flashner.co.il>
11 ;;;
12 ;;; This file is part of GNU Guix.
13 ;;;
14 ;;; GNU Guix is free software; you can redistribute it and/or modify it
15 ;;; under the terms of the GNU General Public License as published by
16 ;;; the Free Software Foundation; either version 3 of the License, or (at
17 ;;; your option) any later version.
18 ;;;
19 ;;; GNU Guix is distributed in the hope that it will be useful, but
20 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
21 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
22 ;;; GNU General Public License for more details.
23 ;;;
24 ;;; You should have received a copy of the GNU General Public License
25 ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
27 (define-module (gnu services base)
28 #:use-module (guix store)
29 #:use-module (guix deprecation)
30 #:use-module (gnu services)
31 #:use-module (gnu services admin)
32 #:use-module (gnu services shepherd)
33 #:use-module (gnu system pam)
34 #:use-module (gnu system shadow) ; 'user-account', etc.
35 #:use-module (gnu system uuid)
36 #:use-module (gnu system file-systems) ; 'file-system', etc.
37 #:use-module (gnu system mapped-devices)
38 #:use-module ((gnu system linux-initrd)
39 #:select (file-system-packages))
40 #:use-module (gnu packages admin)
41 #:use-module ((gnu packages linux)
42 #:select (alsa-utils crda eudev e2fsprogs fuse gpm kbd lvm2 rng-tools))
43 #:use-module ((gnu packages base)
44 #:select (canonical-package glibc glibc-utf8-locales))
45 #:use-module (gnu packages bash)
46 #:use-module (gnu packages package-management)
47 #:use-module ((gnu packages gnupg) #:select (guile-gcrypt))
48 #:use-module (gnu packages linux)
49 #:use-module (gnu packages terminals)
50 #:use-module ((gnu build file-systems)
51 #:select (mount-flags->bit-mask))
52 #:use-module (guix gexp)
53 #:use-module (guix records)
54 #:use-module (guix modules)
55 #:use-module ((guix self) #:select (make-config.scm))
56 #:use-module (srfi srfi-1)
57 #:use-module (srfi srfi-26)
58 #:use-module (ice-9 match)
59 #:use-module (ice-9 format)
60 #:export (fstab-service-type
61 root-file-system-service
62 file-system-service-type
63 swap-service
64 user-processes-service-type
65 host-name-service
66 console-keymap-service
67 %default-console-font
68 console-font-service-type
69 console-font-service
70 virtual-terminal-service-type
72 static-networking
74 static-networking?
75 static-networking-interface
76 static-networking-ip
77 static-networking-netmask
78 static-networking-gateway
79 static-networking-requirement
81 static-networking-service
82 static-networking-service-type
84 udev-configuration
85 udev-configuration?
86 udev-configuration-rules
87 udev-service-type
88 udev-service
89 udev-rule
90 file->udev-rule
92 login-configuration
93 login-configuration?
94 login-service-type
95 login-service
97 agetty-configuration
98 agetty-configuration?
99 agetty-service
100 agetty-service-type
102 mingetty-configuration
103 mingetty-configuration?
104 mingetty-service
105 mingetty-service-type
107 %nscd-default-caches
108 %nscd-default-configuration
110 nscd-configuration
111 nscd-configuration?
113 nscd-cache
114 nscd-cache?
116 nscd-service-type
117 nscd-service
119 syslog-configuration
120 syslog-configuration?
121 syslog-service
122 syslog-service-type
123 %default-syslog.conf
125 %default-authorized-guix-keys
126 guix-configuration
127 guix-configuration?
129 guix-configuration-guix
130 guix-configuration-build-group
131 guix-configuration-build-accounts
132 guix-configuration-authorize-key?
133 guix-configuration-authorized-keys
134 guix-configuration-use-substitutes?
135 guix-configuration-substitute-urls
136 guix-configuration-extra-options
137 guix-configuration-log-file
139 guix-service
140 guix-service-type
141 guix-publish-configuration
142 guix-publish-configuration?
143 guix-publish-configuration-guix
144 guix-publish-configuration-port
145 guix-publish-configuration-host
146 guix-publish-configuration-compression
147 guix-publish-configuration-compression-level ;deprecated
148 guix-publish-configuration-nar-path
149 guix-publish-configuration-cache
150 guix-publish-configuration-ttl
151 guix-publish-service
152 guix-publish-service-type
154 gpm-configuration
155 gpm-configuration?
156 gpm-service-type
157 gpm-service
159 urandom-seed-service-type
160 urandom-seed-service
162 rngd-configuration
163 rngd-configuration?
164 rngd-service-type
165 rngd-service
167 kmscon-configuration
168 kmscon-configuration?
169 kmscon-service-type
171 pam-limits-service-type
172 pam-limits-service
174 %base-services))
176 ;;; Commentary:
177 ;;;
178 ;;; Base system services---i.e., services that 99% of the users will want to
179 ;;; use.
180 ;;;
181 ;;; Code:
184 \f
185 ;;;
186 ;;; User processes.
187 ;;;
189 (define %do-not-kill-file
190 ;; Name of the file listing PIDs of processes that must survive when halting
191 ;; the system. Typical example is user-space file systems.
192 "/etc/shepherd/do-not-kill")
194 (define (user-processes-shepherd-service requirements)
195 "Return the 'user-processes' Shepherd service with dependencies on
196 REQUIREMENTS (a list of service names).
198 This is a synchronization point used to make sure user processes and daemons
199 get started only after crucial initial services have been started---file
200 system mounts, etc. This is similar to the 'sysvinit' target in systemd."
201 (define grace-delay
202 ;; Delay after sending SIGTERM and before sending SIGKILL.
203 4)
205 (list (shepherd-service
206 (documentation "When stopped, terminate all user processes.")
207 (provision '(user-processes))
208 (requirement requirements)
209 (start #~(const #t))
210 (stop #~(lambda _
211 (define (kill-except omit signal)
212 ;; Kill all the processes with SIGNAL except those listed
213 ;; in OMIT and the current process.
214 (let ((omit (cons (getpid) omit)))
215 (for-each (lambda (pid)
216 (unless (memv pid omit)
217 (false-if-exception
218 (kill pid signal))))
219 (processes))))
221 (define omitted-pids
222 ;; List of PIDs that must not be killed.
223 (if (file-exists? #$%do-not-kill-file)
224 (map string->number
225 (call-with-input-file #$%do-not-kill-file
226 (compose string-tokenize
227 (@ (ice-9 rdelim) read-string))))
228 '()))
230 (define (now)
231 (car (gettimeofday)))
233 (define (sleep* n)
234 ;; Really sleep N seconds.
235 ;; Work around <http://bugs.gnu.org/19581>.
236 (define start (now))
237 (let loop ((elapsed 0))
238 (when (> n elapsed)
239 (sleep (- n elapsed))
240 (loop (- (now) start)))))
242 (define lset= (@ (srfi srfi-1) lset=))
244 (display "sending all processes the TERM signal\n")
246 (if (null? omitted-pids)
247 (begin
248 ;; Easy: terminate all of them.
249 (kill -1 SIGTERM)
250 (sleep* #$grace-delay)
251 (kill -1 SIGKILL))
252 (begin
253 ;; Kill them all except OMITTED-PIDS. XXX: We would
254 ;; like to (kill -1 SIGSTOP) to get a fixed list of
255 ;; processes, like 'killall5' does, but that seems
256 ;; unreliable.
257 (kill-except omitted-pids SIGTERM)
258 (sleep* #$grace-delay)
259 (kill-except omitted-pids SIGKILL)
260 (delete-file #$%do-not-kill-file)))
262 (let wait ()
263 ;; Reap children, if any, so that we don't end up with
264 ;; zombies and enter an infinite loop.
265 (let reap-children ()
266 (define result
267 (false-if-exception
268 (waitpid WAIT_ANY (if (null? omitted-pids)
269 0
270 WNOHANG))))
272 (when (and (pair? result)
273 (not (zero? (car result))))
274 (reap-children)))
276 (let ((pids (processes)))
277 (unless (lset= = pids (cons 1 omitted-pids))
278 (format #t "waiting for process termination\
279 (processes left: ~s)~%"
280 pids)
281 (sleep* 2)
282 (wait))))
284 (display "all processes have been terminated\n")
285 #f))
286 (respawn? #f))))
288 (define user-processes-service-type
289 (service-type
290 (name 'user-processes)
291 (extensions (list (service-extension shepherd-root-service-type
292 user-processes-shepherd-service)))
293 (compose concatenate)
294 (extend append)
296 ;; The value is the list of Shepherd services 'user-processes' depends on.
297 ;; Extensions can add new services to this list.
298 (default-value '())
300 (description "The @code{user-processes} service is responsible for
301 terminating all the processes so that the root file system can be re-mounted
302 read-only, just before rebooting/halting. Processes still running after a few
303 seconds after @code{SIGTERM} has been sent are terminated with
304 @code{SIGKILL}.")))
306 \f
307 ;;;
308 ;;; File systems.
309 ;;;
311 (define (file-system->fstab-entry file-system)
312 "Return a @file{/etc/fstab} entry for @var{file-system}."
313 (string-append (match (file-system-device file-system)
314 ((? file-system-label? label)
315 (string-append "LABEL="
316 (file-system-label->string label)))
317 ((? uuid? uuid)
318 (string-append "UUID=" (uuid->string uuid)))
319 ((? string? device)
320 device))
321 "\t"
322 (file-system-mount-point file-system) "\t"
323 (file-system-type file-system) "\t"
324 (or (file-system-options file-system) "defaults") "\t"
326 ;; XXX: Omit the 'fs_freq' and 'fs_passno' fields because we
327 ;; don't have anything sensible to put in there.
328 ))
330 (define (file-systems->fstab file-systems)
331 "Return a @file{/etc} entry for an @file{fstab} describing
332 @var{file-systems}."
333 `(("fstab" ,(plain-file "fstab"
334 (string-append
335 "\
336 # This file was generated from your Guix configuration. Any changes
337 # will be lost upon reboot or reconfiguration.\n\n"
338 (string-join (map file-system->fstab-entry
339 file-systems)
340 "\n")
341 "\n")))))
343 (define fstab-service-type
344 ;; The /etc/fstab service.
345 (service-type (name 'fstab)
346 (extensions
347 (list (service-extension etc-service-type
348 file-systems->fstab)))
349 (compose concatenate)
350 (extend append)
351 (description
352 "Populate the @file{/etc/fstab} based on the given file
353 system objects.")))
355 (define %root-file-system-shepherd-service
356 (shepherd-service
357 (documentation "Take care of the root file system.")
358 (provision '(root-file-system))
359 (start #~(const #t))
360 (stop #~(lambda _
361 ;; Return #f if successfully stopped.
362 (sync)
364 (call-with-blocked-asyncs
365 (lambda ()
366 (let ((null (%make-void-port "w")))
367 ;; Close 'shepherd.log'.
368 (display "closing log\n")
369 ((@ (shepherd comm) stop-logging))
371 ;; Redirect the default output ports..
372 (set-current-output-port null)
373 (set-current-error-port null)
375 ;; Close /dev/console.
376 (for-each close-fdes '(0 1 2))
378 ;; At this point, there are no open files left, so the
379 ;; root file system can be re-mounted read-only.
380 (mount #f "/" #f
381 (logior MS_REMOUNT MS_RDONLY)
382 #:update-mtab? #f)
384 #f)))))
385 (respawn? #f)))
387 (define root-file-system-service-type
388 (shepherd-service-type 'root-file-system
389 (const %root-file-system-shepherd-service)))
391 (define (root-file-system-service)
392 "Return a service whose sole purpose is to re-mount read-only the root file
393 system upon shutdown (aka. cleanly \"umounting\" root.)
395 This service must be the root of the service dependency graph so that its
396 'stop' action is invoked when shepherd is the only process left."
397 (service root-file-system-service-type #f))
399 (define (file-system->shepherd-service-name file-system)
400 "Return the symbol that denotes the service mounting and unmounting
401 FILE-SYSTEM."
402 (symbol-append 'file-system-
403 (string->symbol (file-system-mount-point file-system))))
405 (define (mapped-device->shepherd-service-name md)
406 "Return the symbol that denotes the shepherd service of MD, a <mapped-device>."
407 (symbol-append 'device-mapping-
408 (string->symbol (mapped-device-target md))))
410 (define dependency->shepherd-service-name
411 (match-lambda
412 ((? mapped-device? md)
413 (mapped-device->shepherd-service-name md))
414 ((? file-system? fs)
415 (file-system->shepherd-service-name fs))))
417 (define (file-system-shepherd-service file-system)
418 "Return the shepherd service for @var{file-system}, or @code{#f} if
419 @var{file-system} is not auto-mounted upon boot."
420 (let ((target (file-system-mount-point file-system))
421 (create? (file-system-create-mount-point? file-system))
422 (dependencies (file-system-dependencies file-system))
423 (packages (file-system-packages (list file-system))))
424 (and (file-system-mount? file-system)
425 (with-imported-modules (source-module-closure
426 '((gnu build file-systems)))
427 (shepherd-service
428 (provision (list (file-system->shepherd-service-name file-system)))
429 (requirement `(root-file-system udev
430 ,@(map dependency->shepherd-service-name dependencies)))
431 (documentation "Check, mount, and unmount the given file system.")
432 (start #~(lambda args
433 #$(if create?
434 #~(mkdir-p #$target)
435 #t)
437 (let (($PATH (getenv "PATH")))
438 ;; Make sure fsck.ext2 & co. can be found.
439 (dynamic-wind
440 (lambda ()
441 ;; Don’t display the PATH settings.
442 (with-output-to-port (%make-void-port "w")
443 (lambda ()
444 (set-path-environment-variable "PATH"
445 '("bin" "sbin")
446 '#$packages))))
447 (lambda ()
448 (mount-file-system
449 (spec->file-system
450 '#$(file-system->spec file-system))
451 #:root "/"))
452 (lambda ()
453 (setenv "PATH" $PATH)))
454 #t)))
455 (stop #~(lambda args
456 ;; Normally there are no processes left at this point, so
457 ;; TARGET can be safely unmounted.
459 ;; Make sure PID 1 doesn't keep TARGET busy.
460 (chdir "/")
462 (umount #$target)
463 #f))
465 ;; We need additional modules.
466 (modules `(((gnu build file-systems)
467 #:select (mount-file-system))
468 (gnu system file-systems)
469 ,@%default-modules)))))))
471 (define (file-system-shepherd-services file-systems)
472 "Return the list of Shepherd services for FILE-SYSTEMS."
473 (let* ((file-systems (filter file-system-mount? file-systems)))
474 (define sink
475 (shepherd-service
476 (provision '(file-systems))
477 (requirement (cons* 'root-file-system 'user-file-systems
478 (map file-system->shepherd-service-name
479 file-systems)))
480 (documentation "Target for all the initially-mounted file systems")
481 (start #~(const #t))
482 (stop #~(const #f))))
484 (define known-mount-points
485 (map file-system-mount-point file-systems))
487 (define user-unmount
488 (shepherd-service
489 (documentation "Unmount manually-mounted file systems.")
490 (provision '(user-file-systems))
491 (start #~(const #t))
492 (stop #~(lambda args
493 (define (known? mount-point)
494 (member mount-point
495 (cons* "/proc" "/sys" '#$known-mount-points)))
497 ;; Make sure we don't keep the user's mount points busy.
498 (chdir "/")
500 (for-each (lambda (mount-point)
501 (format #t "unmounting '~a'...~%" mount-point)
502 (catch 'system-error
503 (lambda ()
504 (umount mount-point))
505 (lambda args
506 (let ((errno (system-error-errno args)))
507 (format #t "failed to unmount '~a': ~a~%"
508 mount-point (strerror errno))))))
509 (filter (negate known?) (mount-points)))
510 #f))))
512 (cons* sink user-unmount
513 (map file-system-shepherd-service file-systems))))
515 (define (file-system-fstab-entries file-systems)
516 "Return the subset of @var{file-systems} that should have an entry in
517 @file{/etc/fstab}."
518 ;; /etc/fstab is about telling fsck(8), mount(8), and umount(8) about
519 ;; relevant file systems they'll have to deal with. That excludes "pseudo"
520 ;; file systems.
521 ;;
522 ;; In particular, things like GIO (part of GLib) use it to determine the set
523 ;; of mounts, which is then used by graphical file managers and desktop
524 ;; environments to display "volume" icons. Thus, we really need to exclude
525 ;; those pseudo file systems from the list.
526 (remove (lambda (file-system)
527 (or (member (file-system-type file-system)
528 %pseudo-file-system-types)
529 (memq 'bind-mount (file-system-flags file-system))))
530 file-systems))
532 (define file-system-service-type
533 (service-type (name 'file-systems)
534 (extensions
535 (list (service-extension shepherd-root-service-type
536 file-system-shepherd-services)
537 (service-extension fstab-service-type
538 file-system-fstab-entries)
540 ;; Have 'user-processes' depend on 'file-systems'.
541 (service-extension user-processes-service-type
542 (const '(file-systems)))))
543 (compose concatenate)
544 (extend append)
545 (description
546 "Provide Shepherd services to mount and unmount the given
547 file systems, as well as corresponding @file{/etc/fstab} entries.")))
550 \f
551 ;;;
552 ;;; Preserve entropy to seed /dev/urandom on boot.
553 ;;;
555 (define %random-seed-file
556 "/var/lib/random-seed")
558 (define (urandom-seed-shepherd-service _)
559 "Return a shepherd service for the /dev/urandom seed."
560 (list (shepherd-service
561 (documentation "Preserve entropy across reboots for /dev/urandom.")
562 (provision '(urandom-seed))
564 ;; Depend on udev so that /dev/hwrng is available.
565 (requirement '(file-systems udev))
567 (start #~(lambda _
568 ;; On boot, write random seed into /dev/urandom.
569 (when (file-exists? #$%random-seed-file)
570 (call-with-input-file #$%random-seed-file
571 (lambda (seed)
572 (call-with-output-file "/dev/urandom"
573 (lambda (urandom)
574 (dump-port seed urandom))))))
576 ;; Try writing from /dev/hwrng into /dev/urandom.
577 ;; It seems that the file /dev/hwrng always exists, even
578 ;; when there is no hardware random number generator
579 ;; available. So, we handle a failed read or any other error
580 ;; reported by the operating system.
581 (let ((buf (catch 'system-error
582 (lambda ()
583 (call-with-input-file "/dev/hwrng"
584 (lambda (hwrng)
585 (get-bytevector-n hwrng 512))))
586 ;; Silence is golden...
587 (const #f))))
588 (when buf
589 (call-with-output-file "/dev/urandom"
590 (lambda (urandom)
591 (put-bytevector urandom buf)))))
593 ;; Immediately refresh the seed in case the system doesn't
594 ;; shut down cleanly.
595 (call-with-input-file "/dev/urandom"
596 (lambda (urandom)
597 (let ((previous-umask (umask #o077))
598 (buf (make-bytevector 512)))
599 (mkdir-p (dirname #$%random-seed-file))
600 (get-bytevector-n! urandom buf 0 512)
601 (call-with-output-file #$%random-seed-file
602 (lambda (seed)
603 (put-bytevector seed buf)))
604 (umask previous-umask))))
605 #t))
606 (stop #~(lambda _
607 ;; During shutdown, write from /dev/urandom into random seed.
608 (let ((buf (make-bytevector 512)))
609 (call-with-input-file "/dev/urandom"
610 (lambda (urandom)
611 (let ((previous-umask (umask #o077)))
612 (get-bytevector-n! urandom buf 0 512)
613 (mkdir-p (dirname #$%random-seed-file))
614 (call-with-output-file #$%random-seed-file
615 (lambda (seed)
616 (put-bytevector seed buf)))
617 (umask previous-umask))
618 #t)))))
619 (modules `((rnrs bytevectors)
620 (rnrs io ports)
621 ,@%default-modules)))))
623 (define urandom-seed-service-type
624 (service-type (name 'urandom-seed)
625 (extensions
626 (list (service-extension shepherd-root-service-type
627 urandom-seed-shepherd-service)
629 ;; Have 'user-processes' depend on 'urandom-seed'.
630 ;; This ensures that user processes and daemons don't
631 ;; start until we have seeded the PRNG.
632 (service-extension user-processes-service-type
633 (const '(urandom-seed)))))
634 (default-value #f)
635 (description
636 "Seed the @file{/dev/urandom} pseudo-random number
637 generator (RNG) with the value recorded when the system was last shut
638 down.")))
640 (define-deprecated (urandom-seed-service)
641 urandom-seed-service-type
642 (service urandom-seed-service-type))
645 ;;;
646 ;;; Add hardware random number generator to entropy pool.
647 ;;;
649 (define-record-type* <rngd-configuration>
650 rngd-configuration make-rngd-configuration
651 rngd-configuration?
652 (rng-tools rngd-configuration-rng-tools) ;package
653 (device rngd-configuration-device)) ;string
655 (define rngd-service-type
656 (shepherd-service-type
657 'rngd
658 (lambda (config)
659 (define rng-tools (rngd-configuration-rng-tools config))
660 (define device (rngd-configuration-device config))
662 (define rngd-command
663 (list (file-append rng-tools "/sbin/rngd")
664 "-f" "-r" device))
666 (shepherd-service
667 (documentation "Add TRNG to entropy pool.")
668 (requirement '(udev))
669 (provision '(trng))
670 (start #~(make-forkexec-constructor #$@rngd-command))
671 (stop #~(make-kill-destructor))))))
673 (define* (rngd-service #:key
674 (rng-tools rng-tools)
675 (device "/dev/hwrng"))
676 "Return a service that runs the @command{rngd} program from @var{rng-tools}
677 to add @var{device} to the kernel's entropy pool. The service will fail if
678 @var{device} does not exist."
679 (service rngd-service-type
680 (rngd-configuration
681 (rng-tools rng-tools)
682 (device device))))
684 \f
685 ;;;
686 ;;; Console & co.
687 ;;;
689 (define host-name-service-type
690 (shepherd-service-type
691 'host-name
692 (lambda (name)
693 (shepherd-service
694 (documentation "Initialize the machine's host name.")
695 (provision '(host-name))
696 (start #~(lambda _
697 (sethostname #$name)))
698 (respawn? #f)))))
700 (define (host-name-service name)
701 "Return a service that sets the host name to @var{name}."
702 (service host-name-service-type name))
704 (define virtual-terminal-service-type
705 ;; Ensure that virtual terminals run in UTF-8 mode. This is the case by
706 ;; default with recent Linux kernels, but this service allows us to ensure
707 ;; this. This service must start before any 'term-' service so that newly
708 ;; created terminals inherit this property. See
709 ;; <https://bugs.gnu.org/30505> for a discussion.
710 (shepherd-service-type
711 'virtual-terminal
712 (lambda (utf8?)
713 (let ((knob "/sys/module/vt/parameters/default_utf8"))
714 (shepherd-service
715 (documentation "Set virtual terminals in UTF-8 module.")
716 (provision '(virtual-terminal))
717 (requirement '(root-file-system))
718 (start #~(lambda _
719 ;; In containers /sys is read-only so don't insist on
720 ;; writing to this file.
721 (unless (= 1 (call-with-input-file #$knob read))
722 (call-with-output-file #$knob
723 (lambda (port)
724 (display 1 port))))
725 #t))
726 (stop #~(const #f)))))
727 #t)) ;default to UTF-8
729 (define console-keymap-service-type
730 (shepherd-service-type
731 'console-keymap
732 (lambda (files)
733 (shepherd-service
734 (documentation (string-append "Load console keymap (loadkeys)."))
735 (provision '(console-keymap))
736 (start #~(lambda _
737 (zero? (system* #$(file-append kbd "/bin/loadkeys")
738 #$@files))))
739 (respawn? #f)))))
741 (define-deprecated (console-keymap-service #:rest files)
742 #f
743 "Return a service to load console keymaps from @var{files}."
744 (service console-keymap-service-type files))
746 (define %default-console-font
747 ;; Note: 'LatGrkCyr-8x16' has the advantage of providing three common
748 ;; scripts as well as glyphs for em dash, quotation marks, and other Unicode
749 ;; codepoints notably found in the UTF-8 manual.
750 "LatGrkCyr-8x16")
752 (define (console-font-shepherd-services tty+font)
753 "Return a list of Shepherd services for each pair in TTY+FONT."
754 (map (match-lambda
755 ((tty . font)
756 (let ((device (string-append "/dev/" tty)))
757 (shepherd-service
758 (documentation "Load a Unicode console font.")
759 (provision (list (symbol-append 'console-font-
760 (string->symbol tty))))
762 ;; Start after mingetty has been started on TTY, otherwise the settings
763 ;; are ignored.
764 (requirement (list (symbol-append 'term-
765 (string->symbol tty))))
767 (start #~(lambda _
768 ;; It could be that mingetty is not fully ready yet,
769 ;; which we check by calling 'ttyname'.
770 (let loop ((i 10))
771 (unless (or (zero? i)
772 (call-with-input-file #$device
773 (lambda (port)
774 (false-if-exception (ttyname port)))))
775 (usleep 500)
776 (loop (- i 1))))
778 ;; Assume the VT is already in UTF-8 mode, thanks to
779 ;; the 'virtual-terminal' service.
780 ;;
781 ;; 'setfont' returns EX_OSERR (71) when an
782 ;; KDFONTOP ioctl fails, for example. Like
783 ;; systemd's vconsole support, let's not treat
784 ;; this as an error.
785 (case (status:exit-val
786 (system* #$(file-append kbd "/bin/setfont")
787 "-C" #$device #$font))
788 ((0 71) #t)
789 (else #f))))
790 (stop #~(const #t))
791 (respawn? #f)))))
792 tty+font))
794 (define console-font-service-type
795 (service-type (name 'console-fonts)
796 (extensions
797 (list (service-extension shepherd-root-service-type
798 console-font-shepherd-services)))
799 (compose concatenate)
800 (extend append)
801 (description
802 "Install the given fonts on the specified ttys (fonts are per
803 virtual console on GNU/Linux). The value of this service is a list of
804 tty/font pairs like:
806 @example
807 '((\"tty1\" . \"LatGrkCyr-8x16\"))
808 @end example\n")))
810 (define* (console-font-service tty #:optional (font "LatGrkCyr-8x16"))
811 "This procedure is deprecated in favor of @code{console-font-service-type}.
813 Return a service that sets up Unicode support in @var{tty} and loads
814 @var{font} for that tty (fonts are per virtual console in Linux.)"
815 (simple-service (symbol-append 'console-font- (string->symbol tty))
816 console-font-service-type `((,tty . ,font))))
818 (define %default-motd
819 (plain-file "motd" "This is the GNU operating system, welcome!\n\n"))
821 (define-record-type* <login-configuration>
822 login-configuration make-login-configuration
823 login-configuration?
824 (motd login-configuration-motd ;file-like
825 (default %default-motd))
826 ;; Allow empty passwords by default so that first-time users can log in when
827 ;; the 'root' account has just been created.
828 (allow-empty-passwords? login-configuration-allow-empty-passwords?
829 (default #t))) ;Boolean
831 (define (login-pam-service config)
832 "Return the list of PAM service needed for CONF."
833 ;; Let 'login' be known to PAM.
834 (list (unix-pam-service "login"
835 #:login-uid? #t
836 #:allow-empty-passwords?
837 (login-configuration-allow-empty-passwords? config)
838 #:motd
839 (login-configuration-motd config))))
841 (define login-service-type
842 (service-type (name 'login)
843 (extensions (list (service-extension pam-root-service-type
844 login-pam-service)))
845 (default-value (login-configuration))
846 (description
847 "Provide a console log-in service as specified by its
848 configuration value, a @code{login-configuration} object.")))
850 (define* (login-service #:optional (config (login-configuration)))
851 "Return a service configure login according to @var{config}, which specifies
852 the message of the day, among other things."
853 (service login-service-type config))
855 (define-record-type* <agetty-configuration>
856 agetty-configuration make-agetty-configuration
857 agetty-configuration?
858 (agetty agetty-configuration-agetty ;<package>
859 (default util-linux))
860 (tty agetty-configuration-tty) ;string | #f
861 (term agetty-term ;string | #f
862 (default #f))
863 (baud-rate agetty-baud-rate ;string | #f
864 (default #f))
865 (auto-login agetty-auto-login ;list of strings | #f
866 (default #f))
867 (login-program agetty-login-program ;gexp
868 (default (file-append shadow "/bin/login")))
869 (login-pause? agetty-login-pause? ;Boolean
870 (default #f))
871 (eight-bits? agetty-eight-bits? ;Boolean
872 (default #f))
873 (no-reset? agetty-no-reset? ;Boolean
874 (default #f))
875 (remote? agetty-remote? ;Boolean
876 (default #f))
877 (flow-control? agetty-flow-control? ;Boolean
878 (default #f))
879 (host agetty-host ;string | #f
880 (default #f))
881 (no-issue? agetty-no-issue? ;Boolean
882 (default #f))
883 (init-string agetty-init-string ;string | #f
884 (default #f))
885 (no-clear? agetty-no-clear? ;Boolean
886 (default #f))
887 (local-line agetty-local-line ;always | never | auto
888 (default #f))
889 (extract-baud? agetty-extract-baud? ;Boolean
890 (default #f))
891 (skip-login? agetty-skip-login? ;Boolean
892 (default #f))
893 (no-newline? agetty-no-newline? ;Boolean
894 (default #f))
895 (login-options agetty-login-options ;string | #f
896 (default #f))
897 (chroot agetty-chroot ;string | #f
898 (default #f))
899 (hangup? agetty-hangup? ;Boolean
900 (default #f))
901 (keep-baud? agetty-keep-baud? ;Boolean
902 (default #f))
903 (timeout agetty-timeout ;integer | #f
904 (default #f))
905 (detect-case? agetty-detect-case? ;Boolean
906 (default #f))
907 (wait-cr? agetty-wait-cr? ;Boolean
908 (default #f))
909 (no-hints? agetty-no-hints? ;Boolean
910 (default #f))
911 (no-hostname? agetty-no hostname? ;Boolean
912 (default #f))
913 (long-hostname? agetty-long-hostname? ;Boolean
914 (default #f))
915 (erase-characters agetty-erase-characters ;string | #f
916 (default #f))
917 (kill-characters agetty-kill-characters ;string | #f
918 (default #f))
919 (chdir agetty-chdir ;string | #f
920 (default #f))
921 (delay agetty-delay ;integer | #f
922 (default #f))
923 (nice agetty-nice ;integer | #f
924 (default #f))
925 ;; "Escape hatch" for passing arbitrary command-line arguments.
926 (extra-options agetty-extra-options ;list of strings
927 (default '()))
928 ;;; XXX Unimplemented for now!
929 ;;; (issue-file agetty-issue-file ;file-like
930 ;;; (default #f))
931 )
933 (define (default-serial-port)
934 "Return a gexp that determines a reasonable default serial port
935 to use as the tty. This is primarily useful for headless systems."
936 #~(begin
937 ;; console=device,options
938 ;; device: can be tty0, ttyS0, lp0, ttyUSB0 (serial).
939 ;; options: BBBBPNF. P n|o|e, N number of bits,
940 ;; F flow control (r RTS)
941 (let* ((not-comma (char-set-complement (char-set #\,)))
942 (command (linux-command-line))
943 (agetty-specs (find-long-options "agetty.tty" command))
944 (console-specs (filter (lambda (spec)
945 (and (string-prefix? "tty" spec)
946 (not (or
947 (string-prefix? "tty0" spec)
948 (string-prefix? "tty1" spec)
949 (string-prefix? "tty2" spec)
950 (string-prefix? "tty3" spec)
951 (string-prefix? "tty4" spec)
952 (string-prefix? "tty5" spec)
953 (string-prefix? "tty6" spec)
954 (string-prefix? "tty7" spec)
955 (string-prefix? "tty8" spec)
956 (string-prefix? "tty9" spec)))))
957 (find-long-options "console" command)))
958 (specs (append agetty-specs console-specs)))
959 (match specs
960 (() #f)
961 ((spec _ ...)
962 ;; Extract device name from first spec.
963 (match (string-tokenize spec not-comma)
964 ((device-name _ ...)
965 device-name)))))))
967 (define agetty-shepherd-service
968 (match-lambda
969 (($ <agetty-configuration> agetty tty term baud-rate auto-login
970 login-program login-pause? eight-bits? no-reset? remote? flow-control?
971 host no-issue? init-string no-clear? local-line extract-baud?
972 skip-login? no-newline? login-options chroot hangup? keep-baud? timeout
973 detect-case? wait-cr? no-hints? no-hostname? long-hostname?
974 erase-characters kill-characters chdir delay nice extra-options)
975 (list
976 (shepherd-service
977 (modules '((ice-9 match) (gnu build linux-boot)))
978 (documentation "Run agetty on a tty.")
979 (provision (list (symbol-append 'term- (string->symbol (or tty "auto")))))
981 ;; Since the login prompt shows the host name, wait for the 'host-name'
982 ;; service to be done. Also wait for udev essentially so that the tty
983 ;; text is not lost in the middle of kernel messages (see also
984 ;; mingetty-shepherd-service).
985 (requirement '(user-processes host-name udev))
987 (start #~(lambda args
988 (let ((defaulted-tty #$(or tty (default-serial-port))))
989 (apply
990 (if defaulted-tty
991 (make-forkexec-constructor
992 (list #$(file-append util-linux "/sbin/agetty")
993 #$@extra-options
994 #$@(if eight-bits?
995 #~("--8bits")
996 #~())
997 #$@(if no-reset?
998 #~("--noreset")
999 #~())
1000 #$@(if remote?
1001 #~("--remote")
1002 #~())
1003 #$@(if flow-control?
1004 #~("--flow-control")
1005 #~())
1006 #$@(if host
1007 #~("--host" #$host)
1008 #~())
1009 #$@(if no-issue?
1010 #~("--noissue")
1011 #~())
1012 #$@(if init-string
1013 #~("--init-string" #$init-string)
1014 #~())
1015 #$@(if no-clear?
1016 #~("--noclear")
1017 #~())
1018 ;;; FIXME This doesn't work as expected. According to agetty(8), if this option
1019 ;;; is not passed, then the default is 'auto'. However, in my tests, when that
1020 ;;; option is selected, agetty never presents the login prompt, and the
1021 ;;; term-ttyS0 service respawns every few seconds.
1022 #$@(if local-line
1023 #~(#$(match local-line
1024 ('auto "--local-line=auto")
1025 ('always "--local-line=always")
1026 ('never "-local-line=never")))
1027 #~())
1028 #$@(if tty
1029 #~()
1030 #~("--keep-baud"))
1031 #$@(if extract-baud?
1032 #~("--extract-baud")
1033 #~())
1034 #$@(if skip-login?
1035 #~("--skip-login")
1036 #~())
1037 #$@(if no-newline?
1038 #~("--nonewline")
1039 #~())
1040 #$@(if login-options
1041 #~("--login-options" #$login-options)
1042 #~())
1043 #$@(if chroot
1044 #~("--chroot" #$chroot)
1045 #~())
1046 #$@(if hangup?
1047 #~("--hangup")
1048 #~())
1049 #$@(if keep-baud?
1050 #~("--keep-baud")
1051 #~())
1052 #$@(if timeout
1053 #~("--timeout" #$(number->string timeout))
1054 #~())
1055 #$@(if detect-case?
1056 #~("--detect-case")
1057 #~())
1058 #$@(if wait-cr?
1059 #~("--wait-cr")
1060 #~())
1061 #$@(if no-hints?
1062 #~("--nohints?")
1063 #~())
1064 #$@(if no-hostname?
1065 #~("--nohostname")
1066 #~())
1067 #$@(if long-hostname?
1068 #~("--long-hostname")
1069 #~())
1070 #$@(if erase-characters
1071 #~("--erase-chars" #$erase-characters)
1072 #~())
1073 #$@(if kill-characters
1074 #~("--kill-chars" #$kill-characters)
1075 #~())
1076 #$@(if chdir
1077 #~("--chdir" #$chdir)
1078 #~())
1079 #$@(if delay
1080 #~("--delay" #$(number->string delay))
1081 #~())
1082 #$@(if nice
1083 #~("--nice" #$(number->string nice))
1084 #~())
1085 #$@(if auto-login
1086 (list "--autologin" auto-login)
1087 '())
1088 #$@(if login-program
1089 #~("--login-program" #$login-program)
1090 #~())
1091 #$@(if login-pause?
1092 #~("--login-pause")
1093 #~())
1094 defaulted-tty
1095 #$@(if baud-rate
1096 #~(#$baud-rate)
1097 #~())
1098 #$@(if term
1099 #~(#$term)
1100 #~())))
1101 (const #f)) ; never start.
1102 args))))
1103 (stop #~(make-kill-destructor)))))))
1105 (define agetty-service-type
1106 (service-type (name 'agetty)
1107 (extensions (list (service-extension shepherd-root-service-type
1108 agetty-shepherd-service)))
1109 (description
1110 "Provide console login using the @command{agetty}
1111 program.")))
1113 (define* (agetty-service config)
1114 "Return a service to run agetty according to @var{config}, which specifies
1115 the tty to run, among other things."
1116 (service agetty-service-type config))
1118 (define-record-type* <mingetty-configuration>
1119 mingetty-configuration make-mingetty-configuration
1120 mingetty-configuration?
1121 (mingetty mingetty-configuration-mingetty ;<package>
1122 (default mingetty))
1123 (tty mingetty-configuration-tty) ;string
1124 (auto-login mingetty-auto-login ;string | #f
1125 (default #f))
1126 (login-program mingetty-login-program ;gexp
1127 (default #f))
1128 (login-pause? mingetty-login-pause? ;Boolean
1129 (default #f)))
1131 (define mingetty-shepherd-service
1132 (match-lambda
1133 (($ <mingetty-configuration> mingetty tty auto-login login-program
1134 login-pause?)
1135 (list
1136 (shepherd-service
1137 (documentation "Run mingetty on an tty.")
1138 (provision (list (symbol-append 'term- (string->symbol tty))))
1140 ;; Since the login prompt shows the host name, wait for the 'host-name'
1141 ;; service to be done. Also wait for udev essentially so that the tty
1142 ;; text is not lost in the middle of kernel messages (XXX).
1143 (requirement '(user-processes host-name udev virtual-terminal))
1145 (start #~(make-forkexec-constructor
1146 (list #$(file-append mingetty "/sbin/mingetty")
1147 "--noclear"
1149 ;; Avoiding 'vhangup' allows us to avoid 'setfont'
1150 ;; errors down the path where various ioctls get
1151 ;; EIO--see 'hung_up_tty_ioctl' in driver/tty/tty_io.c
1152 ;; in Linux.
1153 "--nohangup" #$tty
1155 #$@(if auto-login
1156 #~("--autologin" #$auto-login)
1157 #~())
1158 #$@(if login-program
1159 #~("--loginprog" #$login-program)
1160 #~())
1161 #$@(if login-pause?
1162 #~("--loginpause")
1163 #~()))))
1164 (stop #~(make-kill-destructor)))))))
1166 (define mingetty-service-type
1167 (service-type (name 'mingetty)
1168 (extensions (list (service-extension shepherd-root-service-type
1169 mingetty-shepherd-service)))
1170 (description
1171 "Provide console login using the @command{mingetty}
1172 program.")))
1174 (define* (mingetty-service config)
1175 "Return a service to run mingetty according to @var{config}, which specifies
1176 the tty to run, among other things."
1177 (service mingetty-service-type config))
1179 (define-record-type* <nscd-configuration> nscd-configuration
1180 make-nscd-configuration
1181 nscd-configuration?
1182 (log-file nscd-configuration-log-file ;string
1183 (default "/var/log/nscd.log"))
1184 (debug-level nscd-debug-level ;integer
1185 (default 0))
1186 ;; TODO: See nscd.conf in glibc for other options to add.
1187 (caches nscd-configuration-caches ;list of <nscd-cache>
1188 (default %nscd-default-caches))
1189 (name-services nscd-configuration-name-services ;list of <packages>
1190 (default '()))
1191 (glibc nscd-configuration-glibc ;<package>
1192 (default (canonical-package glibc))))
1194 (define-record-type* <nscd-cache> nscd-cache make-nscd-cache
1195 nscd-cache?
1196 (database nscd-cache-database) ;symbol
1197 (positive-time-to-live nscd-cache-positive-time-to-live) ;integer
1198 (negative-time-to-live nscd-cache-negative-time-to-live
1199 (default 20)) ;integer
1200 (suggested-size nscd-cache-suggested-size ;integer ("default module
1201 ;of hash table")
1202 (default 211))
1203 (check-files? nscd-cache-check-files? ;Boolean
1204 (default #t))
1205 (persistent? nscd-cache-persistent? ;Boolean
1206 (default #t))
1207 (shared? nscd-cache-shared? ;Boolean
1208 (default #t))
1209 (max-database-size nscd-cache-max-database-size ;integer
1210 (default (* 32 (expt 2 20))))
1211 (auto-propagate? nscd-cache-auto-propagate? ;Boolean
1212 (default #t)))
1214 (define %nscd-default-caches
1215 ;; Caches that we want to enable by default. Note that when providing an
1216 ;; empty nscd.conf, all caches are disabled.
1217 (list (nscd-cache (database 'hosts)
1219 ;; Aggressively cache the host name cache to improve
1220 ;; privacy and resilience.
1221 (positive-time-to-live (* 3600 12))
1222 (negative-time-to-live 20)
1223 (persistent? #t))
1225 (nscd-cache (database 'services)
1227 ;; Services are unlikely to change, so we can be even more
1228 ;; aggressive.
1229 (positive-time-to-live (* 3600 24))
1230 (negative-time-to-live 3600)
1231 (check-files? #t) ;check /etc/services changes
1232 (persistent? #t))))
1234 (define %nscd-default-configuration
1235 ;; Default nscd configuration.
1236 (nscd-configuration))
1238 (define (nscd.conf-file config)
1239 "Return the @file{nscd.conf} configuration file for @var{config}, an
1240 @code{<nscd-configuration>} object."
1241 (define cache->config
1242 (match-lambda
1243 (($ <nscd-cache> (= symbol->string database)
1244 positive-ttl negative-ttl size check-files?
1245 persistent? shared? max-size propagate?)
1246 (string-append "\nenable-cache\t" database "\tyes\n"
1248 "positive-time-to-live\t" database "\t"
1249 (number->string positive-ttl) "\n"
1250 "negative-time-to-live\t" database "\t"
1251 (number->string negative-ttl) "\n"
1252 "suggested-size\t" database "\t"
1253 (number->string size) "\n"
1254 "check-files\t" database "\t"
1255 (if check-files? "yes\n" "no\n")
1256 "persistent\t" database "\t"
1257 (if persistent? "yes\n" "no\n")
1258 "shared\t" database "\t"
1259 (if shared? "yes\n" "no\n")
1260 "max-db-size\t" database "\t"
1261 (number->string max-size) "\n"
1262 "auto-propagate\t" database "\t"
1263 (if propagate? "yes\n" "no\n")))))
1265 (match config
1266 (($ <nscd-configuration> log-file debug-level caches)
1267 (plain-file "nscd.conf"
1268 (string-append "\
1269 # Configuration of libc's name service cache daemon (nscd).\n\n"
1270 (if log-file
1271 (string-append "logfile\t" log-file)
1272 "")
1273 "\n"
1274 (if debug-level
1275 (string-append "debug-level\t"
1276 (number->string debug-level))
1277 "")
1278 "\n"
1279 (string-concatenate
1280 (map cache->config caches)))))))
1282 (define (nscd-action-procedure nscd config option)
1283 ;; XXX: This is duplicated from mcron; factorize.
1284 #~(lambda (_ . args)
1285 ;; Run 'nscd' in a pipe so we can explicitly redirect its output to
1286 ;; 'current-output-port', which at this stage is bound to the client
1287 ;; connection.
1288 (let ((pipe (apply open-pipe* OPEN_READ #$nscd
1289 "-f" #$config #$option args)))
1290 (let loop ()
1291 (match (read-line pipe 'concat)
1292 ((? eof-object?)
1293 (catch 'system-error
1294 (lambda ()
1295 (zero? (close-pipe pipe)))
1296 (lambda args
1297 ;; There's a race with the SIGCHLD handler, which could
1298 ;; call 'waitpid' before 'close-pipe' above does. If we
1299 ;; get ECHILD, that means we lost the race; in that case, we
1300 ;; cannot tell what the exit code was (FIXME).
1301 (or (= ECHILD (system-error-errno args))
1302 (apply throw args)))))
1303 (line
1304 (display line)
1305 (loop)))))))
1307 (define (nscd-actions nscd config)
1308 "Return Shepherd actions for NSCD."
1309 ;; Make this functionality available as actions because that's a simple way
1310 ;; to run the right 'nscd' binary with the right config file.
1311 (list (shepherd-action
1312 (name 'statistics)
1313 (documentation "Display statistics about nscd usage.")
1314 (procedure (nscd-action-procedure nscd config "--statistics")))
1315 (shepherd-action
1316 (name 'invalidate)
1317 (documentation
1318 "Invalidate the given cache--e.g., 'hosts' for host name lookups.")
1319 (procedure (nscd-action-procedure nscd config "--invalidate")))))
1321 (define (nscd-shepherd-service config)
1322 "Return a shepherd service for CONFIG, an <nscd-configuration> object."
1323 (let ((nscd (file-append (nscd-configuration-glibc config)
1324 "/sbin/nscd"))
1325 (nscd.conf (nscd.conf-file config))
1326 (name-services (nscd-configuration-name-services config)))
1327 (list (shepherd-service
1328 (documentation "Run libc's name service cache daemon (nscd).")
1329 (provision '(nscd))
1330 (requirement '(user-processes))
1331 (start #~(make-forkexec-constructor
1332 (list #$nscd "-f" #$nscd.conf "--foreground")
1334 ;; Wait for the PID file. However, the PID file is
1335 ;; written before nscd is actually listening on its
1336 ;; socket (XXX).
1337 #:pid-file "/var/run/nscd/nscd.pid"
1339 #:environment-variables
1340 (list (string-append "LD_LIBRARY_PATH="
1341 (string-join
1342 (map (lambda (dir)
1343 (string-append dir "/lib"))
1344 (list #$@name-services))
1345 ":")))))
1346 (stop #~(make-kill-destructor))
1347 (modules `((ice-9 popen) ;for the actions
1348 (ice-9 rdelim)
1349 (ice-9 match)
1350 ,@%default-modules))
1351 (actions (nscd-actions nscd nscd.conf))))))
1353 (define nscd-activation
1354 ;; Actions to take before starting nscd.
1355 #~(begin
1356 (use-modules (guix build utils))
1357 (mkdir-p "/var/run/nscd")
1358 (mkdir-p "/var/db/nscd") ;for the persistent cache
1360 ;; In libc 2.25 nscd uses inotify to watch /etc/resolv.conf, but only if
1361 ;; that file exists when it is started. Thus create it here. Note: on
1362 ;; some systems, such as when NetworkManager is used, /etc/resolv.conf
1363 ;; is a symlink, hence 'lstat'.
1364 (unless (false-if-exception (lstat "/etc/resolv.conf"))
1365 (call-with-output-file "/etc/resolv.conf"
1366 (lambda (port)
1367 (display "# This is a placeholder.\n" port))))))
1369 (define nscd-service-type
1370 (service-type (name 'nscd)
1371 (extensions
1372 (list (service-extension activation-service-type
1373 (const nscd-activation))
1374 (service-extension shepherd-root-service-type
1375 nscd-shepherd-service)))
1377 ;; This can be extended by providing additional name services
1378 ;; such as nss-mdns.
1379 (compose concatenate)
1380 (extend (lambda (config name-services)
1381 (nscd-configuration
1382 (inherit config)
1383 (name-services (append
1384 (nscd-configuration-name-services config)
1385 name-services)))))
1386 (default-value %nscd-default-configuration)
1387 (description
1388 "Runs libc's @dfn{name service cache daemon} (nscd) with the
1389 given configuration---an @code{<nscd-configuration>} object. @xref{Name
1390 Service Switch}, for an example.")))
1392 (define* (nscd-service #:optional (config %nscd-default-configuration))
1393 "Return a service that runs libc's name service cache daemon (nscd) with the
1394 given @var{config}---an @code{<nscd-configuration>} object. @xref{Name
1395 Service Switch}, for an example."
1396 (service nscd-service-type config))
1399 (define-record-type* <syslog-configuration>
1400 syslog-configuration make-syslog-configuration
1401 syslog-configuration?
1402 (syslogd syslog-configuration-syslogd
1403 (default (file-append inetutils "/libexec/syslogd")))
1404 (config-file syslog-configuration-config-file
1405 (default %default-syslog.conf)))
1407 (define syslog-service-type
1408 (shepherd-service-type
1409 'syslog
1410 (lambda (config)
1411 (shepherd-service
1412 (documentation "Run the syslog daemon (syslogd).")
1413 (provision '(syslogd))
1414 (requirement '(user-processes))
1415 (start #~(make-forkexec-constructor
1416 (list #$(syslog-configuration-syslogd config)
1417 "--rcfile" #$(syslog-configuration-config-file config))
1418 #:pid-file "/var/run/syslog.pid"))
1419 (stop #~(make-kill-destructor))))))
1421 ;; Snippet adapted from the GNU inetutils manual.
1422 (define %default-syslog.conf
1423 (plain-file "syslog.conf" "
1424 # Log all error messages, authentication messages of
1425 # level notice or higher and anything of level err or
1426 # higher to the console.
1427 # Don't log private authentication messages!
1428 *.alert;auth.notice;authpriv.none /dev/console
1430 # Log anything (except mail) of level info or higher.
1431 # Don't log private authentication messages!
1432 *.info;mail.none;authpriv.none /var/log/messages
1434 # Like /var/log/messages, but also including \"debug\"-level logs.
1435 *.debug;mail.none;authpriv.none /var/log/debug
1437 # Same, in a different place.
1438 *.info;mail.none;authpriv.none /dev/tty12
1440 # The authpriv file has restricted access.
1441 authpriv.* /var/log/secure
1443 # Log all the mail messages in one place.
1444 mail.* /var/log/maillog
1445 "))
1447 (define* (syslog-service #:optional (config (syslog-configuration)))
1448 "Return a service that runs @command{syslogd} and takes
1449 @var{<syslog-configuration>} as a parameter.
1451 @xref{syslogd invocation,,, inetutils, GNU Inetutils}, for more
1452 information on the configuration file syntax."
1453 (service syslog-service-type config))
1456 (define pam-limits-service-type
1457 (let ((security-limits
1458 ;; Create /etc/security containing the provided "limits.conf" file.
1459 (lambda (limits-file)
1460 `(("security"
1461 ,(computed-file
1462 "security"
1463 #~(begin
1464 (mkdir #$output)
1465 (stat #$limits-file)
1466 (symlink #$limits-file
1467 (string-append #$output "/limits.conf"))))))))
1468 (pam-extension
1469 (lambda (pam)
1470 (let ((pam-limits (pam-entry
1471 (control "required")
1472 (module "pam_limits.so")
1473 (arguments '("conf=/etc/security/limits.conf")))))
1474 (if (member (pam-service-name pam)
1475 '("login" "su" "slim"))
1476 (pam-service
1477 (inherit pam)
1478 (session (cons pam-limits
1479 (pam-service-session pam))))
1480 pam)))))
1481 (service-type
1482 (name 'limits)
1483 (extensions
1484 (list (service-extension etc-service-type security-limits)
1485 (service-extension pam-root-service-type
1486 (lambda _ (list pam-extension)))))
1487 (description
1488 "Install the specified resource usage limits by populating
1489 @file{/etc/security/limits.conf} and using the @code{pam_limits}
1490 authentication module."))))
1492 (define* (pam-limits-service #:optional (limits '()))
1493 "Return a service that makes selected programs respect the list of
1494 pam-limits-entry specified in LIMITS via pam_limits.so."
1495 (service pam-limits-service-type
1496 (plain-file "limits.conf"
1497 (string-join (map pam-limits-entry->string limits)
1498 "\n"))))
1500 \f
1501 ;;;
1502 ;;; Guix services.
1503 ;;;
1505 (define* (guix-build-accounts count #:key
1506 (group "guixbuild")
1507 (shadow shadow))
1508 "Return a list of COUNT user accounts for Guix build users with the given
1509 GID."
1510 (unfold (cut > <> count)
1511 (lambda (n)
1512 (user-account
1513 (name (format #f "guixbuilder~2,'0d" n))
1514 (system? #t)
1515 (group group)
1517 ;; guix-daemon expects GROUP to be listed as a
1518 ;; supplementary group too:
1519 ;; <http://lists.gnu.org/archive/html/bug-guix/2013-01/msg00239.html>.
1520 (supplementary-groups (list group "kvm"))
1522 (comment (format #f "Guix Build User ~2d" n))
1523 (home-directory "/var/empty")
1524 (shell (file-append shadow "/sbin/nologin"))))
1525 1+
1526 1))
1528 (define not-config?
1529 ;; Select (guix …) and (gnu …) modules, except (guix config).
1530 (match-lambda
1531 (('guix 'config) #f)
1532 (('guix rest ...) #t)
1533 (('gnu rest ...) #t)
1534 (rest #f)))
1536 (define (substitute-key-authorization keys guix)
1537 "Return a gexp with code to register KEYS, a list of files containing 'guix
1538 archive' public keys, with GUIX."
1539 (define default-acl
1540 (with-extensions (list guile-gcrypt)
1541 (with-imported-modules `(((guix config) => ,(make-config.scm))
1542 ,@(source-module-closure '((guix pki))
1543 #:select? not-config?))
1544 (computed-file "acl"
1545 #~(begin
1546 (use-modules (guix pki)
1547 (gcrypt pk-crypto)
1548 (ice-9 rdelim))
1550 (define keys
1551 (map (lambda (file)
1552 (call-with-input-file file
1553 (compose string->canonical-sexp
1554 read-string)))
1555 '(#$@keys)))
1557 (call-with-output-file #$output
1558 (lambda (port)
1559 (write-acl (public-keys->acl keys)
1560 port))))))))
1562 (with-imported-modules '((guix build utils))
1563 #~(begin
1564 (use-modules (guix build utils))
1566 (unless (file-exists? "/etc/guix/acl")
1567 (mkdir-p "/etc/guix")
1568 (copy-file #+default-acl "/etc/guix/acl")
1569 (chmod "/etc/guix/acl" #o600)))))
1571 (define %default-authorized-guix-keys
1572 ;; List of authorized substitute keys.
1573 (list (file-append guix "/share/guix/berlin.guixsd.org.pub")))
1575 (define-record-type* <guix-configuration>
1576 guix-configuration make-guix-configuration
1577 guix-configuration?
1578 (guix guix-configuration-guix ;<package>
1579 (default guix))
1580 (build-group guix-configuration-build-group ;string
1581 (default "guixbuild"))
1582 (build-accounts guix-configuration-build-accounts ;integer
1583 (default 10))
1584 (authorize-key? guix-configuration-authorize-key? ;Boolean
1585 (default #t))
1586 (authorized-keys guix-configuration-authorized-keys ;list of gexps
1587 (default %default-authorized-guix-keys))
1588 (use-substitutes? guix-configuration-use-substitutes? ;Boolean
1589 (default #t))
1590 (substitute-urls guix-configuration-substitute-urls ;list of strings
1591 (default %default-substitute-urls))
1592 (chroot-directories guix-configuration-chroot-directories ;list of file-like/strings
1593 (default '()))
1594 (max-silent-time guix-configuration-max-silent-time ;integer
1595 (default 0))
1596 (timeout guix-configuration-timeout ;integer
1597 (default 0))
1598 (log-compression guix-configuration-log-compression
1599 (default 'bzip2))
1600 (extra-options guix-configuration-extra-options ;list of strings
1601 (default '()))
1602 (log-file guix-configuration-log-file ;string
1603 (default "/var/log/guix-daemon.log"))
1604 (http-proxy guix-http-proxy ;string | #f
1605 (default #f))
1606 (tmpdir guix-tmpdir ;string | #f
1607 (default #f)))
1609 (define %default-guix-configuration
1610 (guix-configuration))
1612 (define (guix-shepherd-service config)
1613 "Return a <shepherd-service> for the Guix daemon service with CONFIG."
1614 (match-record config <guix-configuration>
1615 (guix build-group build-accounts authorize-key? authorized-keys
1616 use-substitutes? substitute-urls max-silent-time timeout
1617 log-compression extra-options log-file http-proxy tmpdir
1618 chroot-directories)
1619 (list (shepherd-service
1620 (documentation "Run the Guix daemon.")
1621 (provision '(guix-daemon))
1622 (requirement '(user-processes))
1623 (modules '((srfi srfi-1)))
1624 (start
1625 #~(make-forkexec-constructor
1626 (cons* #$(file-append guix "/bin/guix-daemon")
1627 "--build-users-group" #$build-group
1628 "--max-silent-time" #$(number->string max-silent-time)
1629 "--timeout" #$(number->string timeout)
1630 "--log-compression" #$(symbol->string log-compression)
1631 #$@(if use-substitutes?
1632 '()
1633 '("--no-substitutes"))
1634 "--substitute-urls" #$(string-join substitute-urls)
1635 #$@extra-options
1637 ;; Add CHROOT-DIRECTORIES and all their dependencies (if
1638 ;; these are store items) to the chroot.
1639 (append-map (lambda (file)
1640 (append-map (lambda (directory)
1641 (list "--chroot-directory"
1642 directory))
1643 (call-with-input-file file
1644 read)))
1645 '#$(map references-file chroot-directories)))
1647 #:environment-variables
1648 (list #$@(if http-proxy
1649 (list (string-append "http_proxy=" http-proxy))
1650 '())
1651 #$@(if tmpdir
1652 (list (string-append "TMPDIR=" tmpdir))
1653 '())
1655 ;; Make sure we run in a UTF-8 locale so that 'guix
1656 ;; offload' correctly restores nars that contain UTF-8
1657 ;; file names such as 'nss-certs'. See
1658 ;; <https://bugs.gnu.org/32942>.
1659 (string-append "GUIX_LOCPATH="
1660 #$glibc-utf8-locales "/lib/locale")
1661 "LC_ALL=en_US.utf8")
1663 #:log-file #$log-file))
1664 (stop #~(make-kill-destructor))))))
1666 (define (guix-accounts config)
1667 "Return the user accounts and user groups for CONFIG."
1668 (match config
1669 (($ <guix-configuration> _ build-group build-accounts)
1670 (cons (user-group
1671 (name build-group)
1672 (system? #t)
1674 ;; Use a fixed GID so that we can create the store with the right
1675 ;; owner.
1676 (id 30000))
1677 (guix-build-accounts build-accounts
1678 #:group build-group)))))
1680 (define (guix-activation config)
1681 "Return the activation gexp for CONFIG."
1682 (match config
1683 (($ <guix-configuration> guix build-group build-accounts authorize-key? keys)
1684 ;; Assume that the store has BUILD-GROUP as its group. We could
1685 ;; otherwise call 'chown' here, but the problem is that on a COW overlayfs,
1686 ;; chown leads to an entire copy of the tree, which is a bad idea.
1688 ;; Optionally authorize substitute server keys.
1689 (if authorize-key?
1690 (substitute-key-authorization keys guix)
1691 #~#f))))
1693 (define* (references-file item #:optional (name "references"))
1694 "Return a file that contains the list of references of ITEM."
1695 (if (struct? item) ;lowerable object
1696 (computed-file name
1697 (with-imported-modules (source-module-closure
1698 '((guix build store-copy)))
1699 #~(begin
1700 (use-modules (guix build store-copy))
1702 (call-with-output-file #$output
1703 (lambda (port)
1704 (write (map store-info-item
1705 (call-with-input-file "graph"
1706 read-reference-graph))
1707 port)))))
1708 #:options `(#:local-build? #f
1709 #:references-graphs (("graph" ,item))))
1710 (plain-file name "()")))
1712 (define guix-service-type
1713 (service-type
1714 (name 'guix)
1715 (extensions
1716 (list (service-extension shepherd-root-service-type guix-shepherd-service)
1717 (service-extension account-service-type guix-accounts)
1718 (service-extension activation-service-type guix-activation)
1719 (service-extension profile-service-type
1720 (compose list guix-configuration-guix))))
1722 ;; Extensions can specify extra directories to add to the build chroot.
1723 (compose concatenate)
1724 (extend (lambda (config directories)
1725 (guix-configuration
1726 (inherit config)
1727 (chroot-directories
1728 (append (guix-configuration-chroot-directories config)
1729 directories)))))
1731 (default-value (guix-configuration))
1732 (description
1733 "Run the build daemon of GNU@tie{}Guix, aka. @command{guix-daemon}.")))
1735 (define-deprecated (guix-service #:optional
1736 (config %default-guix-configuration))
1737 guix-service-type
1738 "Return a service that runs the Guix build daemon according to
1739 @var{config}."
1740 (service guix-service-type config))
1743 (define-record-type* <guix-publish-configuration>
1744 guix-publish-configuration make-guix-publish-configuration
1745 guix-publish-configuration?
1746 (guix guix-publish-configuration-guix ;package
1747 (default guix))
1748 (port guix-publish-configuration-port ;number
1749 (default 80))
1750 (host guix-publish-configuration-host ;string
1751 (default "localhost"))
1752 (compression guix-publish-configuration-compression
1753 (thunked)
1754 (default (default-compression this-record
1755 (current-source-location))))
1756 (compression-level %guix-publish-configuration-compression-level ;deprecated
1757 (default #f))
1758 (nar-path guix-publish-configuration-nar-path ;string
1759 (default "nar"))
1760 (cache guix-publish-configuration-cache ;#f | string
1761 (default #f))
1762 (workers guix-publish-configuration-workers ;#f | integer
1763 (default #f))
1764 (ttl guix-publish-configuration-ttl ;#f | integer
1765 (default #f)))
1767 (define-deprecated (guix-publish-configuration-compression-level config)
1768 "Return a compression level, the old way."
1769 (match (guix-publish-configuration-compression config)
1770 (((_ level) _ ...) level)))
1772 (define (default-compression config properties)
1773 "Return the default 'guix publish' compression according to CONFIG, and
1774 raise a deprecation warning if the 'compression-level' field was used."
1775 (match (%guix-publish-configuration-compression-level config)
1776 (#f
1777 '(("gzip" 3)))
1778 (level
1779 (warn-about-deprecation 'compression-level properties
1780 #:replacement 'compression)
1781 `(("gzip" ,level)))))
1783 (define (guix-publish-shepherd-service config)
1784 (define (config->compression-options config)
1785 (match (guix-publish-configuration-compression config)
1786 (() ;empty list means "no compression"
1787 '("-C0"))
1788 (lst
1789 (append-map (match-lambda
1790 ((type level)
1791 `("-C" ,(string-append type ":"
1792 (number->string level)))))
1793 lst))))
1795 (match-record config <guix-publish-configuration>
1796 (guix port host nar-path cache workers ttl)
1797 (list (shepherd-service
1798 (provision '(guix-publish))
1799 (requirement '(guix-daemon))
1800 (start #~(make-forkexec-constructor
1801 (list #$(file-append guix "/bin/guix")
1802 "publish" "-u" "guix-publish"
1803 "-p" #$(number->string port)
1804 #$@(config->compression-options config)
1805 (string-append "--nar-path=" #$nar-path)
1806 (string-append "--listen=" #$host)
1807 #$@(if workers
1808 #~((string-append "--workers="
1809 #$(number->string
1810 workers)))
1811 #~())
1812 #$@(if ttl
1813 #~((string-append "--ttl="
1814 #$(number->string ttl)
1815 "s"))
1816 #~())
1817 #$@(if cache
1818 #~((string-append "--cache=" #$cache))
1819 #~()))
1821 ;; Make sure we run in a UTF-8 locale so we can produce
1822 ;; nars for packages that contain UTF-8 file names such
1823 ;; as 'nss-certs'. See <https://bugs.gnu.org/26948>.
1824 #:environment-variables
1825 (list (string-append "GUIX_LOCPATH="
1826 #$glibc-utf8-locales "/lib/locale")
1827 "LC_ALL=en_US.utf8")
1828 #:log-file "/var/log/guix-publish.log"))
1829 (stop #~(make-kill-destructor))))))
1831 (define %guix-publish-accounts
1832 (list (user-group (name "guix-publish") (system? #t))
1833 (user-account
1834 (name "guix-publish")
1835 (group "guix-publish")
1836 (system? #t)
1837 (comment "guix publish user")
1838 (home-directory "/var/empty")
1839 (shell (file-append shadow "/sbin/nologin")))))
1841 (define %guix-publish-log-rotations
1842 (list (log-rotation
1843 (files (list "/var/log/guix-publish.log")))))
1845 (define (guix-publish-activation config)
1846 (let ((cache (guix-publish-configuration-cache config)))
1847 (if cache
1848 (with-imported-modules '((guix build utils))
1849 #~(begin
1850 (use-modules (guix build utils))
1852 (mkdir-p #$cache)
1853 (let* ((pw (getpw "guix-publish"))
1854 (uid (passwd:uid pw))
1855 (gid (passwd:gid pw)))
1856 (chown #$cache uid gid))))
1857 #t)))
1859 (define guix-publish-service-type
1860 (service-type (name 'guix-publish)
1861 (extensions
1862 (list (service-extension shepherd-root-service-type
1863 guix-publish-shepherd-service)
1864 (service-extension account-service-type
1865 (const %guix-publish-accounts))
1866 (service-extension rottlog-service-type
1867 (const %guix-publish-log-rotations))
1868 (service-extension activation-service-type
1869 guix-publish-activation)))
1870 (default-value (guix-publish-configuration))
1871 (description
1872 "Add a Shepherd service running @command{guix publish}, a
1873 command that allows you to share pre-built binaries with others over HTTP.")))
1875 (define-deprecated (guix-publish-service #:key (guix guix)
1876 (port 80) (host "localhost"))
1877 guix-publish-service-type
1878 "Return a service that runs @command{guix publish} listening on @var{host}
1879 and @var{port} (@pxref{Invoking guix publish}).
1881 This assumes that @file{/etc/guix} already contains a signing key pair as
1882 created by @command{guix archive --generate-key} (@pxref{Invoking guix
1883 archive}). If that is not the case, the service will fail to start."
1884 ;; Deprecated.
1885 (service guix-publish-service-type
1886 (guix-publish-configuration (guix guix) (port port) (host host))))
1888 \f
1889 ;;;
1890 ;;; Udev.
1891 ;;;
1893 (define-record-type* <udev-configuration>
1894 udev-configuration make-udev-configuration
1895 udev-configuration?
1896 (udev udev-configuration-udev ;<package>
1897 (default eudev))
1898 (rules udev-configuration-rules ;list of <package>
1899 (default '())))
1901 (define (udev-rules-union packages)
1902 "Return the union of the @code{lib/udev/rules.d} directories found in each
1903 item of @var{packages}."
1904 (define build
1905 (with-imported-modules '((guix build union)
1906 (guix build utils))
1907 #~(begin
1908 (use-modules (guix build union)
1909 (guix build utils)
1910 (srfi srfi-1)
1911 (srfi srfi-26))
1913 (define %standard-locations
1914 '("/lib/udev/rules.d" "/libexec/udev/rules.d"))
1916 (define (rules-sub-directory directory)
1917 ;; Return the sub-directory of DIRECTORY containing udev rules, or
1918 ;; #f if none was found.
1919 (find directory-exists?
1920 (map (cut string-append directory <>) %standard-locations)))
1922 (mkdir-p (string-append #$output "/lib/udev"))
1923 (union-build (string-append #$output "/lib/udev/rules.d")
1924 (filter-map rules-sub-directory '#$packages)))))
1926 (computed-file "udev-rules" build))
1928 (define (udev-rule file-name contents)
1929 "Return a directory with a udev rule file FILE-NAME containing CONTENTS."
1930 (computed-file file-name
1931 (with-imported-modules '((guix build utils))
1932 #~(begin
1933 (use-modules (guix build utils))
1935 (define rules.d
1936 (string-append #$output "/lib/udev/rules.d"))
1938 (mkdir-p rules.d)
1939 (call-with-output-file
1940 (string-append rules.d "/" #$file-name)
1941 (lambda (port)
1942 (display #$contents port)))))))
1944 (define (file->udev-rule file-name file)
1945 "Return a directory with a udev rule file FILE-NAME which is a copy of FILE."
1946 (computed-file file-name
1947 (with-imported-modules '((guix build utils))
1948 #~(begin
1949 (use-modules (guix build utils))
1951 (define rules.d
1952 (string-append #$output "/lib/udev/rules.d"))
1954 (define file-copy-dest
1955 (string-append rules.d "/" #$file-name))
1957 (mkdir-p rules.d)
1958 (copy-file #$file file-copy-dest)))))
1960 (define kvm-udev-rule
1961 ;; Return a directory with a udev rule that changes the group of /dev/kvm to
1962 ;; "kvm" and makes it #o660. Apparently QEMU-KVM used to ship this rule,
1963 ;; but now we have to add it by ourselves.
1965 ;; Build users are part of the "kvm" group, so we can fearlessly make
1966 ;; /dev/kvm 660 (see <http://bugs.gnu.org/18994>, for background.)
1967 (udev-rule "90-kvm.rules"
1968 "KERNEL==\"kvm\", GROUP=\"kvm\", MODE=\"0660\"\n"))
1970 (define udev-shepherd-service
1971 ;; Return a <shepherd-service> for UDEV with RULES.
1972 (match-lambda
1973 (($ <udev-configuration> udev rules)
1974 (let* ((rules (udev-rules-union (cons* udev kvm-udev-rule rules)))
1975 (udev.conf (computed-file "udev.conf"
1976 #~(call-with-output-file #$output
1977 (lambda (port)
1978 (format port
1979 "udev_rules=\"~a/lib/udev/rules.d\"\n"
1980 #$rules))))))
1981 (list
1982 (shepherd-service
1983 (provision '(udev))
1985 ;; Udev needs /dev to be a 'devtmpfs' mount so that new device nodes can
1986 ;; be added: see
1987 ;; <http://www.linuxfromscratch.org/lfs/view/development/chapter07/udev.html>.
1988 (requirement '(root-file-system))
1990 (documentation "Populate the /dev directory, dynamically.")
1991 (start #~(lambda ()
1992 (define udevd
1993 ;; 'udevd' from eudev.
1994 #$(file-append udev "/sbin/udevd"))
1996 (define (wait-for-udevd)
1997 ;; Wait until someone's listening on udevd's control
1998 ;; socket.
1999 (let ((sock (socket AF_UNIX SOCK_SEQPACKET 0)))
2000 (let try ()
2001 (catch 'system-error
2002 (lambda ()
2003 (connect sock PF_UNIX "/run/udev/control")
2004 (close-port sock))
2005 (lambda args
2006 (format #t "waiting for udevd...~%")
2007 (usleep 500000)
2008 (try))))))
2010 ;; Allow udev to find the modules.
2011 (setenv "LINUX_MODULE_DIRECTORY"
2012 "/run/booted-system/kernel/lib/modules")
2014 ;; The first one is for udev, the second one for eudev.
2015 (setenv "UDEV_CONFIG_FILE" #$udev.conf)
2016 (setenv "EUDEV_RULES_DIRECTORY"
2017 #$(file-append rules "/lib/udev/rules.d"))
2019 (let* ((kernel-release
2020 (utsname:release (uname)))
2021 (linux-module-directory
2022 (getenv "LINUX_MODULE_DIRECTORY"))
2023 (directory
2024 (string-append linux-module-directory "/"
2025 kernel-release))
2026 (old-umask (umask #o022)))
2027 ;; If we're in a container, DIRECTORY might not exist,
2028 ;; for instance because the host runs a different
2029 ;; kernel. In that case, skip it; we'll just miss a few
2030 ;; nodes like /dev/fuse.
2031 (when (file-exists? directory)
2032 (make-static-device-nodes directory))
2033 (umask old-umask))
2035 (let ((pid (fork+exec-command (list udevd))))
2036 ;; Wait until udevd is up and running. This appears to
2037 ;; be needed so that the events triggered below are
2038 ;; actually handled.
2039 (wait-for-udevd)
2041 ;; Trigger device node creation.
2042 (system* #$(file-append udev "/bin/udevadm")
2043 "trigger" "--action=add")
2045 ;; Wait for things to settle down.
2046 (system* #$(file-append udev "/bin/udevadm")
2047 "settle")
2048 pid)))
2049 (stop #~(make-kill-destructor))
2051 ;; When halting the system, 'udev' is actually killed by
2052 ;; 'user-processes', i.e., before its own 'stop' method was called.
2053 ;; Thus, make sure it is not respawned.
2054 (respawn? #f)
2055 ;; We need additional modules.
2056 (modules `((gnu build linux-boot)
2057 ,@%default-modules))
2059 (actions (list (shepherd-action
2060 (name 'rules)
2061 (documentation "Display the directory containing
2062 the udev rules in use.")
2063 (procedure #~(lambda (_)
2064 (display #$rules)
2065 (newline))))))))))))
2067 (define udev-service-type
2068 (service-type (name 'udev)
2069 (extensions
2070 (list (service-extension shepherd-root-service-type
2071 udev-shepherd-service)))
2073 (compose concatenate) ;concatenate the list of rules
2074 (extend (lambda (config rules)
2075 (match config
2076 (($ <udev-configuration> udev initial-rules)
2077 (udev-configuration
2078 (udev udev)
2079 (rules (append initial-rules rules)))))))
2080 (default-value (udev-configuration))
2081 (description
2082 "Run @command{udev}, which populates the @file{/dev}
2083 directory dynamically. Get extra rules from the packages listed in the
2084 @code{rules} field of its value, @code{udev-configuration} object.")))
2086 (define* (udev-service #:key (udev eudev) (rules '()))
2087 "Run @var{udev}, which populates the @file{/dev} directory dynamically. Get
2088 extra rules from the packages listed in @var{rules}."
2089 (service udev-service-type
2090 (udev-configuration (udev udev) (rules rules))))
2092 (define swap-service-type
2093 (shepherd-service-type
2094 'swap
2095 (lambda (device)
2096 (define requirement
2097 (if (string-prefix? "/dev/mapper/" device)
2098 (list (symbol-append 'device-mapping-
2099 (string->symbol (basename device))))
2100 '()))
2102 (shepherd-service
2103 (provision (list (symbol-append 'swap- (string->symbol device))))
2104 (requirement `(udev ,@requirement))
2105 (documentation "Enable the given swap device.")
2106 (start #~(lambda ()
2107 (restart-on-EINTR (swapon #$device))
2108 #t))
2109 (stop #~(lambda _
2110 (restart-on-EINTR (swapoff #$device))
2111 #f))
2112 (respawn? #f)))))
2114 (define (swap-service device)
2115 "Return a service that uses @var{device} as a swap device."
2116 (service swap-service-type device))
2118 (define %default-gpm-options
2119 ;; Default options for GPM.
2120 '("-m" "/dev/input/mice" "-t" "ps2"))
2122 (define-record-type* <gpm-configuration>
2123 gpm-configuration make-gpm-configuration gpm-configuration?
2124 (gpm gpm-configuration-gpm ;package
2125 (default gpm))
2126 (options gpm-configuration-options ;list of strings
2127 (default %default-gpm-options)))
2129 (define gpm-shepherd-service
2130 (match-lambda
2131 (($ <gpm-configuration> gpm options)
2132 (list (shepherd-service
2133 (requirement '(udev))
2134 (provision '(gpm))
2135 (start #~(lambda ()
2136 ;; 'gpm' runs in the background and sets a PID file.
2137 ;; Note that it requires running as "root".
2138 (false-if-exception (delete-file "/var/run/gpm.pid"))
2139 (fork+exec-command (list #$(file-append gpm "/sbin/gpm")
2140 #$@options))
2142 ;; Wait for the PID file to appear; declare failure if
2143 ;; it doesn't show up.
2144 (let loop ((i 3))
2145 (or (file-exists? "/var/run/gpm.pid")
2146 (if (zero? i)
2147 #f
2148 (begin
2149 (sleep 1)
2150 (loop (1- i))))))))
2152 (stop #~(lambda (_)
2153 ;; Return #f if successfully stopped.
2154 (not (zero? (system* #$(file-append gpm "/sbin/gpm")
2155 "-k"))))))))))
2157 (define gpm-service-type
2158 (service-type (name 'gpm)
2159 (extensions
2160 (list (service-extension shepherd-root-service-type
2161 gpm-shepherd-service)))
2162 (default-value (gpm-configuration))
2163 (description
2164 "Run GPM, the general-purpose mouse daemon, with the given
2165 command-line options. GPM allows users to use the mouse in the console,
2166 notably to select, copy, and paste text. The default options use the
2167 @code{ps2} protocol, which works for both USB and PS/2 mice.")))
2169 (define-deprecated (gpm-service #:key (gpm gpm)
2170 (options %default-gpm-options))
2171 gpm-service-type
2172 "Run @var{gpm}, the general-purpose mouse daemon, with the given
2173 command-line @var{options}. GPM allows users to use the mouse in the console,
2174 notably to select, copy, and paste text. The default value of @var{options}
2175 uses the @code{ps2} protocol, which works for both USB and PS/2 mice.
2177 This service is not part of @var{%base-services}."
2178 ;; To test in QEMU, use "-usbdevice mouse" and then, in the monitor, use
2179 ;; "info mice" and "mouse_set X" to use the right mouse.
2180 (service gpm-service-type
2181 (gpm-configuration (gpm gpm) (options options))))
2183 (define-record-type* <kmscon-configuration>
2184 kmscon-configuration make-kmscon-configuration
2185 kmscon-configuration?
2186 (kmscon kmscon-configuration-kmscon
2187 (default kmscon))
2188 (virtual-terminal kmscon-configuration-virtual-terminal)
2189 (login-program kmscon-configuration-login-program
2190 (default (file-append shadow "/bin/login")))
2191 (login-arguments kmscon-configuration-login-arguments
2192 (default '("-p")))
2193 (auto-login kmscon-configuration-auto-login
2194 (default #f))
2195 (hardware-acceleration? kmscon-configuration-hardware-acceleration?
2196 (default #f))) ; #t causes failure
2198 (define kmscon-service-type
2199 (shepherd-service-type
2200 'kmscon
2201 (lambda (config)
2202 (let ((kmscon (kmscon-configuration-kmscon config))
2203 (virtual-terminal (kmscon-configuration-virtual-terminal config))
2204 (login-program (kmscon-configuration-login-program config))
2205 (login-arguments (kmscon-configuration-login-arguments config))
2206 (auto-login (kmscon-configuration-auto-login config))
2207 (hardware-acceleration? (kmscon-configuration-hardware-acceleration? config)))
2209 (define kmscon-command
2210 #~(list
2211 #$(file-append kmscon "/bin/kmscon") "--login"
2212 "--vt" #$virtual-terminal
2213 "--no-switchvt" ;Prevent a switch to the virtual terminal.
2214 #$@(if hardware-acceleration? '("--hwaccel") '())
2215 "--login" "--"
2216 #$login-program #$@login-arguments
2217 #$@(if auto-login
2218 #~(#$auto-login)
2219 #~())))
2221 (shepherd-service
2222 (documentation "kmscon virtual terminal")
2223 (requirement '(user-processes udev dbus-system))
2224 (provision (list (symbol-append 'term- (string->symbol virtual-terminal))))
2225 (start #~(make-forkexec-constructor #$kmscon-command))
2226 (stop #~(make-kill-destructor)))))))
2228 (define-record-type* <static-networking>
2229 static-networking make-static-networking
2230 static-networking?
2231 (interface static-networking-interface)
2232 (ip static-networking-ip)
2233 (netmask static-networking-netmask
2234 (default #f))
2235 (gateway static-networking-gateway ;FIXME: doesn't belong here
2236 (default #f))
2237 (provision static-networking-provision
2238 (default #f))
2239 (requirement static-networking-requirement
2240 (default '()))
2241 (name-servers static-networking-name-servers ;FIXME: doesn't belong here
2242 (default '())))
2244 (define static-networking-shepherd-service
2245 (match-lambda
2246 (($ <static-networking> interface ip netmask gateway provision
2247 requirement name-servers)
2248 (let ((loopback? (and provision (memq 'loopback provision))))
2249 (shepherd-service
2251 (documentation
2252 "Bring up the networking interface using a static IP address.")
2253 (requirement requirement)
2254 (provision (or provision
2255 (list (symbol-append 'networking-
2256 (string->symbol interface)))))
2258 (start #~(lambda _
2259 ;; Return #t if successfully started.
2260 (let* ((addr (inet-pton AF_INET #$ip))
2261 (sockaddr (make-socket-address AF_INET addr 0))
2262 (mask (and #$netmask
2263 (inet-pton AF_INET #$netmask)))
2264 (maskaddr (and mask
2265 (make-socket-address AF_INET
2266 mask 0)))
2267 (gateway (and #$gateway
2268 (inet-pton AF_INET #$gateway)))
2269 (gatewayaddr (and gateway
2270 (make-socket-address AF_INET
2271 gateway 0))))
2272 (configure-network-interface #$interface sockaddr
2273 (logior IFF_UP
2274 #$(if loopback?
2275 #~IFF_LOOPBACK
2276 0))
2277 #:netmask maskaddr)
2278 (when gateway
2279 (let ((sock (socket AF_INET SOCK_DGRAM 0)))
2280 (add-network-route/gateway sock gatewayaddr)
2281 (close-port sock))))))
2282 (stop #~(lambda _
2283 ;; Return #f is successfully stopped.
2284 (let ((sock (socket AF_INET SOCK_STREAM 0)))
2285 (when #$gateway
2286 (delete-network-route sock
2287 (make-socket-address
2288 AF_INET INADDR_ANY 0)))
2289 (set-network-interface-flags sock #$interface 0)
2290 (close-port sock)
2291 #f)))
2292 (respawn? #f))))))
2294 (define (static-networking-etc-files interfaces)
2295 "Return a /etc/resolv.conf entry for INTERFACES or the empty list."
2296 (match (delete-duplicates
2297 (append-map static-networking-name-servers
2298 interfaces))
2299 (()
2300 '())
2301 ((name-servers ...)
2302 (let ((content (string-join
2303 (map (cut string-append "nameserver " <>)
2304 name-servers)
2305 "\n" 'suffix)))
2306 `(("resolv.conf"
2307 ,(plain-file "resolv.conf"
2308 (string-append "\
2309 # Generated by 'static-networking-service'.\n"
2310 content))))))))
2312 (define (static-networking-shepherd-services interfaces)
2313 "Return the list of Shepherd services to bring up INTERFACES, a list of
2314 <static-networking> objects."
2315 (define (loopback? service)
2316 (memq 'loopback (shepherd-service-provision service)))
2318 (let ((services (map static-networking-shepherd-service interfaces)))
2319 (match (remove loopback? services)
2320 (()
2321 ;; There's no interface other than 'loopback', so we assume that the
2322 ;; 'networking' service will be provided by dhclient or similar.
2323 services)
2324 ((non-loopback ...)
2325 ;; Assume we're providing all the interfaces, and thus, provide a
2326 ;; 'networking' service.
2327 (cons (shepherd-service
2328 (provision '(networking))
2329 (requirement (append-map shepherd-service-provision
2330 services))
2331 (start #~(const #t))
2332 (stop #~(const #f))
2333 (documentation "Bring up all the networking interfaces."))
2334 services)))))
2336 (define static-networking-service-type
2337 ;; The service type for statically-defined network interfaces.
2338 (service-type (name 'static-networking)
2339 (extensions
2340 (list
2341 (service-extension shepherd-root-service-type
2342 static-networking-shepherd-services)
2343 (service-extension etc-service-type
2344 static-networking-etc-files)))
2345 (compose concatenate)
2346 (extend append)
2347 (description
2348 "Turn up the specified network interfaces upon startup,
2349 with the given IP address, gateway, netmask, and so on. The value for
2350 services of this type is a list of @code{static-networking} objects, one per
2351 network interface.")))
2353 (define* (static-networking-service interface ip
2354 #:key
2355 netmask gateway provision
2356 ;; Most interfaces require udev to be usable.
2357 (requirement '(udev))
2358 (name-servers '()))
2359 "Return a service that starts @var{interface} with address @var{ip}. If
2360 @var{netmask} is true, use it as the network mask. If @var{gateway} is true,
2361 it must be a string specifying the default network gateway.
2363 This procedure can be called several times, one for each network
2364 interface of interest. Behind the scenes what it does is extend
2365 @code{static-networking-service-type} with additional network interfaces
2366 to handle."
2367 (simple-service 'static-network-interface
2368 static-networking-service-type
2369 (list (static-networking (interface interface) (ip ip)
2370 (netmask netmask) (gateway gateway)
2371 (provision provision)
2372 (requirement requirement)
2373 (name-servers name-servers)))))
2375 \f
2376 (define %base-services
2377 ;; Convenience variable holding the basic services.
2378 (list (service login-service-type)
2380 (service virtual-terminal-service-type)
2381 (service console-font-service-type
2382 (map (lambda (tty)
2383 (cons tty %default-console-font))
2384 '("tty1" "tty2" "tty3" "tty4" "tty5" "tty6")))
2386 (service agetty-service-type (agetty-configuration
2387 (extra-options '("-L")) ; no carrier detect
2388 (term "vt100")
2389 (tty #f))) ; automatic
2391 (service mingetty-service-type (mingetty-configuration
2392 (tty "tty1")))
2393 (service mingetty-service-type (mingetty-configuration
2394 (tty "tty2")))
2395 (service mingetty-service-type (mingetty-configuration
2396 (tty "tty3")))
2397 (service mingetty-service-type (mingetty-configuration
2398 (tty "tty4")))
2399 (service mingetty-service-type (mingetty-configuration
2400 (tty "tty5")))
2401 (service mingetty-service-type (mingetty-configuration
2402 (tty "tty6")))
2404 (service static-networking-service-type
2405 (list (static-networking (interface "lo")
2406 (ip "127.0.0.1")
2407 (requirement '())
2408 (provision '(loopback)))))
2409 (syslog-service)
2410 (service urandom-seed-service-type)
2411 (service guix-service-type)
2412 (service nscd-service-type)
2414 ;; The LVM2 rules are needed as soon as LVM2 or the device-mapper is
2415 ;; used, so enable them by default. The FUSE and ALSA rules are
2416 ;; less critical, but handy.
2417 (service udev-service-type
2418 (udev-configuration
2419 (rules (list lvm2 fuse alsa-utils crda))))
2421 (service special-files-service-type
2422 `(("/bin/sh" ,(file-append (canonical-package bash)
2423 "/bin/sh"))))))
2425 ;;; base.scm ends here