1 ;;; GNU Guix --- Functional package management for GNU
2 ;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020 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 ;;; Copyright © 2019 Tobias Geerinckx-Rice <me@tobias.gr>
12 ;;; Copyright © 2019 John Soo <jsoo1@asu.edu>
13 ;;; Copyright © 2019 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
14 ;;; Copyright © 2020 Florian Pelz <pelzflorian@pelzflorian.de>
15 ;;; Copyright © 2020 Brice Waegeneire <brice@waegenei.re>
17 ;;; This file is part of GNU Guix.
19 ;;; GNU Guix is free software; you can redistribute it and/or modify it
20 ;;; under the terms of the GNU General Public License as published by
21 ;;; the Free Software Foundation; either version 3 of the License, or (at
22 ;;; your option) any later version.
24 ;;; GNU Guix is distributed in the hope that it will be useful, but
25 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
26 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
27 ;;; GNU General Public License for more details.
29 ;;; You should have received a copy of the GNU General Public License
30 ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
32 (define-module (gnu services base)
33 #:use-module (guix store)
34 #:use-module (guix deprecation)
35 #:use-module (gnu services)
36 #:use-module (gnu services admin)
37 #:use-module (gnu services shepherd)
38 #:use-module (gnu system pam)
39 #:use-module (gnu system shadow) ; 'user-account', etc.
40 #:use-module (gnu system uuid)
41 #:use-module (gnu system file-systems) ; 'file-system', etc.
42 #:use-module (gnu system mapped-devices)
43 #:use-module ((gnu system linux-initrd)
44 #:select (file-system-packages))
45 #:use-module (gnu packages admin)
46 #:use-module ((gnu packages linux)
47 #:select (alsa-utils crda eudev e2fsprogs fuse gpm kbd lvm2 rng-tools))
48 #:use-module (gnu packages bash)
49 #:use-module ((gnu packages base)
50 #:select (coreutils glibc glibc-utf8-locales))
51 #:use-module (gnu packages package-management)
52 #:use-module ((gnu packages gnupg) #:select (guile-gcrypt))
53 #:use-module (gnu packages linux)
54 #:use-module (gnu packages terminals)
55 #:use-module ((gnu build file-systems)
56 #:select (mount-flags->bit-mask))
57 #:use-module (guix gexp)
58 #:use-module (guix records)
59 #:use-module (guix modules)
60 #:use-module ((guix self) #:select (make-config.scm))
61 #:use-module (srfi srfi-1)
62 #:use-module (srfi srfi-26)
63 #:use-module (ice-9 match)
64 #:use-module (ice-9 format)
65 #:re-export (user-processes-service-type) ;backwards compatibility
66 #:export (fstab-service-type
67 root-file-system-service
68 file-system-service-type
71 console-keymap-service
73 console-font-service-type
75 virtual-terminal-service-type
80 static-networking-interface
82 static-networking-netmask
83 static-networking-gateway
84 static-networking-requirement
86 static-networking-service
87 static-networking-service-type
91 udev-configuration-rules
104 agetty-configuration?
108 mingetty-configuration
109 mingetty-configuration?
111 mingetty-service-type
114 %nscd-default-configuration
126 syslog-configuration?
131 %default-authorized-guix-keys
135 guix-configuration-guix
136 guix-configuration-build-group
137 guix-configuration-build-accounts
138 guix-configuration-authorize-key?
139 guix-configuration-authorized-keys
140 guix-configuration-use-substitutes?
141 guix-configuration-substitute-urls
142 guix-configuration-extra-options
143 guix-configuration-log-file
147 guix-publish-configuration
148 guix-publish-configuration?
149 guix-publish-configuration-guix
150 guix-publish-configuration-port
151 guix-publish-configuration-host
152 guix-publish-configuration-compression
153 guix-publish-configuration-compression-level ;deprecated
154 guix-publish-configuration-nar-path
155 guix-publish-configuration-cache
156 guix-publish-configuration-ttl
158 guix-publish-service-type
165 urandom-seed-service-type
174 kmscon-configuration?
177 pam-limits-service-type
186 ;;; Base system services---i.e., services that 99% of the users will want to
197 (define (file-system->fstab-entry file-system)
198 "Return a @file{/etc/fstab} entry for @var{file-system}."
199 (string-append (match (file-system-device file-system)
200 ((? file-system-label? label)
201 (string-append "LABEL="
202 (file-system-label->string label)))
204 (string-append "UUID=" (uuid->string uuid)))
208 (file-system-mount-point file-system) "\t"
209 (file-system-type file-system) "\t"
210 (or (file-system-options file-system) "defaults") "\t"
212 ;; XXX: Omit the 'fs_freq' and 'fs_passno' fields because we
213 ;; don't have anything sensible to put in there.
216 (define (file-systems->fstab file-systems)
217 "Return a @file{/etc} entry for an @file{fstab} describing
219 `(("fstab" ,(plain-file "fstab"
222 # This file was generated from your Guix configuration. Any changes
223 # will be lost upon reboot or reconfiguration.\n\n"
224 (string-join (map file-system->fstab-entry
229 (define fstab-service-type
230 ;; The /etc/fstab service.
231 (service-type (name 'fstab)
233 (list (service-extension etc-service-type
234 file-systems->fstab)))
235 (compose concatenate)
238 "Populate the @file{/etc/fstab} based on the given file
241 (define %root-file-system-shepherd-service
243 (documentation "Take care of the root file system.")
244 (provision '(root-file-system))
247 ;; Return #f if successfully stopped.
250 (call-with-blocked-asyncs
252 (let ((null (%make-void-port "w")))
253 ;; Close 'shepherd.log'.
254 (display "closing log\n")
255 ((@ (shepherd comm) stop-logging))
257 ;; Redirect the default output ports..
258 (set-current-output-port null)
259 (set-current-error-port null)
261 ;; Close /dev/console.
262 (for-each close-fdes '(0 1 2))
264 ;; At this point, there are no open files left, so the
265 ;; root file system can be re-mounted read-only.
267 (logior MS_REMOUNT MS_RDONLY)
273 (define root-file-system-service-type
274 (shepherd-service-type 'root-file-system
275 (const %root-file-system-shepherd-service)))
277 (define (root-file-system-service)
278 "Return a service whose sole purpose is to re-mount read-only the root file
279 system upon shutdown (aka. cleanly \"umounting\" root.)
281 This service must be the root of the service dependency graph so that its
282 'stop' action is invoked when shepherd is the only process left."
283 (service root-file-system-service-type #f))
285 (define (file-system->shepherd-service-name file-system)
286 "Return the symbol that denotes the service mounting and unmounting
288 (symbol-append 'file-system-
289 (string->symbol (file-system-mount-point file-system))))
291 (define (mapped-device->shepherd-service-name md)
292 "Return the symbol that denotes the shepherd service of MD, a <mapped-device>."
293 (symbol-append 'device-mapping-
294 (string->symbol (mapped-device-target md))))
296 (define dependency->shepherd-service-name
298 ((? mapped-device? md)
299 (mapped-device->shepherd-service-name md))
301 (file-system->shepherd-service-name fs))))
303 (define (file-system-shepherd-service file-system)
304 "Return the shepherd service for @var{file-system}, or @code{#f} if
305 @var{file-system} is not auto-mounted upon boot."
306 (let ((target (file-system-mount-point file-system))
307 (create? (file-system-create-mount-point? file-system))
308 (dependencies (file-system-dependencies file-system))
309 (packages (file-system-packages (list file-system))))
310 (and (file-system-mount? file-system)
311 (with-imported-modules (source-module-closure
312 '((gnu build file-systems)))
314 (provision (list (file-system->shepherd-service-name file-system)))
315 (requirement `(root-file-system udev
316 ,@(map dependency->shepherd-service-name dependencies)))
317 (documentation "Check, mount, and unmount the given file system.")
318 (start #~(lambda args
323 (let (($PATH (getenv "PATH")))
324 ;; Make sure fsck.ext2 & co. can be found.
327 ;; Don’t display the PATH settings.
328 (with-output-to-port (%make-void-port "w")
330 (set-path-environment-variable "PATH"
336 '#$(file-system->spec file-system))
339 (setenv "PATH" $PATH)))
342 ;; Normally there are no processes left at this point, so
343 ;; TARGET can be safely unmounted.
345 ;; Make sure PID 1 doesn't keep TARGET busy.
351 ;; We need additional modules.
352 (modules `(((gnu build file-systems)
353 #:select (mount-file-system))
354 (gnu system file-systems)
355 ,@%default-modules)))))))
357 (define (file-system-shepherd-services file-systems)
358 "Return the list of Shepherd services for FILE-SYSTEMS."
359 (let* ((file-systems (filter file-system-mount? file-systems)))
362 (provision '(file-systems))
363 (requirement (cons* 'root-file-system 'user-file-systems
364 (map file-system->shepherd-service-name
366 (documentation "Target for all the initially-mounted file systems")
368 (stop #~(const #f))))
370 (define known-mount-points
371 (map file-system-mount-point file-systems))
375 (documentation "Unmount manually-mounted file systems.")
376 (provision '(user-file-systems))
379 (define (known? mount-point)
381 (cons* "/proc" "/sys" '#$known-mount-points)))
383 ;; Make sure we don't keep the user's mount points busy.
386 (for-each (lambda (mount-point)
387 (format #t "unmounting '~a'...~%" mount-point)
390 (umount mount-point))
392 (let ((errno (system-error-errno args)))
393 (format #t "failed to unmount '~a': ~a~%"
394 mount-point (strerror errno))))))
395 (filter (negate known?) (mount-points)))
398 (cons* sink user-unmount
399 (map file-system-shepherd-service file-systems))))
401 (define (file-system-fstab-entries file-systems)
402 "Return the subset of @var{file-systems} that should have an entry in
404 ;; /etc/fstab is about telling fsck(8), mount(8), and umount(8) about
405 ;; relevant file systems they'll have to deal with. That excludes "pseudo"
408 ;; In particular, things like GIO (part of GLib) use it to determine the set
409 ;; of mounts, which is then used by graphical file managers and desktop
410 ;; environments to display "volume" icons. Thus, we really need to exclude
411 ;; those pseudo file systems from the list.
412 (remove (lambda (file-system)
413 (or (member (file-system-type file-system)
414 %pseudo-file-system-types)
415 (memq 'bind-mount (file-system-flags file-system))))
418 (define file-system-service-type
419 (service-type (name 'file-systems)
421 (list (service-extension shepherd-root-service-type
422 file-system-shepherd-services)
423 (service-extension fstab-service-type
424 file-system-fstab-entries)
426 ;; Have 'user-processes' depend on 'file-systems'.
427 (service-extension user-processes-service-type
428 (const '(file-systems)))))
429 (compose concatenate)
432 "Provide Shepherd services to mount and unmount the given
433 file systems, as well as corresponding @file{/etc/fstab} entries.")))
438 ;;; Preserve entropy to seed /dev/urandom on boot.
441 (define %random-seed-file
442 "/var/lib/random-seed")
444 (define (urandom-seed-shepherd-service _)
445 "Return a shepherd service for the /dev/urandom seed."
446 (list (shepherd-service
447 (documentation "Preserve entropy across reboots for /dev/urandom.")
448 (provision '(urandom-seed))
450 ;; Depend on udev so that /dev/hwrng is available.
451 (requirement '(file-systems udev))
454 ;; On boot, write random seed into /dev/urandom.
455 (when (file-exists? #$%random-seed-file)
456 (call-with-input-file #$%random-seed-file
458 (call-with-output-file "/dev/urandom"
460 (dump-port seed urandom)
462 ;; Writing SEED to URANDOM isn't enough: we must
463 ;; also tell the kernel to account for these
464 ;; extra bits of entropy.
465 (let ((bits (* 8 (stat:size (stat seed)))))
466 (add-to-entropy-count urandom bits)))))))
468 ;; Try writing from /dev/hwrng into /dev/urandom.
469 ;; It seems that the file /dev/hwrng always exists, even
470 ;; when there is no hardware random number generator
471 ;; available. So, we handle a failed read or any other error
472 ;; reported by the operating system.
473 (let ((buf (catch 'system-error
475 (call-with-input-file "/dev/hwrng"
477 (get-bytevector-n hwrng 512))))
478 ;; Silence is golden...
481 (call-with-output-file "/dev/urandom"
483 (put-bytevector urandom buf)
484 (let ((bits (* 8 (bytevector-length buf))))
485 (add-to-entropy-count urandom bits))))))
487 ;; Immediately refresh the seed in case the system doesn't
488 ;; shut down cleanly.
489 (call-with-input-file "/dev/urandom"
491 (let ((previous-umask (umask #o077))
492 (buf (make-bytevector 512)))
493 (mkdir-p (dirname #$%random-seed-file))
494 (get-bytevector-n! urandom buf 0 512)
495 (call-with-output-file #$%random-seed-file
497 (put-bytevector seed buf)))
498 (umask previous-umask))))
501 ;; During shutdown, write from /dev/urandom into random seed.
502 (let ((buf (make-bytevector 512)))
503 (call-with-input-file "/dev/urandom"
505 (let ((previous-umask (umask #o077)))
506 (get-bytevector-n! urandom buf 0 512)
507 (mkdir-p (dirname #$%random-seed-file))
508 (call-with-output-file #$%random-seed-file
510 (put-bytevector seed buf)))
511 (umask previous-umask))
513 (modules `((rnrs bytevectors)
515 ,@%default-modules)))))
517 (define urandom-seed-service-type
518 (service-type (name 'urandom-seed)
520 (list (service-extension shepherd-root-service-type
521 urandom-seed-shepherd-service)
523 ;; Have 'user-processes' depend on 'urandom-seed'.
524 ;; This ensures that user processes and daemons don't
525 ;; start until we have seeded the PRNG.
526 (service-extension user-processes-service-type
527 (const '(urandom-seed)))))
530 "Seed the @file{/dev/urandom} pseudo-random number
531 generator (RNG) with the value recorded when the system was last shut
534 (define-deprecated (urandom-seed-service)
535 urandom-seed-service-type
536 (service urandom-seed-service-type))
540 ;;; Add hardware random number generator to entropy pool.
543 (define-record-type* <rngd-configuration>
544 rngd-configuration make-rngd-configuration
546 (rng-tools rngd-configuration-rng-tools) ;package
547 (device rngd-configuration-device)) ;string
549 (define rngd-service-type
550 (shepherd-service-type
553 (define rng-tools (rngd-configuration-rng-tools config))
554 (define device (rngd-configuration-device config))
557 (list (file-append rng-tools "/sbin/rngd")
561 (documentation "Add TRNG to entropy pool.")
562 (requirement '(udev))
564 (start #~(make-forkexec-constructor '#$rngd-command))
565 (stop #~(make-kill-destructor))))))
567 (define* (rngd-service #:key
568 (rng-tools rng-tools)
569 (device "/dev/hwrng"))
570 "Return a service that runs the @command{rngd} program from @var{rng-tools}
571 to add @var{device} to the kernel's entropy pool. The service will fail if
572 @var{device} does not exist."
573 (service rngd-service-type
575 (rng-tools rng-tools)
583 (define host-name-service-type
584 (shepherd-service-type
588 (documentation "Initialize the machine's host name.")
589 (provision '(host-name))
591 (sethostname #$name)))
594 (define (host-name-service name)
595 "Return a service that sets the host name to @var{name}."
596 (service host-name-service-type name))
598 (define virtual-terminal-service-type
599 ;; Ensure that virtual terminals run in UTF-8 mode. This is the case by
600 ;; default with recent Linux kernels, but this service allows us to ensure
601 ;; this. This service must start before any 'term-' service so that newly
602 ;; created terminals inherit this property. See
603 ;; <https://bugs.gnu.org/30505> for a discussion.
604 (shepherd-service-type
607 (let ((knob "/sys/module/vt/parameters/default_utf8"))
609 (documentation "Set virtual terminals in UTF-8 module.")
610 (provision '(virtual-terminal))
611 (requirement '(root-file-system))
613 ;; In containers /sys is read-only so don't insist on
614 ;; writing to this file.
615 (unless (= 1 (call-with-input-file #$knob read))
616 (call-with-output-file #$knob
620 (stop #~(const #f)))))
621 #t)) ;default to UTF-8
623 (define console-keymap-service-type
624 (shepherd-service-type
628 (documentation (string-append "Load console keymap (loadkeys)."))
629 (provision '(console-keymap))
631 (zero? (system* #$(file-append kbd "/bin/loadkeys")
635 (define-deprecated (console-keymap-service #:rest files)
637 "Return a service to load console keymaps from @var{files}."
638 (service console-keymap-service-type files))
640 (define %default-console-font
641 ;; Note: 'LatGrkCyr-8x16' has the advantage of providing three common
642 ;; scripts as well as glyphs for em dash, quotation marks, and other Unicode
643 ;; codepoints notably found in the UTF-8 manual.
646 (define (console-font-shepherd-services tty+font)
647 "Return a list of Shepherd services for each pair in TTY+FONT."
650 (let ((device (string-append "/dev/" tty)))
652 (documentation "Load a Unicode console font.")
653 (provision (list (symbol-append 'console-font-
654 (string->symbol tty))))
656 ;; Start after mingetty has been started on TTY, otherwise the settings
658 (requirement (list (symbol-append 'term-
659 (string->symbol tty))))
662 ;; It could be that mingetty is not fully ready yet,
663 ;; which we check by calling 'ttyname'.
665 (unless (or (zero? i)
666 (call-with-input-file #$device
668 (false-if-exception (ttyname port)))))
672 ;; Assume the VT is already in UTF-8 mode, thanks to
673 ;; the 'virtual-terminal' service.
675 ;; 'setfont' returns EX_OSERR (71) when an
676 ;; KDFONTOP ioctl fails, for example. Like
677 ;; systemd's vconsole support, let's not treat
679 (case (status:exit-val
680 (system* #$(file-append kbd "/bin/setfont")
681 "-C" #$device #$font))
688 (define console-font-service-type
689 (service-type (name 'console-fonts)
691 (list (service-extension shepherd-root-service-type
692 console-font-shepherd-services)))
693 (compose concatenate)
696 "Install the given fonts on the specified ttys (fonts are per
697 virtual console on GNU/Linux). The value of this service is a list of
698 tty/font pairs. The font can be the name of a font provided by the @code{kbd}
699 package or any valid argument to @command{setfont}, as in this example:
702 `((\"tty1\" . \"LatGrkCyr-8x16\")
703 (\"tty2\" . ,(file-append
705 \"/share/kbd/consolefonts/TamzenForPowerline10x20.psf\"))
706 (\"tty3\" . ,(file-append
708 \"/share/consolefonts/ter-132n\"))) ; for HDPI
711 (define* (console-font-service tty #:optional (font "LatGrkCyr-8x16"))
712 "This procedure is deprecated in favor of @code{console-font-service-type}.
714 Return a service that sets up Unicode support in @var{tty} and loads
715 @var{font} for that tty (fonts are per virtual console in Linux.)"
716 (simple-service (symbol-append 'console-font- (string->symbol tty))
717 console-font-service-type `((,tty . ,font))))
719 (define %default-motd
720 (plain-file "motd" "This is the GNU operating system, welcome!\n\n"))
722 (define-record-type* <login-configuration>
723 login-configuration make-login-configuration
725 (motd login-configuration-motd ;file-like
726 (default %default-motd))
727 ;; Allow empty passwords by default so that first-time users can log in when
728 ;; the 'root' account has just been created.
729 (allow-empty-passwords? login-configuration-allow-empty-passwords?
730 (default #t))) ;Boolean
732 (define (login-pam-service config)
733 "Return the list of PAM service needed for CONF."
734 ;; Let 'login' be known to PAM.
735 (list (unix-pam-service "login"
737 #:allow-empty-passwords?
738 (login-configuration-allow-empty-passwords? config)
740 (login-configuration-motd config))))
742 (define login-service-type
743 (service-type (name 'login)
744 (extensions (list (service-extension pam-root-service-type
746 (default-value (login-configuration))
748 "Provide a console log-in service as specified by its
749 configuration value, a @code{login-configuration} object.")))
751 (define* (login-service #:optional (config (login-configuration)))
752 "Return a service configure login according to @var{config}, which specifies
753 the message of the day, among other things."
754 (service login-service-type config))
756 (define-record-type* <agetty-configuration>
757 agetty-configuration make-agetty-configuration
758 agetty-configuration?
759 (agetty agetty-configuration-agetty ;<package>
760 (default util-linux))
761 (tty agetty-configuration-tty) ;string | #f
762 (term agetty-term ;string | #f
764 (baud-rate agetty-baud-rate ;string | #f
766 (auto-login agetty-auto-login ;list of strings | #f
768 (login-program agetty-login-program ;gexp
769 (default (file-append shadow "/bin/login")))
770 (login-pause? agetty-login-pause? ;Boolean
772 (eight-bits? agetty-eight-bits? ;Boolean
774 (no-reset? agetty-no-reset? ;Boolean
776 (remote? agetty-remote? ;Boolean
778 (flow-control? agetty-flow-control? ;Boolean
780 (host agetty-host ;string | #f
782 (no-issue? agetty-no-issue? ;Boolean
784 (init-string agetty-init-string ;string | #f
786 (no-clear? agetty-no-clear? ;Boolean
788 (local-line agetty-local-line ;always | never | auto
790 (extract-baud? agetty-extract-baud? ;Boolean
792 (skip-login? agetty-skip-login? ;Boolean
794 (no-newline? agetty-no-newline? ;Boolean
796 (login-options agetty-login-options ;string | #f
798 (chroot agetty-chroot ;string | #f
800 (hangup? agetty-hangup? ;Boolean
802 (keep-baud? agetty-keep-baud? ;Boolean
804 (timeout agetty-timeout ;integer | #f
806 (detect-case? agetty-detect-case? ;Boolean
808 (wait-cr? agetty-wait-cr? ;Boolean
810 (no-hints? agetty-no-hints? ;Boolean
812 (no-hostname? agetty-no hostname? ;Boolean
814 (long-hostname? agetty-long-hostname? ;Boolean
816 (erase-characters agetty-erase-characters ;string | #f
818 (kill-characters agetty-kill-characters ;string | #f
820 (chdir agetty-chdir ;string | #f
822 (delay agetty-delay ;integer | #f
824 (nice agetty-nice ;integer | #f
826 ;; "Escape hatch" for passing arbitrary command-line arguments.
827 (extra-options agetty-extra-options ;list of strings
829 ;;; XXX Unimplemented for now!
830 ;;; (issue-file agetty-issue-file ;file-like
834 (define (default-serial-port)
835 "Return a gexp that determines a reasonable default serial port
836 to use as the tty. This is primarily useful for headless systems."
837 (with-imported-modules (source-module-closure
838 '((gnu build linux-boot))) ;for 'find-long-options'
840 ;; console=device,options
841 ;; device: can be tty0, ttyS0, lp0, ttyUSB0 (serial).
842 ;; options: BBBBPNF. P n|o|e, N number of bits,
843 ;; F flow control (r RTS)
844 (let* ((not-comma (char-set-complement (char-set #\,)))
845 (command (linux-command-line))
846 (agetty-specs (find-long-options "agetty.tty" command))
847 (console-specs (filter (lambda (spec)
848 (and (string-prefix? "tty" spec)
850 (string-prefix? "tty0" spec)
851 (string-prefix? "tty1" spec)
852 (string-prefix? "tty2" spec)
853 (string-prefix? "tty3" spec)
854 (string-prefix? "tty4" spec)
855 (string-prefix? "tty5" spec)
856 (string-prefix? "tty6" spec)
857 (string-prefix? "tty7" spec)
858 (string-prefix? "tty8" spec)
859 (string-prefix? "tty9" spec)))))
860 (find-long-options "console" command)))
861 (specs (append agetty-specs console-specs)))
865 ;; Extract device name from first spec.
866 (match (string-tokenize spec not-comma)
870 (define agetty-shepherd-service
872 (($ <agetty-configuration> agetty tty term baud-rate auto-login
873 login-program login-pause? eight-bits? no-reset? remote? flow-control?
874 host no-issue? init-string no-clear? local-line extract-baud?
875 skip-login? no-newline? login-options chroot hangup? keep-baud? timeout
876 detect-case? wait-cr? no-hints? no-hostname? long-hostname?
877 erase-characters kill-characters chdir delay nice extra-options)
880 (documentation "Run agetty on a tty.")
881 (provision (list (symbol-append 'term- (string->symbol (or tty "auto")))))
883 ;; Since the login prompt shows the host name, wait for the 'host-name'
884 ;; service to be done. Also wait for udev essentially so that the tty
885 ;; text is not lost in the middle of kernel messages (see also
886 ;; mingetty-shepherd-service).
887 (requirement '(user-processes host-name udev))
889 (modules '((ice-9 match) (gnu build linux-boot)))
891 (with-imported-modules (source-module-closure
892 '((gnu build linux-boot)))
894 (let ((defaulted-tty #$(or tty (default-serial-port))))
897 (make-forkexec-constructor
898 (list #$(file-append util-linux "/sbin/agetty")
919 #~("--init-string" #$init-string)
924 ;;; FIXME This doesn't work as expected. According to agetty(8), if this option
925 ;;; is not passed, then the default is 'auto'. However, in my tests, when that
926 ;;; option is selected, agetty never presents the login prompt, and the
927 ;;; term-ttyS0 service respawns every few seconds.
929 #~(#$(match local-line
930 ('auto "--local-line=auto")
931 ('always "--local-line=always")
932 ('never "-local-line=never")))
947 #~("--login-options" #$login-options)
950 #~("--chroot" #$chroot)
959 #~("--timeout" #$(number->string timeout))
973 #$@(if long-hostname?
974 #~("--long-hostname")
976 #$@(if erase-characters
977 #~("--erase-chars" #$erase-characters)
979 #$@(if kill-characters
980 #~("--kill-chars" #$kill-characters)
983 #~("--chdir" #$chdir)
986 #~("--delay" #$(number->string delay))
989 #~("--nice" #$(number->string nice))
992 (list "--autologin" auto-login)
995 #~("--login-program" #$login-program)
1007 (const #f)) ; never start.
1009 (stop #~(make-kill-destructor)))))))
1011 (define agetty-service-type
1012 (service-type (name 'agetty)
1013 (extensions (list (service-extension shepherd-root-service-type
1014 agetty-shepherd-service)))
1016 "Provide console login using the @command{agetty}
1019 (define* (agetty-service config)
1020 "Return a service to run agetty according to @var{config}, which specifies
1021 the tty to run, among other things."
1022 (service agetty-service-type config))
1024 (define-record-type* <mingetty-configuration>
1025 mingetty-configuration make-mingetty-configuration
1026 mingetty-configuration?
1027 (mingetty mingetty-configuration-mingetty ;<package>
1029 (tty mingetty-configuration-tty) ;string
1030 (auto-login mingetty-auto-login ;string | #f
1032 (login-program mingetty-login-program ;gexp
1034 (login-pause? mingetty-login-pause? ;Boolean
1037 (define mingetty-shepherd-service
1039 (($ <mingetty-configuration> mingetty tty auto-login login-program
1043 (documentation "Run mingetty on an tty.")
1044 (provision (list (symbol-append 'term- (string->symbol tty))))
1046 ;; Since the login prompt shows the host name, wait for the 'host-name'
1047 ;; service to be done. Also wait for udev essentially so that the tty
1048 ;; text is not lost in the middle of kernel messages (XXX).
1049 (requirement '(user-processes host-name udev virtual-terminal))
1051 (start #~(make-forkexec-constructor
1052 (list #$(file-append mingetty "/sbin/mingetty")
1055 ;; Avoiding 'vhangup' allows us to avoid 'setfont'
1056 ;; errors down the path where various ioctls get
1057 ;; EIO--see 'hung_up_tty_ioctl' in driver/tty/tty_io.c
1062 #~("--autologin" #$auto-login)
1064 #$@(if login-program
1065 #~("--loginprog" #$login-program)
1070 (stop #~(make-kill-destructor)))))))
1072 (define mingetty-service-type
1073 (service-type (name 'mingetty)
1074 (extensions (list (service-extension shepherd-root-service-type
1075 mingetty-shepherd-service)))
1077 "Provide console login using the @command{mingetty}
1080 (define* (mingetty-service config)
1081 "Return a service to run mingetty according to @var{config}, which specifies
1082 the tty to run, among other things."
1083 (service mingetty-service-type config))
1085 (define-record-type* <nscd-configuration> nscd-configuration
1086 make-nscd-configuration
1088 (log-file nscd-configuration-log-file ;string
1089 (default "/var/log/nscd.log"))
1090 (debug-level nscd-debug-level ;integer
1092 ;; TODO: See nscd.conf in glibc for other options to add.
1093 (caches nscd-configuration-caches ;list of <nscd-cache>
1094 (default %nscd-default-caches))
1095 (name-services nscd-configuration-name-services ;list of <packages>
1097 (glibc nscd-configuration-glibc ;<package>
1100 (define-record-type* <nscd-cache> nscd-cache make-nscd-cache
1102 (database nscd-cache-database) ;symbol
1103 (positive-time-to-live nscd-cache-positive-time-to-live) ;integer
1104 (negative-time-to-live nscd-cache-negative-time-to-live
1105 (default 20)) ;integer
1106 (suggested-size nscd-cache-suggested-size ;integer ("default module
1109 (check-files? nscd-cache-check-files? ;Boolean
1111 (persistent? nscd-cache-persistent? ;Boolean
1113 (shared? nscd-cache-shared? ;Boolean
1115 (max-database-size nscd-cache-max-database-size ;integer
1116 (default (* 32 (expt 2 20))))
1117 (auto-propagate? nscd-cache-auto-propagate? ;Boolean
1120 (define %nscd-default-caches
1121 ;; Caches that we want to enable by default. Note that when providing an
1122 ;; empty nscd.conf, all caches are disabled.
1123 (list (nscd-cache (database 'hosts)
1125 ;; Aggressively cache the host name cache to improve
1126 ;; privacy and resilience.
1127 (positive-time-to-live (* 3600 12))
1128 (negative-time-to-live 20)
1131 (nscd-cache (database 'services)
1133 ;; Services are unlikely to change, so we can be even more
1135 (positive-time-to-live (* 3600 24))
1136 (negative-time-to-live 3600)
1137 (check-files? #t) ;check /etc/services changes
1140 (define %nscd-default-configuration
1141 ;; Default nscd configuration.
1142 (nscd-configuration))
1144 (define (nscd.conf-file config)
1145 "Return the @file{nscd.conf} configuration file for @var{config}, an
1146 @code{<nscd-configuration>} object."
1147 (define cache->config
1149 (($ <nscd-cache> (= symbol->string database)
1150 positive-ttl negative-ttl size check-files?
1151 persistent? shared? max-size propagate?)
1152 (string-append "\nenable-cache\t" database "\tyes\n"
1154 "positive-time-to-live\t" database "\t"
1155 (number->string positive-ttl) "\n"
1156 "negative-time-to-live\t" database "\t"
1157 (number->string negative-ttl) "\n"
1158 "suggested-size\t" database "\t"
1159 (number->string size) "\n"
1160 "check-files\t" database "\t"
1161 (if check-files? "yes\n" "no\n")
1162 "persistent\t" database "\t"
1163 (if persistent? "yes\n" "no\n")
1164 "shared\t" database "\t"
1165 (if shared? "yes\n" "no\n")
1166 "max-db-size\t" database "\t"
1167 (number->string max-size) "\n"
1168 "auto-propagate\t" database "\t"
1169 (if propagate? "yes\n" "no\n")))))
1172 (($ <nscd-configuration> log-file debug-level caches)
1173 (plain-file "nscd.conf"
1175 # Configuration of libc's name service cache daemon (nscd).\n\n"
1177 (string-append "logfile\t" log-file)
1181 (string-append "debug-level\t"
1182 (number->string debug-level))
1186 (map cache->config caches)))))))
1188 (define (nscd-action-procedure nscd config option)
1189 ;; XXX: This is duplicated from mcron; factorize.
1190 #~(lambda (_ . args)
1191 ;; Run 'nscd' in a pipe so we can explicitly redirect its output to
1192 ;; 'current-output-port', which at this stage is bound to the client
1194 (let ((pipe (apply open-pipe* OPEN_READ #$nscd
1195 "-f" #$config #$option args)))
1197 (match (read-line pipe 'concat)
1199 (catch 'system-error
1201 (zero? (close-pipe pipe)))
1203 ;; There's a race with the SIGCHLD handler, which could
1204 ;; call 'waitpid' before 'close-pipe' above does. If we
1205 ;; get ECHILD, that means we lost the race; in that case, we
1206 ;; cannot tell what the exit code was (FIXME).
1207 (or (= ECHILD (system-error-errno args))
1208 (apply throw args)))))
1213 (define (nscd-actions nscd config)
1214 "Return Shepherd actions for NSCD."
1215 ;; Make this functionality available as actions because that's a simple way
1216 ;; to run the right 'nscd' binary with the right config file.
1217 (list (shepherd-action
1219 (documentation "Display statistics about nscd usage.")
1220 (procedure (nscd-action-procedure nscd config "--statistics")))
1224 "Invalidate the given cache--e.g., 'hosts' for host name lookups.")
1225 (procedure (nscd-action-procedure nscd config "--invalidate")))))
1227 (define (nscd-shepherd-service config)
1228 "Return a shepherd service for CONFIG, an <nscd-configuration> object."
1229 (let ((nscd (file-append (nscd-configuration-glibc config)
1231 (nscd.conf (nscd.conf-file config))
1232 (name-services (nscd-configuration-name-services config)))
1233 (list (shepherd-service
1234 (documentation "Run libc's name service cache daemon (nscd).")
1236 (requirement '(user-processes))
1237 (start #~(make-forkexec-constructor
1238 (list #$nscd "-f" #$nscd.conf "--foreground")
1240 ;; Wait for the PID file. However, the PID file is
1241 ;; written before nscd is actually listening on its
1243 #:pid-file "/var/run/nscd/nscd.pid"
1245 #:environment-variables
1246 (list (string-append "LD_LIBRARY_PATH="
1249 (string-append dir "/lib"))
1250 (list #$@name-services))
1252 (stop #~(make-kill-destructor))
1253 (modules `((ice-9 popen) ;for the actions
1256 ,@%default-modules))
1257 (actions (nscd-actions nscd nscd.conf))))))
1259 (define nscd-activation
1260 ;; Actions to take before starting nscd.
1262 (use-modules (guix build utils))
1263 (mkdir-p "/var/run/nscd")
1264 (mkdir-p "/var/db/nscd") ;for the persistent cache
1266 ;; In libc 2.25 nscd uses inotify to watch /etc/resolv.conf, but only if
1267 ;; that file exists when it is started. Thus create it here. Note: on
1268 ;; some systems, such as when NetworkManager is used, /etc/resolv.conf
1269 ;; is a symlink, hence 'lstat'.
1270 (unless (false-if-exception (lstat "/etc/resolv.conf"))
1271 (call-with-output-file "/etc/resolv.conf"
1273 (display "# This is a placeholder.\n" port))))))
1275 (define nscd-service-type
1276 (service-type (name 'nscd)
1278 (list (service-extension activation-service-type
1279 (const nscd-activation))
1280 (service-extension shepherd-root-service-type
1281 nscd-shepherd-service)))
1283 ;; This can be extended by providing additional name services
1284 ;; such as nss-mdns.
1285 (compose concatenate)
1286 (extend (lambda (config name-services)
1289 (name-services (append
1290 (nscd-configuration-name-services config)
1292 (default-value %nscd-default-configuration)
1294 "Runs libc's @dfn{name service cache daemon} (nscd) with the
1295 given configuration---an @code{<nscd-configuration>} object. @xref{Name
1296 Service Switch}, for an example.")))
1298 (define* (nscd-service #:optional (config %nscd-default-configuration))
1299 "Return a service that runs libc's name service cache daemon (nscd) with the
1300 given @var{config}---an @code{<nscd-configuration>} object. @xref{Name
1301 Service Switch}, for an example."
1302 (service nscd-service-type config))
1305 (define-record-type* <syslog-configuration>
1306 syslog-configuration make-syslog-configuration
1307 syslog-configuration?
1308 (syslogd syslog-configuration-syslogd
1309 (default (file-append inetutils "/libexec/syslogd")))
1310 (config-file syslog-configuration-config-file
1311 (default %default-syslog.conf)))
1313 (define syslog-service-type
1314 (shepherd-service-type
1318 (documentation "Run the syslog daemon (syslogd).")
1319 (provision '(syslogd))
1320 (requirement '(user-processes))
1321 (start #~(let ((spawn (make-forkexec-constructor
1322 (list #$(syslog-configuration-syslogd config)
1324 #$(syslog-configuration-config-file config))
1325 #:pid-file "/var/run/syslog.pid")))
1327 ;; Set the umask such that file permissions are #o640.
1328 (let ((mask (umask #o137))
1332 (stop #~(make-kill-destructor))))))
1334 ;; Snippet adapted from the GNU inetutils manual.
1335 (define %default-syslog.conf
1336 (plain-file "syslog.conf" "
1337 # Log all error messages, authentication messages of
1338 # level notice or higher and anything of level err or
1339 # higher to the console.
1340 # Don't log private authentication messages!
1341 *.alert;auth.notice;authpriv.none /dev/console
1343 # Log anything (except mail) of level info or higher.
1344 # Don't log private authentication messages!
1345 *.info;mail.none;authpriv.none /var/log/messages
1347 # Like /var/log/messages, but also including \"debug\"-level logs.
1348 *.debug;mail.none;authpriv.none /var/log/debug
1350 # Same, in a different place.
1351 *.info;mail.none;authpriv.none /dev/tty12
1353 # The authpriv file has restricted access.
1354 authpriv.* /var/log/secure
1356 # Log all the mail messages in one place.
1357 mail.* /var/log/maillog
1360 (define* (syslog-service #:optional (config (syslog-configuration)))
1361 "Return a service that runs @command{syslogd} and takes
1362 @var{<syslog-configuration>} as a parameter.
1364 @xref{syslogd invocation,,, inetutils, GNU Inetutils}, for more
1365 information on the configuration file syntax."
1366 (service syslog-service-type config))
1369 (define pam-limits-service-type
1370 (let ((security-limits
1371 ;; Create /etc/security containing the provided "limits.conf" file.
1372 (lambda (limits-file)
1378 (stat #$limits-file)
1379 (symlink #$limits-file
1380 (string-append #$output "/limits.conf"))))))))
1383 (let ((pam-limits (pam-entry
1384 (control "required")
1385 (module "pam_limits.so")
1386 (arguments '("conf=/etc/security/limits.conf")))))
1387 (if (member (pam-service-name pam)
1388 '("login" "su" "slim" "gdm-password" "sddm"))
1391 (session (cons pam-limits
1392 (pam-service-session pam))))
1397 (list (service-extension etc-service-type security-limits)
1398 (service-extension pam-root-service-type
1399 (lambda _ (list pam-extension)))))
1401 "Install the specified resource usage limits by populating
1402 @file{/etc/security/limits.conf} and using the @code{pam_limits}
1403 authentication module."))))
1405 (define* (pam-limits-service #:optional (limits '()))
1406 "Return a service that makes selected programs respect the list of
1407 pam-limits-entry specified in LIMITS via pam_limits.so."
1408 (service pam-limits-service-type
1409 (plain-file "limits.conf"
1410 (string-join (map pam-limits-entry->string limits)
1418 (define* (guix-build-accounts count #:key
1421 "Return a list of COUNT user accounts for Guix build users with the given
1423 (unfold (cut > <> count)
1426 (name (format #f "guixbuilder~2,'0d" n))
1430 ;; guix-daemon expects GROUP to be listed as a
1431 ;; supplementary group too:
1432 ;; <http://lists.gnu.org/archive/html/bug-guix/2013-01/msg00239.html>.
1433 (supplementary-groups (list group "kvm"))
1435 (comment (format #f "Guix Build User ~2d" n))
1436 (home-directory "/var/empty")
1437 (shell (file-append shadow "/sbin/nologin"))))
1442 ;; Select (guix …) and (gnu …) modules, except (guix config).
1444 (('guix 'config) #f)
1445 (('guix rest ...) #t)
1446 (('gnu rest ...) #t)
1449 (define (substitute-key-authorization keys guix)
1450 "Return a gexp with code to register KEYS, a list of files containing 'guix
1451 archive' public keys, with GUIX."
1453 (with-extensions (list guile-gcrypt)
1454 (with-imported-modules `(((guix config) => ,(make-config.scm))
1455 ,@(source-module-closure '((guix pki))
1456 #:select? not-config?))
1457 (computed-file "acl"
1459 (use-modules (guix pki)
1465 (call-with-input-file file
1466 (compose string->canonical-sexp
1470 (call-with-output-file #$output
1472 (write-acl (public-keys->acl keys)
1475 (with-imported-modules '((guix build utils))
1477 (use-modules (guix build utils))
1479 ;; If the ACL already exists, move it out of the way. Create a backup
1480 ;; if it's a regular file: it's likely that the user manually updated
1481 ;; it with 'guix archive --authorize'.
1482 (if (file-exists? "/etc/guix/acl")
1483 (if (and (symbolic-link? "/etc/guix/acl")
1484 (store-file-name? (readlink "/etc/guix/acl")))
1485 (delete-file "/etc/guix/acl")
1486 (rename-file "/etc/guix/acl" "/etc/guix/acl.bak"))
1487 (mkdir-p "/etc/guix"))
1489 ;; Installed the declared ACL.
1490 (symlink #+default-acl "/etc/guix/acl"))))
1492 (define %default-authorized-guix-keys
1493 ;; List of authorized substitute keys.
1494 (list (file-append guix "/share/guix/berlin.guix.gnu.org.pub")))
1496 (define-record-type* <guix-configuration>
1497 guix-configuration make-guix-configuration
1499 (guix guix-configuration-guix ;<package>
1501 (build-group guix-configuration-build-group ;string
1502 (default "guixbuild"))
1503 (build-accounts guix-configuration-build-accounts ;integer
1505 (authorize-key? guix-configuration-authorize-key? ;Boolean
1507 (authorized-keys guix-configuration-authorized-keys ;list of gexps
1508 (default %default-authorized-guix-keys))
1509 (use-substitutes? guix-configuration-use-substitutes? ;Boolean
1511 (substitute-urls guix-configuration-substitute-urls ;list of strings
1512 (default %default-substitute-urls))
1513 (chroot-directories guix-configuration-chroot-directories ;list of file-like/strings
1515 (max-silent-time guix-configuration-max-silent-time ;integer
1517 (timeout guix-configuration-timeout ;integer
1519 (log-compression guix-configuration-log-compression
1521 (extra-options guix-configuration-extra-options ;list of strings
1523 (log-file guix-configuration-log-file ;string
1524 (default "/var/log/guix-daemon.log"))
1525 (http-proxy guix-http-proxy ;string | #f
1527 (tmpdir guix-tmpdir ;string | #f
1530 (define %default-guix-configuration
1531 (guix-configuration))
1533 (define shepherd-set-http-proxy-action
1534 ;; Shepherd action to change the HTTP(S) proxy.
1536 (name 'set-http-proxy)
1538 "Change the HTTP(S) proxy used by 'guix-daemon' and restart it.")
1539 (procedure #~(lambda* (_ #:optional proxy)
1540 (let ((environment (environ)))
1541 ;; A bit of a hack: communicate PROXY to the 'start'
1542 ;; method via environment variables.
1545 (format #t "changing HTTP/HTTPS \
1546 proxy of 'guix-daemon' to ~s...~%"
1548 (setenv "http_proxy" proxy))
1550 (format #t "clearing HTTP/HTTPS \
1551 proxy of 'guix-daemon'...~%")
1552 (unsetenv "http_proxy")))
1553 (action 'guix-daemon 'restart)
1554 (environ environment)
1557 (define (guix-shepherd-service config)
1558 "Return a <shepherd-service> for the Guix daemon service with CONFIG."
1559 (match-record config <guix-configuration>
1560 (guix build-group build-accounts authorize-key? authorized-keys
1561 use-substitutes? substitute-urls max-silent-time timeout
1562 log-compression extra-options log-file http-proxy tmpdir
1564 (list (shepherd-service
1565 (documentation "Run the Guix daemon.")
1566 (provision '(guix-daemon))
1567 (requirement '(user-processes))
1568 (actions (list shepherd-set-http-proxy-action))
1569 (modules '((srfi srfi-1)
1571 (gnu build shepherd)))
1573 (with-imported-modules `(((guix config) => ,(make-config.scm))
1574 ,@(source-module-closure
1575 '((gnu build shepherd))
1576 #:select? not-config?))
1579 ;; HTTP/HTTPS proxy. The 'http_proxy' variable is set by
1580 ;; the 'set-http-proxy' action.
1581 (or (getenv "http_proxy") #$http-proxy))
1583 ;; Start the guix-daemon from a container, when supported,
1584 ;; to solve an installation issue. See the comment below for
1586 (fork+exec-command/container
1587 (cons* #$(file-append guix "/bin/guix-daemon")
1588 "--build-users-group" #$build-group
1590 #$(number->string max-silent-time)
1591 "--timeout" #$(number->string timeout)
1593 #$(symbol->string log-compression)
1594 #$@(if use-substitutes?
1596 '("--no-substitutes"))
1597 "--substitute-urls" #$(string-join substitute-urls)
1600 ;; Add CHROOT-DIRECTORIES and all their dependencies
1601 ;; (if these are store items) to the chroot.
1604 (append-map (lambda (directory)
1605 (list "--chroot-directory"
1607 (call-with-input-file file
1609 '#$(map references-file
1610 chroot-directories)))
1612 ;; When running the installer, we need guix-daemon to
1613 ;; operate from within the same MNT namespace as the
1614 ;; installation container. In that case only, enter the
1615 ;; namespace of the process PID passed as start argument.
1616 ;; Otherwise, for symmetry purposes enter the caller
1617 ;; namespaces which is a no-op.
1619 ((pid) (string->number pid))
1622 #:environment-variables
1623 (append (list #$@(if tmpdir
1624 (list (string-append "TMPDIR=" tmpdir))
1627 ;; Make sure we run in a UTF-8 locale so that
1628 ;; 'guix offload' correctly restores nars
1629 ;; that contain UTF-8 file names such as
1631 ;; <https://bugs.gnu.org/32942>.
1632 (string-append "GUIX_LOCPATH="
1633 #$glibc-utf8-locales
1635 "LC_ALL=en_US.utf8")
1637 (list (string-append "http_proxy=" proxy)
1638 (string-append "https_proxy=" proxy))
1641 #:log-file #$log-file))))
1642 (stop #~(make-kill-destructor))))))
1644 (define (guix-accounts config)
1645 "Return the user accounts and user groups for CONFIG."
1647 (($ <guix-configuration> _ build-group build-accounts)
1652 ;; Use a fixed GID so that we can create the store with the right
1655 (guix-build-accounts build-accounts
1656 #:group build-group)))))
1658 (define (guix-activation config)
1659 "Return the activation gexp for CONFIG."
1661 (($ <guix-configuration> guix build-group build-accounts authorize-key? keys)
1662 ;; Assume that the store has BUILD-GROUP as its group. We could
1663 ;; otherwise call 'chown' here, but the problem is that on a COW overlayfs,
1664 ;; chown leads to an entire copy of the tree, which is a bad idea.
1666 ;; Generate a key pair and optionally authorize substitute server keys.
1668 (unless (file-exists? "/etc/guix/signing-key.pub")
1669 (system* #$(file-append guix "/bin/guix") "archive"
1672 #$(if authorize-key?
1673 (substitute-key-authorization keys guix)
1676 (define* (references-file item #:optional (name "references"))
1677 "Return a file that contains the list of references of ITEM."
1678 (if (struct? item) ;lowerable object
1680 (with-imported-modules (source-module-closure
1681 '((guix build store-copy)))
1683 (use-modules (guix build store-copy))
1685 (call-with-output-file #$output
1687 (write (map store-info-item
1688 (call-with-input-file "graph"
1689 read-reference-graph))
1691 #:options `(#:local-build? #f
1692 #:references-graphs (("graph" ,item))))
1693 (plain-file name "()")))
1695 (define guix-service-type
1699 (list (service-extension shepherd-root-service-type guix-shepherd-service)
1700 (service-extension account-service-type guix-accounts)
1701 (service-extension activation-service-type guix-activation)
1702 (service-extension profile-service-type
1703 (compose list guix-configuration-guix))))
1705 ;; Extensions can specify extra directories to add to the build chroot.
1706 (compose concatenate)
1707 (extend (lambda (config directories)
1711 (append (guix-configuration-chroot-directories config)
1714 (default-value (guix-configuration))
1716 "Run the build daemon of GNU@tie{}Guix, aka. @command{guix-daemon}.")))
1718 (define-deprecated (guix-service #:optional
1719 (config %default-guix-configuration))
1721 "Return a service that runs the Guix build daemon according to
1723 (service guix-service-type config))
1726 (define-record-type* <guix-publish-configuration>
1727 guix-publish-configuration make-guix-publish-configuration
1728 guix-publish-configuration?
1729 (guix guix-publish-configuration-guix ;package
1731 (port guix-publish-configuration-port ;number
1733 (host guix-publish-configuration-host ;string
1734 (default "localhost"))
1735 (compression guix-publish-configuration-compression
1737 (default (default-compression this-record
1738 (current-source-location))))
1739 (compression-level %guix-publish-configuration-compression-level ;deprecated
1741 (nar-path guix-publish-configuration-nar-path ;string
1743 (cache guix-publish-configuration-cache ;#f | string
1745 (cache-bypass-threshold guix-publish-configuration-cache-bypass-threshold
1746 (default (* 10 (expt 2 20)))) ;integer
1747 (workers guix-publish-configuration-workers ;#f | integer
1749 (ttl guix-publish-configuration-ttl ;#f | integer
1752 (define-deprecated (guix-publish-configuration-compression-level config)
1753 "Return a compression level, the old way."
1754 (match (guix-publish-configuration-compression config)
1755 (((_ level) _ ...) level)))
1757 (define (default-compression config properties)
1758 "Return the default 'guix publish' compression according to CONFIG, and
1759 raise a deprecation warning if the 'compression-level' field was used."
1760 (match (%guix-publish-configuration-compression-level config)
1764 (warn-about-deprecation 'compression-level properties
1765 #:replacement 'compression)
1766 `(("gzip" ,level)))))
1768 (define (guix-publish-shepherd-service config)
1769 (define (config->compression-options config)
1770 (match (guix-publish-configuration-compression config)
1771 (() ;empty list means "no compression"
1774 (append-map (match-lambda
1776 `("-C" ,(string-append type ":"
1777 (number->string level)))))
1780 (match-record config <guix-publish-configuration>
1781 (guix port host nar-path cache workers ttl cache-bypass-threshold)
1782 (list (shepherd-service
1783 (provision '(guix-publish))
1784 (requirement '(guix-daemon))
1785 (start #~(make-forkexec-constructor
1786 (list #$(file-append guix "/bin/guix")
1787 "publish" "-u" "guix-publish"
1788 "-p" #$(number->string port)
1789 #$@(config->compression-options config)
1790 (string-append "--nar-path=" #$nar-path)
1791 (string-append "--listen=" #$host)
1793 #~((string-append "--workers="
1798 #~((string-append "--ttl="
1799 #$(number->string ttl)
1803 #~((string-append "--cache=" #$cache)
1805 "--cache-bypass-threshold="
1807 cache-bypass-threshold)))
1810 ;; Make sure we run in a UTF-8 locale so we can produce
1811 ;; nars for packages that contain UTF-8 file names such
1812 ;; as 'nss-certs'. See <https://bugs.gnu.org/26948>.
1813 #:environment-variables
1814 (list (string-append "GUIX_LOCPATH="
1815 #$glibc-utf8-locales "/lib/locale")
1816 "LC_ALL=en_US.utf8")
1817 #:log-file "/var/log/guix-publish.log"))
1818 (stop #~(make-kill-destructor))))))
1820 (define %guix-publish-accounts
1821 (list (user-group (name "guix-publish") (system? #t))
1823 (name "guix-publish")
1824 (group "guix-publish")
1826 (comment "guix publish user")
1827 (home-directory "/var/empty")
1828 (shell (file-append shadow "/sbin/nologin")))))
1830 (define %guix-publish-log-rotations
1832 (files (list "/var/log/guix-publish.log")))))
1834 (define (guix-publish-activation config)
1835 (let ((cache (guix-publish-configuration-cache config)))
1837 (with-imported-modules '((guix build utils))
1839 (use-modules (guix build utils))
1842 (let* ((pw (getpw "guix-publish"))
1843 (uid (passwd:uid pw))
1844 (gid (passwd:gid pw)))
1845 (chown #$cache uid gid))))
1848 (define guix-publish-service-type
1849 (service-type (name 'guix-publish)
1851 (list (service-extension shepherd-root-service-type
1852 guix-publish-shepherd-service)
1853 (service-extension account-service-type
1854 (const %guix-publish-accounts))
1855 (service-extension rottlog-service-type
1856 (const %guix-publish-log-rotations))
1857 (service-extension activation-service-type
1858 guix-publish-activation)))
1859 (default-value (guix-publish-configuration))
1861 "Add a Shepherd service running @command{guix publish}, a
1862 command that allows you to share pre-built binaries with others over HTTP.")))
1864 (define-deprecated (guix-publish-service #:key (guix guix)
1865 (port 80) (host "localhost"))
1866 guix-publish-service-type
1867 "Return a service that runs @command{guix publish} listening on @var{host}
1868 and @var{port} (@pxref{Invoking guix publish}).
1870 This assumes that @file{/etc/guix} already contains a signing key pair as
1871 created by @command{guix archive --generate-key} (@pxref{Invoking guix
1872 archive}). If that is not the case, the service will fail to start."
1874 (service guix-publish-service-type
1875 (guix-publish-configuration (guix guix) (port port) (host host))))
1882 (define-record-type* <udev-configuration>
1883 udev-configuration make-udev-configuration
1885 (udev udev-configuration-udev ;<package>
1887 (rules udev-configuration-rules ;list of <package>
1890 (define (udev-rules-union packages)
1891 "Return the union of the @code{lib/udev/rules.d} directories found in each
1892 item of @var{packages}."
1894 (with-imported-modules '((guix build union)
1897 (use-modules (guix build union)
1902 (define %standard-locations
1903 '("/lib/udev/rules.d" "/libexec/udev/rules.d"))
1905 (define (rules-sub-directory directory)
1906 ;; Return the sub-directory of DIRECTORY containing udev rules, or
1907 ;; #f if none was found.
1908 (find directory-exists?
1909 (map (cut string-append directory <>) %standard-locations)))
1911 (mkdir-p (string-append #$output "/lib/udev"))
1912 (union-build (string-append #$output "/lib/udev/rules.d")
1913 (filter-map rules-sub-directory '#$packages)))))
1915 (computed-file "udev-rules" build))
1917 (define (udev-rule file-name contents)
1918 "Return a directory with a udev rule file FILE-NAME containing CONTENTS."
1919 (computed-file file-name
1920 (with-imported-modules '((guix build utils))
1922 (use-modules (guix build utils))
1925 (string-append #$output "/lib/udev/rules.d"))
1928 (call-with-output-file
1929 (string-append rules.d "/" #$file-name)
1931 (display #$contents port)))))))
1933 (define (file->udev-rule file-name file)
1934 "Return a directory with a udev rule file FILE-NAME which is a copy of FILE."
1935 (computed-file file-name
1936 (with-imported-modules '((guix build utils))
1938 (use-modules (guix build utils))
1941 (string-append #$output "/lib/udev/rules.d"))
1943 (define file-copy-dest
1944 (string-append rules.d "/" #$file-name))
1947 (copy-file #$file file-copy-dest)))))
1949 (define kvm-udev-rule
1950 ;; Return a directory with a udev rule that changes the group of /dev/kvm to
1951 ;; "kvm" and makes it #o660. Apparently QEMU-KVM used to ship this rule,
1952 ;; but now we have to add it by ourselves.
1954 ;; Build users are part of the "kvm" group, so we can fearlessly make
1955 ;; /dev/kvm 660 (see <http://bugs.gnu.org/18994>, for background.)
1956 (udev-rule "90-kvm.rules"
1957 "KERNEL==\"kvm\", GROUP=\"kvm\", MODE=\"0660\"\n"))
1959 (define udev-shepherd-service
1960 ;; Return a <shepherd-service> for UDEV with RULES.
1962 (($ <udev-configuration> udev rules)
1963 (let* ((rules (udev-rules-union (cons* udev kvm-udev-rule rules)))
1964 (udev.conf (computed-file "udev.conf"
1965 #~(call-with-output-file #$output
1968 "udev_rules=\"~a/lib/udev/rules.d\"\n"
1974 ;; Udev needs /dev to be a 'devtmpfs' mount so that new device nodes can
1976 ;; <http://www.linuxfromscratch.org/lfs/view/development/chapter07/udev.html>.
1977 (requirement '(root-file-system))
1979 (documentation "Populate the /dev directory, dynamically.")
1981 (with-imported-modules (source-module-closure
1982 '((gnu build linux-boot)))
1985 ;; 'udevd' from eudev.
1986 #$(file-append udev "/sbin/udevd"))
1988 (define (wait-for-udevd)
1989 ;; Wait until someone's listening on udevd's control
1991 (let ((sock (socket AF_UNIX SOCK_SEQPACKET 0)))
1993 (catch 'system-error
1995 (connect sock PF_UNIX "/run/udev/control")
1998 (format #t "waiting for udevd...~%")
2002 ;; Allow udev to find the modules.
2003 (setenv "LINUX_MODULE_DIRECTORY"
2004 "/run/booted-system/kernel/lib/modules")
2006 (let* ((kernel-release
2007 (utsname:release (uname)))
2008 (linux-module-directory
2009 (getenv "LINUX_MODULE_DIRECTORY"))
2011 (string-append linux-module-directory "/"
2013 (old-umask (umask #o022)))
2014 ;; If we're in a container, DIRECTORY might not exist,
2015 ;; for instance because the host runs a different
2016 ;; kernel. In that case, skip it; we'll just miss a few
2017 ;; nodes like /dev/fuse.
2018 (when (file-exists? directory)
2019 (make-static-device-nodes directory))
2022 (let ((pid (fork+exec-command (list udevd)
2023 #:environment-variables
2025 ;; The first one is for udev, the second one for
2027 (string-append "UDEV_CONFIG_FILE=" #$udev.conf)
2028 (string-append "EUDEV_RULES_DIRECTORY="
2030 rules "/lib/udev/rules.d"))
2031 (string-append "LINUX_MODULE_DIRECTORY="
2032 (getenv "LINUX_MODULE_DIRECTORY"))
2033 (default-environment-variables)))))
2034 ;; Wait until udevd is up and running. This appears to
2035 ;; be needed so that the events triggered below are
2036 ;; actually handled.
2039 ;; Trigger device node creation.
2040 (system* #$(file-append udev "/bin/udevadm")
2041 "trigger" "--action=add")
2043 ;; Wait for things to settle down.
2044 (system* #$(file-append udev "/bin/udevadm")
2047 (stop #~(make-kill-destructor))
2049 ;; When halting the system, 'udev' is actually killed by
2050 ;; 'user-processes', i.e., before its own 'stop' method was called.
2051 ;; Thus, make sure it is not respawned.
2053 ;; We need additional modules.
2054 (modules `((gnu build linux-boot) ;'make-static-device-nodes'
2055 ,@%default-modules))
2057 (actions (list (shepherd-action
2059 (documentation "Display the directory containing
2060 the udev rules in use.")
2061 (procedure #~(lambda (_)
2063 (newline))))))))))))
2065 (define udev-service-type
2066 (service-type (name 'udev)
2068 (list (service-extension shepherd-root-service-type
2069 udev-shepherd-service)))
2071 (compose concatenate) ;concatenate the list of rules
2072 (extend (lambda (config rules)
2074 (($ <udev-configuration> udev initial-rules)
2077 (rules (append initial-rules rules)))))))
2078 (default-value (udev-configuration))
2080 "Run @command{udev}, which populates the @file{/dev}
2081 directory dynamically. Get extra rules from the packages listed in the
2082 @code{rules} field of its value, @code{udev-configuration} object.")))
2084 (define* (udev-service #:key (udev eudev) (rules '()))
2085 "Run @var{udev}, which populates the @file{/dev} directory dynamically. Get
2086 extra rules from the packages listed in @var{rules}."
2087 (service udev-service-type
2088 (udev-configuration (udev udev) (rules rules))))
2090 (define* (udev-rules-service name rules #:key (groups '()))
2091 "Return a service that extends udev-service-type with RULES and
2092 account-service-type with GROUPS as system groups. This works by creating a
2093 singleton service type NAME-udev-rules, of which the returned service is an
2095 (let* ((name (symbol-append name '-udev-rules))
2097 (const (map (lambda (group)
2098 (user-group (name group) (system? #t)))
2100 (udev-extension (const (list rules)))
2105 account-service-type account-extension)
2107 udev-service-type udev-extension))))))
2110 (define swap-service-type
2111 (shepherd-service-type
2115 (if (and (string? device)
2116 (string-prefix? "/dev/mapper/" device))
2117 (list (symbol-append 'device-mapping-
2118 (string->symbol (basename device))))
2121 (define (device-lookup device)
2122 ;; The generic 'find-partition' procedures could return a partition
2123 ;; that's not swap space, but that's unlikely.
2124 (cond ((uuid? device)
2125 #~(find-partition-by-uuid #$(uuid-bytevector device)))
2126 ((file-system-label? device)
2127 #~(find-partition-by-label
2128 #$(file-system-label->string device)))
2132 (define service-name
2133 (symbol-append 'swap-
2135 (cond ((uuid? device)
2136 (string-take (uuid->string device) 6))
2137 ((file-system-label? device)
2138 (file-system-label->string device))
2142 (with-imported-modules (source-module-closure '((gnu build file-systems)))
2144 (provision (list service-name))
2145 (requirement `(udev ,@requirement))
2146 (documentation "Enable the given swap device.")
2147 (modules `((gnu build file-systems)
2148 ,@%default-modules))
2150 (let ((device #$(device-lookup device)))
2153 (restart-on-EINTR (swapon device))
2156 (let ((device #$(device-lookup device)))
2158 (restart-on-EINTR (swapoff device)))
2162 (define (swap-service device)
2163 "Return a service that uses @var{device} as a swap device."
2164 (service swap-service-type device))
2166 (define %default-gpm-options
2167 ;; Default options for GPM.
2168 '("-m" "/dev/input/mice" "-t" "ps2"))
2170 (define-record-type* <gpm-configuration>
2171 gpm-configuration make-gpm-configuration gpm-configuration?
2172 (gpm gpm-configuration-gpm ;package
2174 (options gpm-configuration-options ;list of strings
2175 (default %default-gpm-options)))
2177 (define gpm-shepherd-service
2179 (($ <gpm-configuration> gpm options)
2180 (list (shepherd-service
2181 (requirement '(udev))
2184 ;; 'gpm' runs in the background and sets a PID file.
2185 ;; Note that it requires running as "root".
2186 (false-if-exception (delete-file "/var/run/gpm.pid"))
2187 (fork+exec-command (list #$(file-append gpm "/sbin/gpm")
2190 ;; Wait for the PID file to appear; declare failure if
2191 ;; it doesn't show up.
2193 (or (file-exists? "/var/run/gpm.pid")
2201 ;; Return #f if successfully stopped.
2202 (not (zero? (system* #$(file-append gpm "/sbin/gpm")
2205 (define gpm-service-type
2206 (service-type (name 'gpm)
2208 (list (service-extension shepherd-root-service-type
2209 gpm-shepherd-service)))
2210 (default-value (gpm-configuration))
2212 "Run GPM, the general-purpose mouse daemon, with the given
2213 command-line options. GPM allows users to use the mouse in the console,
2214 notably to select, copy, and paste text. The default options use the
2215 @code{ps2} protocol, which works for both USB and PS/2 mice.")))
2217 (define-deprecated (gpm-service #:key (gpm gpm)
2218 (options %default-gpm-options))
2220 "Run @var{gpm}, the general-purpose mouse daemon, with the given
2221 command-line @var{options}. GPM allows users to use the mouse in the console,
2222 notably to select, copy, and paste text. The default value of @var{options}
2223 uses the @code{ps2} protocol, which works for both USB and PS/2 mice.
2225 This service is not part of @var{%base-services}."
2226 ;; To test in QEMU, use "-usbdevice mouse" and then, in the monitor, use
2227 ;; "info mice" and "mouse_set X" to use the right mouse.
2228 (service gpm-service-type
2229 (gpm-configuration (gpm gpm) (options options))))
2231 (define-record-type* <kmscon-configuration>
2232 kmscon-configuration make-kmscon-configuration
2233 kmscon-configuration?
2234 (kmscon kmscon-configuration-kmscon
2236 (virtual-terminal kmscon-configuration-virtual-terminal)
2237 (login-program kmscon-configuration-login-program
2238 (default (file-append shadow "/bin/login")))
2239 (login-arguments kmscon-configuration-login-arguments
2241 (auto-login kmscon-configuration-auto-login
2243 (hardware-acceleration? kmscon-configuration-hardware-acceleration?
2244 (default #f))) ; #t causes failure
2246 (define kmscon-service-type
2247 (shepherd-service-type
2250 (let ((kmscon (kmscon-configuration-kmscon config))
2251 (virtual-terminal (kmscon-configuration-virtual-terminal config))
2252 (login-program (kmscon-configuration-login-program config))
2253 (login-arguments (kmscon-configuration-login-arguments config))
2254 (auto-login (kmscon-configuration-auto-login config))
2255 (hardware-acceleration? (kmscon-configuration-hardware-acceleration? config)))
2257 (define kmscon-command
2259 #$(file-append kmscon "/bin/kmscon") "--login"
2260 "--vt" #$virtual-terminal
2261 "--no-switchvt" ;Prevent a switch to the virtual terminal.
2262 #$@(if hardware-acceleration? '("--hwaccel") '())
2264 #$login-program #$@login-arguments
2270 (documentation "kmscon virtual terminal")
2271 (requirement '(user-processes udev dbus-system))
2272 (provision (list (symbol-append 'term- (string->symbol virtual-terminal))))
2273 (start #~(make-forkexec-constructor #$kmscon-command))
2274 (stop #~(make-kill-destructor)))))))
2276 (define-record-type* <static-networking>
2277 static-networking make-static-networking
2279 (interface static-networking-interface)
2280 (ip static-networking-ip)
2281 (netmask static-networking-netmask
2283 (gateway static-networking-gateway ;FIXME: doesn't belong here
2285 (provision static-networking-provision
2287 (requirement static-networking-requirement
2289 (name-servers static-networking-name-servers ;FIXME: doesn't belong here
2292 (define static-networking-shepherd-service
2294 (($ <static-networking> interface ip netmask gateway provision
2295 requirement name-servers)
2296 (let ((loopback? (and provision (memq 'loopback provision))))
2300 "Bring up the networking interface using a static IP address.")
2301 (requirement requirement)
2302 (provision (or provision
2303 (list (symbol-append 'networking-
2304 (string->symbol interface)))))
2307 ;; Return #t if successfully started.
2308 (let* ((addr (inet-pton AF_INET #$ip))
2309 (sockaddr (make-socket-address AF_INET addr 0))
2310 (mask (and #$netmask
2311 (inet-pton AF_INET #$netmask)))
2313 (make-socket-address AF_INET
2315 (gateway (and #$gateway
2316 (inet-pton AF_INET #$gateway)))
2317 (gatewayaddr (and gateway
2318 (make-socket-address AF_INET
2320 (configure-network-interface #$interface sockaddr
2327 (let ((sock (socket AF_INET SOCK_DGRAM 0)))
2328 (add-network-route/gateway sock gatewayaddr)
2329 (close-port sock))))))
2331 ;; Return #f is successfully stopped.
2332 (let ((sock (socket AF_INET SOCK_STREAM 0)))
2334 (delete-network-route sock
2335 (make-socket-address
2336 AF_INET INADDR_ANY 0)))
2337 (set-network-interface-flags sock #$interface 0)
2342 (define (static-networking-etc-files interfaces)
2343 "Return a /etc/resolv.conf entry for INTERFACES or the empty list."
2344 (match (delete-duplicates
2345 (append-map static-networking-name-servers
2350 (let ((content (string-join
2351 (map (cut string-append "nameserver " <>)
2355 ,(plain-file "resolv.conf"
2357 # Generated by 'static-networking-service'.\n"
2360 (define (static-networking-shepherd-services interfaces)
2361 "Return the list of Shepherd services to bring up INTERFACES, a list of
2362 <static-networking> objects."
2363 (define (loopback? service)
2364 (memq 'loopback (shepherd-service-provision service)))
2366 (let ((services (map static-networking-shepherd-service interfaces)))
2367 (match (remove loopback? services)
2369 ;; There's no interface other than 'loopback', so we assume that the
2370 ;; 'networking' service will be provided by dhclient or similar.
2373 ;; Assume we're providing all the interfaces, and thus, provide a
2374 ;; 'networking' service.
2375 (cons (shepherd-service
2376 (provision '(networking))
2377 (requirement (append-map shepherd-service-provision
2379 (start #~(const #t))
2381 (documentation "Bring up all the networking interfaces."))
2384 (define static-networking-service-type
2385 ;; The service type for statically-defined network interfaces.
2386 (service-type (name 'static-networking)
2389 (service-extension shepherd-root-service-type
2390 static-networking-shepherd-services)
2391 (service-extension etc-service-type
2392 static-networking-etc-files)))
2393 (compose concatenate)
2396 "Turn up the specified network interfaces upon startup,
2397 with the given IP address, gateway, netmask, and so on. The value for
2398 services of this type is a list of @code{static-networking} objects, one per
2399 network interface.")))
2401 (define* (static-networking-service interface ip
2403 netmask gateway provision
2404 ;; Most interfaces require udev to be usable.
2405 (requirement '(udev))
2407 "Return a service that starts @var{interface} with address @var{ip}. If
2408 @var{netmask} is true, use it as the network mask. If @var{gateway} is true,
2409 it must be a string specifying the default network gateway.
2411 This procedure can be called several times, one for each network
2412 interface of interest. Behind the scenes what it does is extend
2413 @code{static-networking-service-type} with additional network interfaces
2415 (simple-service 'static-network-interface
2416 static-networking-service-type
2417 (list (static-networking (interface interface) (ip ip)
2418 (netmask netmask) (gateway gateway)
2419 (provision provision)
2420 (requirement requirement)
2421 (name-servers name-servers)))))
2424 (define %base-services
2425 ;; Convenience variable holding the basic services.
2426 (list (service login-service-type)
2428 (service virtual-terminal-service-type)
2429 (service console-font-service-type
2431 (cons tty %default-console-font))
2432 '("tty1" "tty2" "tty3" "tty4" "tty5" "tty6")))
2434 (service agetty-service-type (agetty-configuration
2435 (extra-options '("-L")) ; no carrier detect
2437 (tty #f))) ; automatic
2439 (service mingetty-service-type (mingetty-configuration
2441 (service mingetty-service-type (mingetty-configuration
2443 (service mingetty-service-type (mingetty-configuration
2445 (service mingetty-service-type (mingetty-configuration
2447 (service mingetty-service-type (mingetty-configuration
2449 (service mingetty-service-type (mingetty-configuration
2452 (service static-networking-service-type
2453 (list (static-networking (interface "lo")
2456 (provision '(loopback)))))
2458 (service urandom-seed-service-type)
2459 (service guix-service-type)
2460 (service nscd-service-type)
2462 (service rottlog-service-type)
2464 ;; The LVM2 rules are needed as soon as LVM2 or the device-mapper is
2465 ;; used, so enable them by default. The FUSE and ALSA rules are
2466 ;; less critical, but handy.
2467 (service udev-service-type
2469 (rules (list lvm2 fuse alsa-utils crda))))
2471 (service special-files-service-type
2472 `(("/bin/sh" ,(file-append bash "/bin/sh"))
2473 ("/usr/bin/env" ,(file-append coreutils "/bin/env"))))))
2475 ;;; base.scm ends here