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
184 ;;; Base system services---i.e., services that 99% of the users will want to
195 (define (file-system->fstab-entry file-system)
196 "Return a @file{/etc/fstab} entry for @var{file-system}."
197 (string-append (match (file-system-device file-system)
198 ((? file-system-label? label)
199 (string-append "LABEL="
200 (file-system-label->string label)))
202 (string-append "UUID=" (uuid->string uuid)))
206 (file-system-mount-point file-system) "\t"
207 (file-system-type file-system) "\t"
208 (or (file-system-options file-system) "defaults") "\t"
210 ;; XXX: Omit the 'fs_freq' and 'fs_passno' fields because we
211 ;; don't have anything sensible to put in there.
214 (define (file-systems->fstab file-systems)
215 "Return a @file{/etc} entry for an @file{fstab} describing
217 `(("fstab" ,(plain-file "fstab"
220 # This file was generated from your Guix configuration. Any changes
221 # will be lost upon reboot or reconfiguration.\n\n"
222 (string-join (map file-system->fstab-entry
227 (define fstab-service-type
228 ;; The /etc/fstab service.
229 (service-type (name 'fstab)
231 (list (service-extension etc-service-type
232 file-systems->fstab)))
233 (compose concatenate)
236 "Populate the @file{/etc/fstab} based on the given file
239 (define %root-file-system-shepherd-service
241 (documentation "Take care of the root file system.")
242 (provision '(root-file-system))
245 ;; Return #f if successfully stopped.
248 (call-with-blocked-asyncs
250 (let ((null (%make-void-port "w")))
251 ;; Close 'shepherd.log'.
252 (display "closing log\n")
253 ((@ (shepherd comm) stop-logging))
255 ;; Redirect the default output ports..
256 (set-current-output-port null)
257 (set-current-error-port null)
259 ;; Close /dev/console.
260 (for-each close-fdes '(0 1 2))
262 ;; At this point, there are no open files left, so the
263 ;; root file system can be re-mounted read-only.
265 (logior MS_REMOUNT MS_RDONLY)
271 (define root-file-system-service-type
272 (shepherd-service-type 'root-file-system
273 (const %root-file-system-shepherd-service)))
275 (define (root-file-system-service)
276 "Return a service whose sole purpose is to re-mount read-only the root file
277 system upon shutdown (aka. cleanly \"umounting\" root.)
279 This service must be the root of the service dependency graph so that its
280 'stop' action is invoked when shepherd is the only process left."
281 (service root-file-system-service-type #f))
283 (define (file-system->shepherd-service-name file-system)
284 "Return the symbol that denotes the service mounting and unmounting
286 (symbol-append 'file-system-
287 (string->symbol (file-system-mount-point file-system))))
289 (define (mapped-device->shepherd-service-name md)
290 "Return the symbol that denotes the shepherd service of MD, a <mapped-device>."
291 (symbol-append 'device-mapping-
292 (string->symbol (mapped-device-target md))))
294 (define dependency->shepherd-service-name
296 ((? mapped-device? md)
297 (mapped-device->shepherd-service-name md))
299 (file-system->shepherd-service-name fs))))
301 (define (file-system-shepherd-service file-system)
302 "Return the shepherd service for @var{file-system}, or @code{#f} if
303 @var{file-system} is not auto-mounted upon boot."
304 (let ((target (file-system-mount-point file-system))
305 (create? (file-system-create-mount-point? file-system))
306 (dependencies (file-system-dependencies file-system))
307 (packages (file-system-packages (list file-system))))
308 (and (file-system-mount? file-system)
309 (with-imported-modules (source-module-closure
310 '((gnu build file-systems)))
312 (provision (list (file-system->shepherd-service-name file-system)))
313 (requirement `(root-file-system udev
314 ,@(map dependency->shepherd-service-name dependencies)))
315 (documentation "Check, mount, and unmount the given file system.")
316 (start #~(lambda args
321 (let (($PATH (getenv "PATH")))
322 ;; Make sure fsck.ext2 & co. can be found.
325 ;; Don’t display the PATH settings.
326 (with-output-to-port (%make-void-port "w")
328 (set-path-environment-variable "PATH"
334 '#$(file-system->spec file-system))
337 (setenv "PATH" $PATH)))
340 ;; Normally there are no processes left at this point, so
341 ;; TARGET can be safely unmounted.
343 ;; Make sure PID 1 doesn't keep TARGET busy.
349 ;; We need additional modules.
350 (modules `(((gnu build file-systems)
351 #:select (mount-file-system))
352 (gnu system file-systems)
353 ,@%default-modules)))))))
355 (define (file-system-shepherd-services file-systems)
356 "Return the list of Shepherd services for FILE-SYSTEMS."
357 (let* ((file-systems (filter file-system-mount? file-systems)))
360 (provision '(file-systems))
361 (requirement (cons* 'root-file-system 'user-file-systems
362 (map file-system->shepherd-service-name
364 (documentation "Target for all the initially-mounted file systems")
366 (stop #~(const #f))))
368 (define known-mount-points
369 (map file-system-mount-point file-systems))
373 (documentation "Unmount manually-mounted file systems.")
374 (provision '(user-file-systems))
377 (define (known? mount-point)
379 (cons* "/proc" "/sys" '#$known-mount-points)))
381 ;; Make sure we don't keep the user's mount points busy.
384 (for-each (lambda (mount-point)
385 (format #t "unmounting '~a'...~%" mount-point)
388 (umount mount-point))
390 (let ((errno (system-error-errno args)))
391 (format #t "failed to unmount '~a': ~a~%"
392 mount-point (strerror errno))))))
393 (filter (negate known?) (mount-points)))
396 (cons* sink user-unmount
397 (map file-system-shepherd-service file-systems))))
399 (define (file-system-fstab-entries file-systems)
400 "Return the subset of @var{file-systems} that should have an entry in
402 ;; /etc/fstab is about telling fsck(8), mount(8), and umount(8) about
403 ;; relevant file systems they'll have to deal with. That excludes "pseudo"
406 ;; In particular, things like GIO (part of GLib) use it to determine the set
407 ;; of mounts, which is then used by graphical file managers and desktop
408 ;; environments to display "volume" icons. Thus, we really need to exclude
409 ;; those pseudo file systems from the list.
410 (remove (lambda (file-system)
411 (or (member (file-system-type file-system)
412 %pseudo-file-system-types)
413 (memq 'bind-mount (file-system-flags file-system))))
416 (define file-system-service-type
417 (service-type (name 'file-systems)
419 (list (service-extension shepherd-root-service-type
420 file-system-shepherd-services)
421 (service-extension fstab-service-type
422 file-system-fstab-entries)
424 ;; Have 'user-processes' depend on 'file-systems'.
425 (service-extension user-processes-service-type
426 (const '(file-systems)))))
427 (compose concatenate)
430 "Provide Shepherd services to mount and unmount the given
431 file systems, as well as corresponding @file{/etc/fstab} entries.")))
436 ;;; Preserve entropy to seed /dev/urandom on boot.
439 (define %random-seed-file
440 "/var/lib/random-seed")
442 (define (urandom-seed-shepherd-service _)
443 "Return a shepherd service for the /dev/urandom seed."
444 (list (shepherd-service
445 (documentation "Preserve entropy across reboots for /dev/urandom.")
446 (provision '(urandom-seed))
448 ;; Depend on udev so that /dev/hwrng is available.
449 (requirement '(file-systems udev))
452 ;; On boot, write random seed into /dev/urandom.
453 (when (file-exists? #$%random-seed-file)
454 (call-with-input-file #$%random-seed-file
456 (call-with-output-file "/dev/urandom"
458 (dump-port seed urandom)
460 ;; Writing SEED to URANDOM isn't enough: we must
461 ;; also tell the kernel to account for these
462 ;; extra bits of entropy.
463 (let ((bits (* 8 (stat:size (stat seed)))))
464 (add-to-entropy-count urandom bits)))))))
466 ;; Try writing from /dev/hwrng into /dev/urandom.
467 ;; It seems that the file /dev/hwrng always exists, even
468 ;; when there is no hardware random number generator
469 ;; available. So, we handle a failed read or any other error
470 ;; reported by the operating system.
471 (let ((buf (catch 'system-error
473 (call-with-input-file "/dev/hwrng"
475 (get-bytevector-n hwrng 512))))
476 ;; Silence is golden...
479 (call-with-output-file "/dev/urandom"
481 (put-bytevector urandom buf)
482 (let ((bits (* 8 (bytevector-length buf))))
483 (add-to-entropy-count urandom bits))))))
485 ;; Immediately refresh the seed in case the system doesn't
486 ;; shut down cleanly.
487 (call-with-input-file "/dev/urandom"
489 (let ((previous-umask (umask #o077))
490 (buf (make-bytevector 512)))
491 (mkdir-p (dirname #$%random-seed-file))
492 (get-bytevector-n! urandom buf 0 512)
493 (call-with-output-file #$%random-seed-file
495 (put-bytevector seed buf)))
496 (umask previous-umask))))
499 ;; During shutdown, write from /dev/urandom into random seed.
500 (let ((buf (make-bytevector 512)))
501 (call-with-input-file "/dev/urandom"
503 (let ((previous-umask (umask #o077)))
504 (get-bytevector-n! urandom buf 0 512)
505 (mkdir-p (dirname #$%random-seed-file))
506 (call-with-output-file #$%random-seed-file
508 (put-bytevector seed buf)))
509 (umask previous-umask))
511 (modules `((rnrs bytevectors)
513 ,@%default-modules)))))
515 (define urandom-seed-service-type
516 (service-type (name 'urandom-seed)
518 (list (service-extension shepherd-root-service-type
519 urandom-seed-shepherd-service)
521 ;; Have 'user-processes' depend on 'urandom-seed'.
522 ;; This ensures that user processes and daemons don't
523 ;; start until we have seeded the PRNG.
524 (service-extension user-processes-service-type
525 (const '(urandom-seed)))))
528 "Seed the @file{/dev/urandom} pseudo-random number
529 generator (RNG) with the value recorded when the system was last shut
532 (define-deprecated (urandom-seed-service)
533 urandom-seed-service-type
534 (service urandom-seed-service-type))
538 ;;; Add hardware random number generator to entropy pool.
541 (define-record-type* <rngd-configuration>
542 rngd-configuration make-rngd-configuration
544 (rng-tools rngd-configuration-rng-tools) ;package
545 (device rngd-configuration-device)) ;string
547 (define rngd-service-type
548 (shepherd-service-type
551 (define rng-tools (rngd-configuration-rng-tools config))
552 (define device (rngd-configuration-device config))
555 (list (file-append rng-tools "/sbin/rngd")
559 (documentation "Add TRNG to entropy pool.")
560 (requirement '(udev))
562 (start #~(make-forkexec-constructor '#$rngd-command))
563 (stop #~(make-kill-destructor))))))
565 (define* (rngd-service #:key
566 (rng-tools rng-tools)
567 (device "/dev/hwrng"))
568 "Return a service that runs the @command{rngd} program from @var{rng-tools}
569 to add @var{device} to the kernel's entropy pool. The service will fail if
570 @var{device} does not exist."
571 (service rngd-service-type
573 (rng-tools rng-tools)
581 (define host-name-service-type
582 (shepherd-service-type
586 (documentation "Initialize the machine's host name.")
587 (provision '(host-name))
589 (sethostname #$name)))
592 (define (host-name-service name)
593 "Return a service that sets the host name to @var{name}."
594 (service host-name-service-type name))
596 (define virtual-terminal-service-type
597 ;; Ensure that virtual terminals run in UTF-8 mode. This is the case by
598 ;; default with recent Linux kernels, but this service allows us to ensure
599 ;; this. This service must start before any 'term-' service so that newly
600 ;; created terminals inherit this property. See
601 ;; <https://bugs.gnu.org/30505> for a discussion.
602 (shepherd-service-type
605 (let ((knob "/sys/module/vt/parameters/default_utf8"))
607 (documentation "Set virtual terminals in UTF-8 module.")
608 (provision '(virtual-terminal))
609 (requirement '(root-file-system))
611 ;; In containers /sys is read-only so don't insist on
612 ;; writing to this file.
613 (unless (= 1 (call-with-input-file #$knob read))
614 (call-with-output-file #$knob
618 (stop #~(const #f)))))
619 #t)) ;default to UTF-8
621 (define console-keymap-service-type
622 (shepherd-service-type
626 (documentation (string-append "Load console keymap (loadkeys)."))
627 (provision '(console-keymap))
629 (zero? (system* #$(file-append kbd "/bin/loadkeys")
633 (define-deprecated (console-keymap-service #:rest files)
635 "Return a service to load console keymaps from @var{files}."
636 (service console-keymap-service-type files))
638 (define %default-console-font
639 ;; Note: 'LatGrkCyr-8x16' has the advantage of providing three common
640 ;; scripts as well as glyphs for em dash, quotation marks, and other Unicode
641 ;; codepoints notably found in the UTF-8 manual.
644 (define (console-font-shepherd-services tty+font)
645 "Return a list of Shepherd services for each pair in TTY+FONT."
648 (let ((device (string-append "/dev/" tty)))
650 (documentation "Load a Unicode console font.")
651 (provision (list (symbol-append 'console-font-
652 (string->symbol tty))))
654 ;; Start after mingetty has been started on TTY, otherwise the settings
656 (requirement (list (symbol-append 'term-
657 (string->symbol tty))))
660 ;; It could be that mingetty is not fully ready yet,
661 ;; which we check by calling 'ttyname'.
663 (unless (or (zero? i)
664 (call-with-input-file #$device
666 (false-if-exception (ttyname port)))))
670 ;; Assume the VT is already in UTF-8 mode, thanks to
671 ;; the 'virtual-terminal' service.
673 ;; 'setfont' returns EX_OSERR (71) when an
674 ;; KDFONTOP ioctl fails, for example. Like
675 ;; systemd's vconsole support, let's not treat
677 (case (status:exit-val
678 (system* #$(file-append kbd "/bin/setfont")
679 "-C" #$device #$font))
686 (define console-font-service-type
687 (service-type (name 'console-fonts)
689 (list (service-extension shepherd-root-service-type
690 console-font-shepherd-services)))
691 (compose concatenate)
694 "Install the given fonts on the specified ttys (fonts are per
695 virtual console on GNU/Linux). The value of this service is a list of
696 tty/font pairs. The font can be the name of a font provided by the @code{kbd}
697 package or any valid argument to @command{setfont}, as in this example:
700 `((\"tty1\" . \"LatGrkCyr-8x16\")
701 (\"tty2\" . ,(file-append
703 \"/share/kbd/consolefonts/TamzenForPowerline10x20.psf\"))
704 (\"tty3\" . ,(file-append
706 \"/share/consolefonts/ter-132n\"))) ; for HDPI
709 (define* (console-font-service tty #:optional (font "LatGrkCyr-8x16"))
710 "This procedure is deprecated in favor of @code{console-font-service-type}.
712 Return a service that sets up Unicode support in @var{tty} and loads
713 @var{font} for that tty (fonts are per virtual console in Linux.)"
714 (simple-service (symbol-append 'console-font- (string->symbol tty))
715 console-font-service-type `((,tty . ,font))))
717 (define %default-motd
718 (plain-file "motd" "This is the GNU operating system, welcome!\n\n"))
720 (define-record-type* <login-configuration>
721 login-configuration make-login-configuration
723 (motd login-configuration-motd ;file-like
724 (default %default-motd))
725 ;; Allow empty passwords by default so that first-time users can log in when
726 ;; the 'root' account has just been created.
727 (allow-empty-passwords? login-configuration-allow-empty-passwords?
728 (default #t))) ;Boolean
730 (define (login-pam-service config)
731 "Return the list of PAM service needed for CONF."
732 ;; Let 'login' be known to PAM.
733 (list (unix-pam-service "login"
735 #:allow-empty-passwords?
736 (login-configuration-allow-empty-passwords? config)
738 (login-configuration-motd config))))
740 (define login-service-type
741 (service-type (name 'login)
742 (extensions (list (service-extension pam-root-service-type
744 (default-value (login-configuration))
746 "Provide a console log-in service as specified by its
747 configuration value, a @code{login-configuration} object.")))
749 (define* (login-service #:optional (config (login-configuration)))
750 "Return a service configure login according to @var{config}, which specifies
751 the message of the day, among other things."
752 (service login-service-type config))
754 (define-record-type* <agetty-configuration>
755 agetty-configuration make-agetty-configuration
756 agetty-configuration?
757 (agetty agetty-configuration-agetty ;<package>
758 (default util-linux))
759 (tty agetty-configuration-tty) ;string | #f
760 (term agetty-term ;string | #f
762 (baud-rate agetty-baud-rate ;string | #f
764 (auto-login agetty-auto-login ;list of strings | #f
766 (login-program agetty-login-program ;gexp
767 (default (file-append shadow "/bin/login")))
768 (login-pause? agetty-login-pause? ;Boolean
770 (eight-bits? agetty-eight-bits? ;Boolean
772 (no-reset? agetty-no-reset? ;Boolean
774 (remote? agetty-remote? ;Boolean
776 (flow-control? agetty-flow-control? ;Boolean
778 (host agetty-host ;string | #f
780 (no-issue? agetty-no-issue? ;Boolean
782 (init-string agetty-init-string ;string | #f
784 (no-clear? agetty-no-clear? ;Boolean
786 (local-line agetty-local-line ;always | never | auto
788 (extract-baud? agetty-extract-baud? ;Boolean
790 (skip-login? agetty-skip-login? ;Boolean
792 (no-newline? agetty-no-newline? ;Boolean
794 (login-options agetty-login-options ;string | #f
796 (chroot agetty-chroot ;string | #f
798 (hangup? agetty-hangup? ;Boolean
800 (keep-baud? agetty-keep-baud? ;Boolean
802 (timeout agetty-timeout ;integer | #f
804 (detect-case? agetty-detect-case? ;Boolean
806 (wait-cr? agetty-wait-cr? ;Boolean
808 (no-hints? agetty-no-hints? ;Boolean
810 (no-hostname? agetty-no hostname? ;Boolean
812 (long-hostname? agetty-long-hostname? ;Boolean
814 (erase-characters agetty-erase-characters ;string | #f
816 (kill-characters agetty-kill-characters ;string | #f
818 (chdir agetty-chdir ;string | #f
820 (delay agetty-delay ;integer | #f
822 (nice agetty-nice ;integer | #f
824 ;; "Escape hatch" for passing arbitrary command-line arguments.
825 (extra-options agetty-extra-options ;list of strings
827 ;;; XXX Unimplemented for now!
828 ;;; (issue-file agetty-issue-file ;file-like
832 (define (default-serial-port)
833 "Return a gexp that determines a reasonable default serial port
834 to use as the tty. This is primarily useful for headless systems."
835 (with-imported-modules (source-module-closure
836 '((gnu build linux-boot))) ;for 'find-long-options'
838 ;; console=device,options
839 ;; device: can be tty0, ttyS0, lp0, ttyUSB0 (serial).
840 ;; options: BBBBPNF. P n|o|e, N number of bits,
841 ;; F flow control (r RTS)
842 (let* ((not-comma (char-set-complement (char-set #\,)))
843 (command (linux-command-line))
844 (agetty-specs (find-long-options "agetty.tty" command))
845 (console-specs (filter (lambda (spec)
846 (and (string-prefix? "tty" spec)
848 (string-prefix? "tty0" spec)
849 (string-prefix? "tty1" spec)
850 (string-prefix? "tty2" spec)
851 (string-prefix? "tty3" spec)
852 (string-prefix? "tty4" spec)
853 (string-prefix? "tty5" spec)
854 (string-prefix? "tty6" spec)
855 (string-prefix? "tty7" spec)
856 (string-prefix? "tty8" spec)
857 (string-prefix? "tty9" spec)))))
858 (find-long-options "console" command)))
859 (specs (append agetty-specs console-specs)))
863 ;; Extract device name from first spec.
864 (match (string-tokenize spec not-comma)
868 (define agetty-shepherd-service
870 (($ <agetty-configuration> agetty tty term baud-rate auto-login
871 login-program login-pause? eight-bits? no-reset? remote? flow-control?
872 host no-issue? init-string no-clear? local-line extract-baud?
873 skip-login? no-newline? login-options chroot hangup? keep-baud? timeout
874 detect-case? wait-cr? no-hints? no-hostname? long-hostname?
875 erase-characters kill-characters chdir delay nice extra-options)
878 (documentation "Run agetty on a tty.")
879 (provision (list (symbol-append 'term- (string->symbol (or tty "auto")))))
881 ;; Since the login prompt shows the host name, wait for the 'host-name'
882 ;; service to be done. Also wait for udev essentially so that the tty
883 ;; text is not lost in the middle of kernel messages (see also
884 ;; mingetty-shepherd-service).
885 (requirement '(user-processes host-name udev))
887 (modules '((ice-9 match) (gnu build linux-boot)))
889 (with-imported-modules (source-module-closure
890 '((gnu build linux-boot)))
892 (let ((defaulted-tty #$(or tty (default-serial-port))))
895 (make-forkexec-constructor
896 (list #$(file-append util-linux "/sbin/agetty")
917 #~("--init-string" #$init-string)
922 ;;; FIXME This doesn't work as expected. According to agetty(8), if this option
923 ;;; is not passed, then the default is 'auto'. However, in my tests, when that
924 ;;; option is selected, agetty never presents the login prompt, and the
925 ;;; term-ttyS0 service respawns every few seconds.
927 #~(#$(match local-line
928 ('auto "--local-line=auto")
929 ('always "--local-line=always")
930 ('never "-local-line=never")))
945 #~("--login-options" #$login-options)
948 #~("--chroot" #$chroot)
957 #~("--timeout" #$(number->string timeout))
971 #$@(if long-hostname?
972 #~("--long-hostname")
974 #$@(if erase-characters
975 #~("--erase-chars" #$erase-characters)
977 #$@(if kill-characters
978 #~("--kill-chars" #$kill-characters)
981 #~("--chdir" #$chdir)
984 #~("--delay" #$(number->string delay))
987 #~("--nice" #$(number->string nice))
990 (list "--autologin" auto-login)
993 #~("--login-program" #$login-program)
1005 (const #f)) ; never start.
1007 (stop #~(make-kill-destructor)))))))
1009 (define agetty-service-type
1010 (service-type (name 'agetty)
1011 (extensions (list (service-extension shepherd-root-service-type
1012 agetty-shepherd-service)))
1014 "Provide console login using the @command{agetty}
1017 (define* (agetty-service config)
1018 "Return a service to run agetty according to @var{config}, which specifies
1019 the tty to run, among other things."
1020 (service agetty-service-type config))
1022 (define-record-type* <mingetty-configuration>
1023 mingetty-configuration make-mingetty-configuration
1024 mingetty-configuration?
1025 (mingetty mingetty-configuration-mingetty ;<package>
1027 (tty mingetty-configuration-tty) ;string
1028 (auto-login mingetty-auto-login ;string | #f
1030 (login-program mingetty-login-program ;gexp
1032 (login-pause? mingetty-login-pause? ;Boolean
1035 (define mingetty-shepherd-service
1037 (($ <mingetty-configuration> mingetty tty auto-login login-program
1041 (documentation "Run mingetty on an tty.")
1042 (provision (list (symbol-append 'term- (string->symbol tty))))
1044 ;; Since the login prompt shows the host name, wait for the 'host-name'
1045 ;; service to be done. Also wait for udev essentially so that the tty
1046 ;; text is not lost in the middle of kernel messages (XXX).
1047 (requirement '(user-processes host-name udev virtual-terminal))
1049 (start #~(make-forkexec-constructor
1050 (list #$(file-append mingetty "/sbin/mingetty")
1053 ;; Avoiding 'vhangup' allows us to avoid 'setfont'
1054 ;; errors down the path where various ioctls get
1055 ;; EIO--see 'hung_up_tty_ioctl' in driver/tty/tty_io.c
1060 #~("--autologin" #$auto-login)
1062 #$@(if login-program
1063 #~("--loginprog" #$login-program)
1068 (stop #~(make-kill-destructor)))))))
1070 (define mingetty-service-type
1071 (service-type (name 'mingetty)
1072 (extensions (list (service-extension shepherd-root-service-type
1073 mingetty-shepherd-service)))
1075 "Provide console login using the @command{mingetty}
1078 (define* (mingetty-service config)
1079 "Return a service to run mingetty according to @var{config}, which specifies
1080 the tty to run, among other things."
1081 (service mingetty-service-type config))
1083 (define-record-type* <nscd-configuration> nscd-configuration
1084 make-nscd-configuration
1086 (log-file nscd-configuration-log-file ;string
1087 (default "/var/log/nscd.log"))
1088 (debug-level nscd-debug-level ;integer
1090 ;; TODO: See nscd.conf in glibc for other options to add.
1091 (caches nscd-configuration-caches ;list of <nscd-cache>
1092 (default %nscd-default-caches))
1093 (name-services nscd-configuration-name-services ;list of <packages>
1095 (glibc nscd-configuration-glibc ;<package>
1098 (define-record-type* <nscd-cache> nscd-cache make-nscd-cache
1100 (database nscd-cache-database) ;symbol
1101 (positive-time-to-live nscd-cache-positive-time-to-live) ;integer
1102 (negative-time-to-live nscd-cache-negative-time-to-live
1103 (default 20)) ;integer
1104 (suggested-size nscd-cache-suggested-size ;integer ("default module
1107 (check-files? nscd-cache-check-files? ;Boolean
1109 (persistent? nscd-cache-persistent? ;Boolean
1111 (shared? nscd-cache-shared? ;Boolean
1113 (max-database-size nscd-cache-max-database-size ;integer
1114 (default (* 32 (expt 2 20))))
1115 (auto-propagate? nscd-cache-auto-propagate? ;Boolean
1118 (define %nscd-default-caches
1119 ;; Caches that we want to enable by default. Note that when providing an
1120 ;; empty nscd.conf, all caches are disabled.
1121 (list (nscd-cache (database 'hosts)
1123 ;; Aggressively cache the host name cache to improve
1124 ;; privacy and resilience.
1125 (positive-time-to-live (* 3600 12))
1126 (negative-time-to-live 20)
1129 (nscd-cache (database 'services)
1131 ;; Services are unlikely to change, so we can be even more
1133 (positive-time-to-live (* 3600 24))
1134 (negative-time-to-live 3600)
1135 (check-files? #t) ;check /etc/services changes
1138 (define %nscd-default-configuration
1139 ;; Default nscd configuration.
1140 (nscd-configuration))
1142 (define (nscd.conf-file config)
1143 "Return the @file{nscd.conf} configuration file for @var{config}, an
1144 @code{<nscd-configuration>} object."
1145 (define cache->config
1147 (($ <nscd-cache> (= symbol->string database)
1148 positive-ttl negative-ttl size check-files?
1149 persistent? shared? max-size propagate?)
1150 (string-append "\nenable-cache\t" database "\tyes\n"
1152 "positive-time-to-live\t" database "\t"
1153 (number->string positive-ttl) "\n"
1154 "negative-time-to-live\t" database "\t"
1155 (number->string negative-ttl) "\n"
1156 "suggested-size\t" database "\t"
1157 (number->string size) "\n"
1158 "check-files\t" database "\t"
1159 (if check-files? "yes\n" "no\n")
1160 "persistent\t" database "\t"
1161 (if persistent? "yes\n" "no\n")
1162 "shared\t" database "\t"
1163 (if shared? "yes\n" "no\n")
1164 "max-db-size\t" database "\t"
1165 (number->string max-size) "\n"
1166 "auto-propagate\t" database "\t"
1167 (if propagate? "yes\n" "no\n")))))
1170 (($ <nscd-configuration> log-file debug-level caches)
1171 (plain-file "nscd.conf"
1173 # Configuration of libc's name service cache daemon (nscd).\n\n"
1175 (string-append "logfile\t" log-file)
1179 (string-append "debug-level\t"
1180 (number->string debug-level))
1184 (map cache->config caches)))))))
1186 (define (nscd-action-procedure nscd config option)
1187 ;; XXX: This is duplicated from mcron; factorize.
1188 #~(lambda (_ . args)
1189 ;; Run 'nscd' in a pipe so we can explicitly redirect its output to
1190 ;; 'current-output-port', which at this stage is bound to the client
1192 (let ((pipe (apply open-pipe* OPEN_READ #$nscd
1193 "-f" #$config #$option args)))
1195 (match (read-line pipe 'concat)
1197 (catch 'system-error
1199 (zero? (close-pipe pipe)))
1201 ;; There's a race with the SIGCHLD handler, which could
1202 ;; call 'waitpid' before 'close-pipe' above does. If we
1203 ;; get ECHILD, that means we lost the race; in that case, we
1204 ;; cannot tell what the exit code was (FIXME).
1205 (or (= ECHILD (system-error-errno args))
1206 (apply throw args)))))
1211 (define (nscd-actions nscd config)
1212 "Return Shepherd actions for NSCD."
1213 ;; Make this functionality available as actions because that's a simple way
1214 ;; to run the right 'nscd' binary with the right config file.
1215 (list (shepherd-action
1217 (documentation "Display statistics about nscd usage.")
1218 (procedure (nscd-action-procedure nscd config "--statistics")))
1222 "Invalidate the given cache--e.g., 'hosts' for host name lookups.")
1223 (procedure (nscd-action-procedure nscd config "--invalidate")))))
1225 (define (nscd-shepherd-service config)
1226 "Return a shepherd service for CONFIG, an <nscd-configuration> object."
1227 (let ((nscd (file-append (nscd-configuration-glibc config)
1229 (nscd.conf (nscd.conf-file config))
1230 (name-services (nscd-configuration-name-services config)))
1231 (list (shepherd-service
1232 (documentation "Run libc's name service cache daemon (nscd).")
1234 (requirement '(user-processes))
1235 (start #~(make-forkexec-constructor
1236 (list #$nscd "-f" #$nscd.conf "--foreground")
1238 ;; Wait for the PID file. However, the PID file is
1239 ;; written before nscd is actually listening on its
1241 #:pid-file "/var/run/nscd/nscd.pid"
1243 #:environment-variables
1244 (list (string-append "LD_LIBRARY_PATH="
1247 (string-append dir "/lib"))
1248 (list #$@name-services))
1250 (stop #~(make-kill-destructor))
1251 (modules `((ice-9 popen) ;for the actions
1254 ,@%default-modules))
1255 (actions (nscd-actions nscd nscd.conf))))))
1257 (define nscd-activation
1258 ;; Actions to take before starting nscd.
1260 (use-modules (guix build utils))
1261 (mkdir-p "/var/run/nscd")
1262 (mkdir-p "/var/db/nscd") ;for the persistent cache
1264 ;; In libc 2.25 nscd uses inotify to watch /etc/resolv.conf, but only if
1265 ;; that file exists when it is started. Thus create it here. Note: on
1266 ;; some systems, such as when NetworkManager is used, /etc/resolv.conf
1267 ;; is a symlink, hence 'lstat'.
1268 (unless (false-if-exception (lstat "/etc/resolv.conf"))
1269 (call-with-output-file "/etc/resolv.conf"
1271 (display "# This is a placeholder.\n" port))))))
1273 (define nscd-service-type
1274 (service-type (name 'nscd)
1276 (list (service-extension activation-service-type
1277 (const nscd-activation))
1278 (service-extension shepherd-root-service-type
1279 nscd-shepherd-service)))
1281 ;; This can be extended by providing additional name services
1282 ;; such as nss-mdns.
1283 (compose concatenate)
1284 (extend (lambda (config name-services)
1287 (name-services (append
1288 (nscd-configuration-name-services config)
1290 (default-value %nscd-default-configuration)
1292 "Runs libc's @dfn{name service cache daemon} (nscd) with the
1293 given configuration---an @code{<nscd-configuration>} object. @xref{Name
1294 Service Switch}, for an example.")))
1296 (define* (nscd-service #:optional (config %nscd-default-configuration))
1297 "Return a service that runs libc's name service cache daemon (nscd) with the
1298 given @var{config}---an @code{<nscd-configuration>} object. @xref{Name
1299 Service Switch}, for an example."
1300 (service nscd-service-type config))
1303 (define-record-type* <syslog-configuration>
1304 syslog-configuration make-syslog-configuration
1305 syslog-configuration?
1306 (syslogd syslog-configuration-syslogd
1307 (default (file-append inetutils "/libexec/syslogd")))
1308 (config-file syslog-configuration-config-file
1309 (default %default-syslog.conf)))
1311 (define syslog-service-type
1312 (shepherd-service-type
1316 (documentation "Run the syslog daemon (syslogd).")
1317 (provision '(syslogd))
1318 (requirement '(user-processes))
1319 (start #~(let ((spawn (make-forkexec-constructor
1320 (list #$(syslog-configuration-syslogd config)
1322 #$(syslog-configuration-config-file config))
1323 #:pid-file "/var/run/syslog.pid")))
1325 ;; Set the umask such that file permissions are #o640.
1326 (let ((mask (umask #o137))
1330 (stop #~(make-kill-destructor))))))
1332 ;; Snippet adapted from the GNU inetutils manual.
1333 (define %default-syslog.conf
1334 (plain-file "syslog.conf" "
1335 # Log all error messages, authentication messages of
1336 # level notice or higher and anything of level err or
1337 # higher to the console.
1338 # Don't log private authentication messages!
1339 *.alert;auth.notice;authpriv.none /dev/console
1341 # Log anything (except mail) of level info or higher.
1342 # Don't log private authentication messages!
1343 *.info;mail.none;authpriv.none /var/log/messages
1345 # Like /var/log/messages, but also including \"debug\"-level logs.
1346 *.debug;mail.none;authpriv.none /var/log/debug
1348 # Same, in a different place.
1349 *.info;mail.none;authpriv.none /dev/tty12
1351 # The authpriv file has restricted access.
1352 authpriv.* /var/log/secure
1354 # Log all the mail messages in one place.
1355 mail.* /var/log/maillog
1358 (define* (syslog-service #:optional (config (syslog-configuration)))
1359 "Return a service that runs @command{syslogd} and takes
1360 @var{<syslog-configuration>} as a parameter.
1362 @xref{syslogd invocation,,, inetutils, GNU Inetutils}, for more
1363 information on the configuration file syntax."
1364 (service syslog-service-type config))
1367 (define pam-limits-service-type
1368 (let ((security-limits
1369 ;; Create /etc/security containing the provided "limits.conf" file.
1370 (lambda (limits-file)
1376 (stat #$limits-file)
1377 (symlink #$limits-file
1378 (string-append #$output "/limits.conf"))))))))
1381 (let ((pam-limits (pam-entry
1382 (control "required")
1383 (module "pam_limits.so")
1384 (arguments '("conf=/etc/security/limits.conf")))))
1385 (if (member (pam-service-name pam)
1386 '("login" "su" "slim" "gdm-password" "sddm"))
1389 (session (cons pam-limits
1390 (pam-service-session pam))))
1395 (list (service-extension etc-service-type security-limits)
1396 (service-extension pam-root-service-type
1397 (lambda _ (list pam-extension)))))
1399 "Install the specified resource usage limits by populating
1400 @file{/etc/security/limits.conf} and using the @code{pam_limits}
1401 authentication module."))))
1403 (define* (pam-limits-service #:optional (limits '()))
1404 "Return a service that makes selected programs respect the list of
1405 pam-limits-entry specified in LIMITS via pam_limits.so."
1406 (service pam-limits-service-type
1407 (plain-file "limits.conf"
1408 (string-join (map pam-limits-entry->string limits)
1416 (define* (guix-build-accounts count #:key
1419 "Return a list of COUNT user accounts for Guix build users with the given
1421 (unfold (cut > <> count)
1424 (name (format #f "guixbuilder~2,'0d" n))
1428 ;; guix-daemon expects GROUP to be listed as a
1429 ;; supplementary group too:
1430 ;; <http://lists.gnu.org/archive/html/bug-guix/2013-01/msg00239.html>.
1431 (supplementary-groups (list group "kvm"))
1433 (comment (format #f "Guix Build User ~2d" n))
1434 (home-directory "/var/empty")
1435 (shell (file-append shadow "/sbin/nologin"))))
1440 ;; Select (guix …) and (gnu …) modules, except (guix config).
1442 (('guix 'config) #f)
1443 (('guix rest ...) #t)
1444 (('gnu rest ...) #t)
1447 (define (substitute-key-authorization keys guix)
1448 "Return a gexp with code to register KEYS, a list of files containing 'guix
1449 archive' public keys, with GUIX."
1451 (with-extensions (list guile-gcrypt)
1452 (with-imported-modules `(((guix config) => ,(make-config.scm))
1453 ,@(source-module-closure '((guix pki))
1454 #:select? not-config?))
1455 (computed-file "acl"
1457 (use-modules (guix pki)
1463 (call-with-input-file file
1464 (compose string->canonical-sexp
1468 (call-with-output-file #$output
1470 (write-acl (public-keys->acl keys)
1473 (with-imported-modules '((guix build utils))
1475 (use-modules (guix build utils))
1477 (unless (file-exists? "/etc/guix/acl")
1478 (mkdir-p "/etc/guix")
1479 (copy-file #+default-acl "/etc/guix/acl")
1480 (chmod "/etc/guix/acl" #o600)))))
1482 (define %default-authorized-guix-keys
1483 ;; List of authorized substitute keys.
1484 (list (file-append guix "/share/guix/berlin.guixsd.org.pub")))
1486 (define-record-type* <guix-configuration>
1487 guix-configuration make-guix-configuration
1489 (guix guix-configuration-guix ;<package>
1491 (build-group guix-configuration-build-group ;string
1492 (default "guixbuild"))
1493 (build-accounts guix-configuration-build-accounts ;integer
1495 (authorize-key? guix-configuration-authorize-key? ;Boolean
1497 (authorized-keys guix-configuration-authorized-keys ;list of gexps
1498 (default %default-authorized-guix-keys))
1499 (use-substitutes? guix-configuration-use-substitutes? ;Boolean
1501 (substitute-urls guix-configuration-substitute-urls ;list of strings
1502 (default %default-substitute-urls))
1503 (chroot-directories guix-configuration-chroot-directories ;list of file-like/strings
1505 (max-silent-time guix-configuration-max-silent-time ;integer
1507 (timeout guix-configuration-timeout ;integer
1509 (log-compression guix-configuration-log-compression
1511 (extra-options guix-configuration-extra-options ;list of strings
1513 (log-file guix-configuration-log-file ;string
1514 (default "/var/log/guix-daemon.log"))
1515 (http-proxy guix-http-proxy ;string | #f
1517 (tmpdir guix-tmpdir ;string | #f
1520 (define %default-guix-configuration
1521 (guix-configuration))
1523 (define shepherd-set-http-proxy-action
1524 ;; Shepherd action to change the HTTP(S) proxy.
1526 (name 'set-http-proxy)
1528 "Change the HTTP(S) proxy used by 'guix-daemon' and restart it.")
1529 (procedure #~(lambda* (_ #:optional proxy)
1530 (let ((environment (environ)))
1531 ;; A bit of a hack: communicate PROXY to the 'start'
1532 ;; method via environment variables.
1535 (format #t "changing HTTP/HTTPS \
1536 proxy of 'guix-daemon' to ~s...~%"
1538 (setenv "http_proxy" proxy))
1540 (format #t "clearing HTTP/HTTPS \
1541 proxy of 'guix-daemon'...~%")
1542 (unsetenv "http_proxy")))
1543 (action 'guix-daemon 'restart)
1544 (environ environment)
1547 (define (guix-shepherd-service config)
1548 "Return a <shepherd-service> for the Guix daemon service with CONFIG."
1549 (match-record config <guix-configuration>
1550 (guix build-group build-accounts authorize-key? authorized-keys
1551 use-substitutes? substitute-urls max-silent-time timeout
1552 log-compression extra-options log-file http-proxy tmpdir
1554 (list (shepherd-service
1555 (documentation "Run the Guix daemon.")
1556 (provision '(guix-daemon))
1557 (requirement '(user-processes))
1558 (actions (list shepherd-set-http-proxy-action))
1559 (modules '((srfi srfi-1)))
1563 ;; HTTP/HTTPS proxy. The 'http_proxy' variable is set by
1564 ;; the 'set-http-proxy' action.
1565 (or (getenv "http_proxy") #$http-proxy))
1568 (cons* #$(file-append guix "/bin/guix-daemon")
1569 "--build-users-group" #$build-group
1570 "--max-silent-time" #$(number->string max-silent-time)
1571 "--timeout" #$(number->string timeout)
1572 "--log-compression" #$(symbol->string log-compression)
1573 #$@(if use-substitutes?
1575 '("--no-substitutes"))
1576 "--substitute-urls" #$(string-join substitute-urls)
1579 ;; Add CHROOT-DIRECTORIES and all their dependencies
1580 ;; (if these are store items) to the chroot.
1581 (append-map (lambda (file)
1582 (append-map (lambda (directory)
1583 (list "--chroot-directory"
1585 (call-with-input-file file
1587 '#$(map references-file
1588 chroot-directories)))
1590 #:environment-variables
1591 (append (list #$@(if tmpdir
1592 (list (string-append "TMPDIR=" tmpdir))
1595 ;; Make sure we run in a UTF-8 locale so that
1596 ;; 'guix offload' correctly restores nars that
1597 ;; contain UTF-8 file names such as
1599 ;; <https://bugs.gnu.org/32942>.
1600 (string-append "GUIX_LOCPATH="
1601 #$glibc-utf8-locales
1603 "LC_ALL=en_US.utf8")
1605 (list (string-append "http_proxy=" proxy)
1606 (string-append "https_proxy=" proxy))
1609 #:log-file #$log-file)))
1610 (stop #~(make-kill-destructor))))))
1612 (define (guix-accounts config)
1613 "Return the user accounts and user groups for CONFIG."
1615 (($ <guix-configuration> _ build-group build-accounts)
1620 ;; Use a fixed GID so that we can create the store with the right
1623 (guix-build-accounts build-accounts
1624 #:group build-group)))))
1626 (define (guix-activation config)
1627 "Return the activation gexp for CONFIG."
1629 (($ <guix-configuration> guix build-group build-accounts authorize-key? keys)
1630 ;; Assume that the store has BUILD-GROUP as its group. We could
1631 ;; otherwise call 'chown' here, but the problem is that on a COW overlayfs,
1632 ;; chown leads to an entire copy of the tree, which is a bad idea.
1634 ;; Optionally authorize substitute server keys.
1636 (substitute-key-authorization keys guix)
1639 (define* (references-file item #:optional (name "references"))
1640 "Return a file that contains the list of references of ITEM."
1641 (if (struct? item) ;lowerable object
1643 (with-imported-modules (source-module-closure
1644 '((guix build store-copy)))
1646 (use-modules (guix build store-copy))
1648 (call-with-output-file #$output
1650 (write (map store-info-item
1651 (call-with-input-file "graph"
1652 read-reference-graph))
1654 #:options `(#:local-build? #f
1655 #:references-graphs (("graph" ,item))))
1656 (plain-file name "()")))
1658 (define guix-service-type
1662 (list (service-extension shepherd-root-service-type guix-shepherd-service)
1663 (service-extension account-service-type guix-accounts)
1664 (service-extension activation-service-type guix-activation)
1665 (service-extension profile-service-type
1666 (compose list guix-configuration-guix))))
1668 ;; Extensions can specify extra directories to add to the build chroot.
1669 (compose concatenate)
1670 (extend (lambda (config directories)
1674 (append (guix-configuration-chroot-directories config)
1677 (default-value (guix-configuration))
1679 "Run the build daemon of GNU@tie{}Guix, aka. @command{guix-daemon}.")))
1681 (define-deprecated (guix-service #:optional
1682 (config %default-guix-configuration))
1684 "Return a service that runs the Guix build daemon according to
1686 (service guix-service-type config))
1689 (define-record-type* <guix-publish-configuration>
1690 guix-publish-configuration make-guix-publish-configuration
1691 guix-publish-configuration?
1692 (guix guix-publish-configuration-guix ;package
1694 (port guix-publish-configuration-port ;number
1696 (host guix-publish-configuration-host ;string
1697 (default "localhost"))
1698 (compression guix-publish-configuration-compression
1700 (default (default-compression this-record
1701 (current-source-location))))
1702 (compression-level %guix-publish-configuration-compression-level ;deprecated
1704 (nar-path guix-publish-configuration-nar-path ;string
1706 (cache guix-publish-configuration-cache ;#f | string
1708 (workers guix-publish-configuration-workers ;#f | integer
1710 (ttl guix-publish-configuration-ttl ;#f | integer
1713 (define-deprecated (guix-publish-configuration-compression-level config)
1714 "Return a compression level, the old way."
1715 (match (guix-publish-configuration-compression config)
1716 (((_ level) _ ...) level)))
1718 (define (default-compression config properties)
1719 "Return the default 'guix publish' compression according to CONFIG, and
1720 raise a deprecation warning if the 'compression-level' field was used."
1721 (match (%guix-publish-configuration-compression-level config)
1725 (warn-about-deprecation 'compression-level properties
1726 #:replacement 'compression)
1727 `(("gzip" ,level)))))
1729 (define (guix-publish-shepherd-service config)
1730 (define (config->compression-options config)
1731 (match (guix-publish-configuration-compression config)
1732 (() ;empty list means "no compression"
1735 (append-map (match-lambda
1737 `("-C" ,(string-append type ":"
1738 (number->string level)))))
1741 (match-record config <guix-publish-configuration>
1742 (guix port host nar-path cache workers ttl)
1743 (list (shepherd-service
1744 (provision '(guix-publish))
1745 (requirement '(guix-daemon))
1746 (start #~(make-forkexec-constructor
1747 (list #$(file-append guix "/bin/guix")
1748 "publish" "-u" "guix-publish"
1749 "-p" #$(number->string port)
1750 #$@(config->compression-options config)
1751 (string-append "--nar-path=" #$nar-path)
1752 (string-append "--listen=" #$host)
1754 #~((string-append "--workers="
1759 #~((string-append "--ttl="
1760 #$(number->string ttl)
1764 #~((string-append "--cache=" #$cache))
1767 ;; Make sure we run in a UTF-8 locale so we can produce
1768 ;; nars for packages that contain UTF-8 file names such
1769 ;; as 'nss-certs'. See <https://bugs.gnu.org/26948>.
1770 #:environment-variables
1771 (list (string-append "GUIX_LOCPATH="
1772 #$glibc-utf8-locales "/lib/locale")
1773 "LC_ALL=en_US.utf8")
1774 #:log-file "/var/log/guix-publish.log"))
1775 (stop #~(make-kill-destructor))))))
1777 (define %guix-publish-accounts
1778 (list (user-group (name "guix-publish") (system? #t))
1780 (name "guix-publish")
1781 (group "guix-publish")
1783 (comment "guix publish user")
1784 (home-directory "/var/empty")
1785 (shell (file-append shadow "/sbin/nologin")))))
1787 (define %guix-publish-log-rotations
1789 (files (list "/var/log/guix-publish.log")))))
1791 (define (guix-publish-activation config)
1792 (let ((cache (guix-publish-configuration-cache config)))
1794 (with-imported-modules '((guix build utils))
1796 (use-modules (guix build utils))
1799 (let* ((pw (getpw "guix-publish"))
1800 (uid (passwd:uid pw))
1801 (gid (passwd:gid pw)))
1802 (chown #$cache uid gid))))
1805 (define guix-publish-service-type
1806 (service-type (name 'guix-publish)
1808 (list (service-extension shepherd-root-service-type
1809 guix-publish-shepherd-service)
1810 (service-extension account-service-type
1811 (const %guix-publish-accounts))
1812 (service-extension rottlog-service-type
1813 (const %guix-publish-log-rotations))
1814 (service-extension activation-service-type
1815 guix-publish-activation)))
1816 (default-value (guix-publish-configuration))
1818 "Add a Shepherd service running @command{guix publish}, a
1819 command that allows you to share pre-built binaries with others over HTTP.")))
1821 (define-deprecated (guix-publish-service #:key (guix guix)
1822 (port 80) (host "localhost"))
1823 guix-publish-service-type
1824 "Return a service that runs @command{guix publish} listening on @var{host}
1825 and @var{port} (@pxref{Invoking guix publish}).
1827 This assumes that @file{/etc/guix} already contains a signing key pair as
1828 created by @command{guix archive --generate-key} (@pxref{Invoking guix
1829 archive}). If that is not the case, the service will fail to start."
1831 (service guix-publish-service-type
1832 (guix-publish-configuration (guix guix) (port port) (host host))))
1839 (define-record-type* <udev-configuration>
1840 udev-configuration make-udev-configuration
1842 (udev udev-configuration-udev ;<package>
1844 (rules udev-configuration-rules ;list of <package>
1847 (define (udev-rules-union packages)
1848 "Return the union of the @code{lib/udev/rules.d} directories found in each
1849 item of @var{packages}."
1851 (with-imported-modules '((guix build union)
1854 (use-modules (guix build union)
1859 (define %standard-locations
1860 '("/lib/udev/rules.d" "/libexec/udev/rules.d"))
1862 (define (rules-sub-directory directory)
1863 ;; Return the sub-directory of DIRECTORY containing udev rules, or
1864 ;; #f if none was found.
1865 (find directory-exists?
1866 (map (cut string-append directory <>) %standard-locations)))
1868 (mkdir-p (string-append #$output "/lib/udev"))
1869 (union-build (string-append #$output "/lib/udev/rules.d")
1870 (filter-map rules-sub-directory '#$packages)))))
1872 (computed-file "udev-rules" build))
1874 (define (udev-rule file-name contents)
1875 "Return a directory with a udev rule file FILE-NAME containing CONTENTS."
1876 (computed-file file-name
1877 (with-imported-modules '((guix build utils))
1879 (use-modules (guix build utils))
1882 (string-append #$output "/lib/udev/rules.d"))
1885 (call-with-output-file
1886 (string-append rules.d "/" #$file-name)
1888 (display #$contents port)))))))
1890 (define (file->udev-rule file-name file)
1891 "Return a directory with a udev rule file FILE-NAME which is a copy of FILE."
1892 (computed-file file-name
1893 (with-imported-modules '((guix build utils))
1895 (use-modules (guix build utils))
1898 (string-append #$output "/lib/udev/rules.d"))
1900 (define file-copy-dest
1901 (string-append rules.d "/" #$file-name))
1904 (copy-file #$file file-copy-dest)))))
1906 (define kvm-udev-rule
1907 ;; Return a directory with a udev rule that changes the group of /dev/kvm to
1908 ;; "kvm" and makes it #o660. Apparently QEMU-KVM used to ship this rule,
1909 ;; but now we have to add it by ourselves.
1911 ;; Build users are part of the "kvm" group, so we can fearlessly make
1912 ;; /dev/kvm 660 (see <http://bugs.gnu.org/18994>, for background.)
1913 (udev-rule "90-kvm.rules"
1914 "KERNEL==\"kvm\", GROUP=\"kvm\", MODE=\"0660\"\n"))
1916 (define udev-shepherd-service
1917 ;; Return a <shepherd-service> for UDEV with RULES.
1919 (($ <udev-configuration> udev rules)
1920 (let* ((rules (udev-rules-union (cons* udev kvm-udev-rule rules)))
1921 (udev.conf (computed-file "udev.conf"
1922 #~(call-with-output-file #$output
1925 "udev_rules=\"~a/lib/udev/rules.d\"\n"
1931 ;; Udev needs /dev to be a 'devtmpfs' mount so that new device nodes can
1933 ;; <http://www.linuxfromscratch.org/lfs/view/development/chapter07/udev.html>.
1934 (requirement '(root-file-system))
1936 (documentation "Populate the /dev directory, dynamically.")
1938 (with-imported-modules (source-module-closure
1939 '((gnu build linux-boot)))
1942 ;; 'udevd' from eudev.
1943 #$(file-append udev "/sbin/udevd"))
1945 (define (wait-for-udevd)
1946 ;; Wait until someone's listening on udevd's control
1948 (let ((sock (socket AF_UNIX SOCK_SEQPACKET 0)))
1950 (catch 'system-error
1952 (connect sock PF_UNIX "/run/udev/control")
1955 (format #t "waiting for udevd...~%")
1959 ;; Allow udev to find the modules.
1960 (setenv "LINUX_MODULE_DIRECTORY"
1961 "/run/booted-system/kernel/lib/modules")
1963 (let* ((kernel-release
1964 (utsname:release (uname)))
1965 (linux-module-directory
1966 (getenv "LINUX_MODULE_DIRECTORY"))
1968 (string-append linux-module-directory "/"
1970 (old-umask (umask #o022)))
1971 ;; If we're in a container, DIRECTORY might not exist,
1972 ;; for instance because the host runs a different
1973 ;; kernel. In that case, skip it; we'll just miss a few
1974 ;; nodes like /dev/fuse.
1975 (when (file-exists? directory)
1976 (make-static-device-nodes directory))
1979 (let ((pid (fork+exec-command (list udevd)
1980 #:environment-variables
1982 ;; The first one is for udev, the second one for
1984 (string-append "UDEV_CONFIG_FILE=" #$udev.conf)
1985 (string-append "EUDEV_RULES_DIRECTORY="
1987 rules "/lib/udev/rules.d"))
1988 (string-append "LINUX_MODULE_DIRECTORY="
1989 (getenv "LINUX_MODULE_DIRECTORY"))
1990 (default-environment-variables)))))
1991 ;; Wait until udevd is up and running. This appears to
1992 ;; be needed so that the events triggered below are
1993 ;; actually handled.
1996 ;; Trigger device node creation.
1997 (system* #$(file-append udev "/bin/udevadm")
1998 "trigger" "--action=add")
2000 ;; Wait for things to settle down.
2001 (system* #$(file-append udev "/bin/udevadm")
2004 (stop #~(make-kill-destructor))
2006 ;; When halting the system, 'udev' is actually killed by
2007 ;; 'user-processes', i.e., before its own 'stop' method was called.
2008 ;; Thus, make sure it is not respawned.
2010 ;; We need additional modules.
2011 (modules `((gnu build linux-boot) ;'make-static-device-nodes'
2012 ,@%default-modules))
2014 (actions (list (shepherd-action
2016 (documentation "Display the directory containing
2017 the udev rules in use.")
2018 (procedure #~(lambda (_)
2020 (newline))))))))))))
2022 (define udev-service-type
2023 (service-type (name 'udev)
2025 (list (service-extension shepherd-root-service-type
2026 udev-shepherd-service)))
2028 (compose concatenate) ;concatenate the list of rules
2029 (extend (lambda (config rules)
2031 (($ <udev-configuration> udev initial-rules)
2034 (rules (append initial-rules rules)))))))
2035 (default-value (udev-configuration))
2037 "Run @command{udev}, which populates the @file{/dev}
2038 directory dynamically. Get extra rules from the packages listed in the
2039 @code{rules} field of its value, @code{udev-configuration} object.")))
2041 (define* (udev-service #:key (udev eudev) (rules '()))
2042 "Run @var{udev}, which populates the @file{/dev} directory dynamically. Get
2043 extra rules from the packages listed in @var{rules}."
2044 (service udev-service-type
2045 (udev-configuration (udev udev) (rules rules))))
2047 (define* (udev-rules-service name rules #:key (groups '()))
2048 "Return a service that extends udev-service-type with RULES and
2049 account-service-type with GROUPS as system groups. This works by creating a
2050 singleton service type NAME-udev-rules, of which the returned service is an
2052 (let* ((name (symbol-append name '-udev-rules))
2054 (const (map (lambda (group)
2055 (user-group (name group) (system? #t)))
2057 (udev-extension (const (list rules)))
2062 account-service-type account-extension)
2064 udev-service-type udev-extension))))))
2067 (define swap-service-type
2068 (shepherd-service-type
2072 (if (string-prefix? "/dev/mapper/" device)
2073 (list (symbol-append 'device-mapping-
2074 (string->symbol (basename device))))
2078 (provision (list (symbol-append 'swap- (string->symbol device))))
2079 (requirement `(udev ,@requirement))
2080 (documentation "Enable the given swap device.")
2082 (restart-on-EINTR (swapon #$device))
2085 (restart-on-EINTR (swapoff #$device))
2089 (define (swap-service device)
2090 "Return a service that uses @var{device} as a swap device."
2091 (service swap-service-type device))
2093 (define %default-gpm-options
2094 ;; Default options for GPM.
2095 '("-m" "/dev/input/mice" "-t" "ps2"))
2097 (define-record-type* <gpm-configuration>
2098 gpm-configuration make-gpm-configuration gpm-configuration?
2099 (gpm gpm-configuration-gpm ;package
2101 (options gpm-configuration-options ;list of strings
2102 (default %default-gpm-options)))
2104 (define gpm-shepherd-service
2106 (($ <gpm-configuration> gpm options)
2107 (list (shepherd-service
2108 (requirement '(udev))
2111 ;; 'gpm' runs in the background and sets a PID file.
2112 ;; Note that it requires running as "root".
2113 (false-if-exception (delete-file "/var/run/gpm.pid"))
2114 (fork+exec-command (list #$(file-append gpm "/sbin/gpm")
2117 ;; Wait for the PID file to appear; declare failure if
2118 ;; it doesn't show up.
2120 (or (file-exists? "/var/run/gpm.pid")
2128 ;; Return #f if successfully stopped.
2129 (not (zero? (system* #$(file-append gpm "/sbin/gpm")
2132 (define gpm-service-type
2133 (service-type (name 'gpm)
2135 (list (service-extension shepherd-root-service-type
2136 gpm-shepherd-service)))
2137 (default-value (gpm-configuration))
2139 "Run GPM, the general-purpose mouse daemon, with the given
2140 command-line options. GPM allows users to use the mouse in the console,
2141 notably to select, copy, and paste text. The default options use the
2142 @code{ps2} protocol, which works for both USB and PS/2 mice.")))
2144 (define-deprecated (gpm-service #:key (gpm gpm)
2145 (options %default-gpm-options))
2147 "Run @var{gpm}, the general-purpose mouse daemon, with the given
2148 command-line @var{options}. GPM allows users to use the mouse in the console,
2149 notably to select, copy, and paste text. The default value of @var{options}
2150 uses the @code{ps2} protocol, which works for both USB and PS/2 mice.
2152 This service is not part of @var{%base-services}."
2153 ;; To test in QEMU, use "-usbdevice mouse" and then, in the monitor, use
2154 ;; "info mice" and "mouse_set X" to use the right mouse.
2155 (service gpm-service-type
2156 (gpm-configuration (gpm gpm) (options options))))
2158 (define-record-type* <kmscon-configuration>
2159 kmscon-configuration make-kmscon-configuration
2160 kmscon-configuration?
2161 (kmscon kmscon-configuration-kmscon
2163 (virtual-terminal kmscon-configuration-virtual-terminal)
2164 (login-program kmscon-configuration-login-program
2165 (default (file-append shadow "/bin/login")))
2166 (login-arguments kmscon-configuration-login-arguments
2168 (auto-login kmscon-configuration-auto-login
2170 (hardware-acceleration? kmscon-configuration-hardware-acceleration?
2171 (default #f))) ; #t causes failure
2173 (define kmscon-service-type
2174 (shepherd-service-type
2177 (let ((kmscon (kmscon-configuration-kmscon config))
2178 (virtual-terminal (kmscon-configuration-virtual-terminal config))
2179 (login-program (kmscon-configuration-login-program config))
2180 (login-arguments (kmscon-configuration-login-arguments config))
2181 (auto-login (kmscon-configuration-auto-login config))
2182 (hardware-acceleration? (kmscon-configuration-hardware-acceleration? config)))
2184 (define kmscon-command
2186 #$(file-append kmscon "/bin/kmscon") "--login"
2187 "--vt" #$virtual-terminal
2188 "--no-switchvt" ;Prevent a switch to the virtual terminal.
2189 #$@(if hardware-acceleration? '("--hwaccel") '())
2191 #$login-program #$@login-arguments
2197 (documentation "kmscon virtual terminal")
2198 (requirement '(user-processes udev dbus-system))
2199 (provision (list (symbol-append 'term- (string->symbol virtual-terminal))))
2200 (start #~(make-forkexec-constructor #$kmscon-command))
2201 (stop #~(make-kill-destructor)))))))
2203 (define-record-type* <static-networking>
2204 static-networking make-static-networking
2206 (interface static-networking-interface)
2207 (ip static-networking-ip)
2208 (netmask static-networking-netmask
2210 (gateway static-networking-gateway ;FIXME: doesn't belong here
2212 (provision static-networking-provision
2214 (requirement static-networking-requirement
2216 (name-servers static-networking-name-servers ;FIXME: doesn't belong here
2219 (define static-networking-shepherd-service
2221 (($ <static-networking> interface ip netmask gateway provision
2222 requirement name-servers)
2223 (let ((loopback? (and provision (memq 'loopback provision))))
2227 "Bring up the networking interface using a static IP address.")
2228 (requirement requirement)
2229 (provision (or provision
2230 (list (symbol-append 'networking-
2231 (string->symbol interface)))))
2234 ;; Return #t if successfully started.
2235 (let* ((addr (inet-pton AF_INET #$ip))
2236 (sockaddr (make-socket-address AF_INET addr 0))
2237 (mask (and #$netmask
2238 (inet-pton AF_INET #$netmask)))
2240 (make-socket-address AF_INET
2242 (gateway (and #$gateway
2243 (inet-pton AF_INET #$gateway)))
2244 (gatewayaddr (and gateway
2245 (make-socket-address AF_INET
2247 (configure-network-interface #$interface sockaddr
2254 (let ((sock (socket AF_INET SOCK_DGRAM 0)))
2255 (add-network-route/gateway sock gatewayaddr)
2256 (close-port sock))))))
2258 ;; Return #f is successfully stopped.
2259 (let ((sock (socket AF_INET SOCK_STREAM 0)))
2261 (delete-network-route sock
2262 (make-socket-address
2263 AF_INET INADDR_ANY 0)))
2264 (set-network-interface-flags sock #$interface 0)
2269 (define (static-networking-etc-files interfaces)
2270 "Return a /etc/resolv.conf entry for INTERFACES or the empty list."
2271 (match (delete-duplicates
2272 (append-map static-networking-name-servers
2277 (let ((content (string-join
2278 (map (cut string-append "nameserver " <>)
2282 ,(plain-file "resolv.conf"
2284 # Generated by 'static-networking-service'.\n"
2287 (define (static-networking-shepherd-services interfaces)
2288 "Return the list of Shepherd services to bring up INTERFACES, a list of
2289 <static-networking> objects."
2290 (define (loopback? service)
2291 (memq 'loopback (shepherd-service-provision service)))
2293 (let ((services (map static-networking-shepherd-service interfaces)))
2294 (match (remove loopback? services)
2296 ;; There's no interface other than 'loopback', so we assume that the
2297 ;; 'networking' service will be provided by dhclient or similar.
2300 ;; Assume we're providing all the interfaces, and thus, provide a
2301 ;; 'networking' service.
2302 (cons (shepherd-service
2303 (provision '(networking))
2304 (requirement (append-map shepherd-service-provision
2306 (start #~(const #t))
2308 (documentation "Bring up all the networking interfaces."))
2311 (define static-networking-service-type
2312 ;; The service type for statically-defined network interfaces.
2313 (service-type (name 'static-networking)
2316 (service-extension shepherd-root-service-type
2317 static-networking-shepherd-services)
2318 (service-extension etc-service-type
2319 static-networking-etc-files)))
2320 (compose concatenate)
2323 "Turn up the specified network interfaces upon startup,
2324 with the given IP address, gateway, netmask, and so on. The value for
2325 services of this type is a list of @code{static-networking} objects, one per
2326 network interface.")))
2328 (define* (static-networking-service interface ip
2330 netmask gateway provision
2331 ;; Most interfaces require udev to be usable.
2332 (requirement '(udev))
2334 "Return a service that starts @var{interface} with address @var{ip}. If
2335 @var{netmask} is true, use it as the network mask. If @var{gateway} is true,
2336 it must be a string specifying the default network gateway.
2338 This procedure can be called several times, one for each network
2339 interface of interest. Behind the scenes what it does is extend
2340 @code{static-networking-service-type} with additional network interfaces
2342 (simple-service 'static-network-interface
2343 static-networking-service-type
2344 (list (static-networking (interface interface) (ip ip)
2345 (netmask netmask) (gateway gateway)
2346 (provision provision)
2347 (requirement requirement)
2348 (name-servers name-servers)))))
2351 (define %base-services
2352 ;; Convenience variable holding the basic services.
2353 (list (service login-service-type)
2355 (service virtual-terminal-service-type)
2356 (service console-font-service-type
2358 (cons tty %default-console-font))
2359 '("tty1" "tty2" "tty3" "tty4" "tty5" "tty6")))
2361 (service agetty-service-type (agetty-configuration
2362 (extra-options '("-L")) ; no carrier detect
2364 (tty #f))) ; automatic
2366 (service mingetty-service-type (mingetty-configuration
2368 (service mingetty-service-type (mingetty-configuration
2370 (service mingetty-service-type (mingetty-configuration
2372 (service mingetty-service-type (mingetty-configuration
2374 (service mingetty-service-type (mingetty-configuration
2376 (service mingetty-service-type (mingetty-configuration
2379 (service static-networking-service-type
2380 (list (static-networking (interface "lo")
2383 (provision '(loopback)))))
2385 (service urandom-seed-service-type)
2386 (service guix-service-type)
2387 (service nscd-service-type)
2389 (service rottlog-service-type)
2391 ;; The LVM2 rules are needed as soon as LVM2 or the device-mapper is
2392 ;; used, so enable them by default. The FUSE and ALSA rules are
2393 ;; less critical, but handy.
2394 (service udev-service-type
2396 (rules (list lvm2 fuse alsa-utils crda))))
2398 (service special-files-service-type
2399 `(("/bin/sh" ,(file-append bash "/bin/sh"))
2400 ("/usr/bin/env" ,(file-append coreutils "/bin/env"))))))
2402 ;;; base.scm ends here