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 (unless (file-exists? "/etc/guix/acl")
1480 (mkdir-p "/etc/guix")
1481 (copy-file #+default-acl "/etc/guix/acl")
1482 (chmod "/etc/guix/acl" #o600)))))
1484 (define %default-authorized-guix-keys
1485 ;; List of authorized substitute keys.
1486 (list (file-append guix "/share/guix/berlin.guix.gnu.org.pub")))
1488 (define-record-type* <guix-configuration>
1489 guix-configuration make-guix-configuration
1491 (guix guix-configuration-guix ;<package>
1493 (build-group guix-configuration-build-group ;string
1494 (default "guixbuild"))
1495 (build-accounts guix-configuration-build-accounts ;integer
1497 (authorize-key? guix-configuration-authorize-key? ;Boolean
1499 (authorized-keys guix-configuration-authorized-keys ;list of gexps
1500 (default %default-authorized-guix-keys))
1501 (use-substitutes? guix-configuration-use-substitutes? ;Boolean
1503 (substitute-urls guix-configuration-substitute-urls ;list of strings
1504 (default %default-substitute-urls))
1505 (chroot-directories guix-configuration-chroot-directories ;list of file-like/strings
1507 (max-silent-time guix-configuration-max-silent-time ;integer
1509 (timeout guix-configuration-timeout ;integer
1511 (log-compression guix-configuration-log-compression
1513 (extra-options guix-configuration-extra-options ;list of strings
1515 (log-file guix-configuration-log-file ;string
1516 (default "/var/log/guix-daemon.log"))
1517 (http-proxy guix-http-proxy ;string | #f
1519 (tmpdir guix-tmpdir ;string | #f
1522 (define %default-guix-configuration
1523 (guix-configuration))
1525 (define shepherd-set-http-proxy-action
1526 ;; Shepherd action to change the HTTP(S) proxy.
1528 (name 'set-http-proxy)
1530 "Change the HTTP(S) proxy used by 'guix-daemon' and restart it.")
1531 (procedure #~(lambda* (_ #:optional proxy)
1532 (let ((environment (environ)))
1533 ;; A bit of a hack: communicate PROXY to the 'start'
1534 ;; method via environment variables.
1537 (format #t "changing HTTP/HTTPS \
1538 proxy of 'guix-daemon' to ~s...~%"
1540 (setenv "http_proxy" proxy))
1542 (format #t "clearing HTTP/HTTPS \
1543 proxy of 'guix-daemon'...~%")
1544 (unsetenv "http_proxy")))
1545 (action 'guix-daemon 'restart)
1546 (environ environment)
1549 (define (guix-shepherd-service config)
1550 "Return a <shepherd-service> for the Guix daemon service with CONFIG."
1551 (match-record config <guix-configuration>
1552 (guix build-group build-accounts authorize-key? authorized-keys
1553 use-substitutes? substitute-urls max-silent-time timeout
1554 log-compression extra-options log-file http-proxy tmpdir
1556 (list (shepherd-service
1557 (documentation "Run the Guix daemon.")
1558 (provision '(guix-daemon))
1559 (requirement '(user-processes))
1560 (actions (list shepherd-set-http-proxy-action))
1561 (modules '((srfi srfi-1)
1563 (gnu build shepherd)))
1565 (with-imported-modules (source-module-closure
1566 '((gnu build shepherd)))
1569 ;; HTTP/HTTPS proxy. The 'http_proxy' variable is set by
1570 ;; the 'set-http-proxy' action.
1571 (or (getenv "http_proxy") #$http-proxy))
1573 (fork+exec-command/container
1574 (cons* #$(file-append guix "/bin/guix-daemon")
1575 "--build-users-group" #$build-group
1577 #$(number->string max-silent-time)
1578 "--timeout" #$(number->string timeout)
1580 #$(symbol->string log-compression)
1581 #$@(if use-substitutes?
1583 '("--no-substitutes"))
1584 "--substitute-urls" #$(string-join substitute-urls)
1587 ;; Add CHROOT-DIRECTORIES and all their dependencies
1588 ;; (if these are store items) to the chroot.
1591 (append-map (lambda (directory)
1592 (list "--chroot-directory"
1594 (call-with-input-file file
1596 '#$(map references-file
1597 chroot-directories)))
1599 ;; When running the installer, we need guix-daemon to
1600 ;; operate from within the same MNT namespace as the
1601 ;; installation container. In that case only, enter the
1602 ;; namespace of the process PID passed as start argument.
1604 ((pid) (string->number pid))
1607 #:environment-variables
1608 (append (list #$@(if tmpdir
1609 (list (string-append "TMPDIR=" tmpdir))
1612 ;; Make sure we run in a UTF-8 locale so that
1613 ;; 'guix offload' correctly restores nars
1614 ;; that contain UTF-8 file names such as
1616 ;; <https://bugs.gnu.org/32942>.
1617 (string-append "GUIX_LOCPATH="
1618 #$glibc-utf8-locales
1620 "LC_ALL=en_US.utf8")
1622 (list (string-append "http_proxy=" proxy)
1623 (string-append "https_proxy=" proxy))
1626 #:log-file #$log-file))))
1627 (stop #~(make-kill-destructor))))))
1629 (define (guix-accounts config)
1630 "Return the user accounts and user groups for CONFIG."
1632 (($ <guix-configuration> _ build-group build-accounts)
1637 ;; Use a fixed GID so that we can create the store with the right
1640 (guix-build-accounts build-accounts
1641 #:group build-group)))))
1643 (define (guix-activation config)
1644 "Return the activation gexp for CONFIG."
1646 (($ <guix-configuration> guix build-group build-accounts authorize-key? keys)
1647 ;; Assume that the store has BUILD-GROUP as its group. We could
1648 ;; otherwise call 'chown' here, but the problem is that on a COW overlayfs,
1649 ;; chown leads to an entire copy of the tree, which is a bad idea.
1651 ;; Optionally authorize substitute server keys.
1653 (substitute-key-authorization keys guix)
1656 (define* (references-file item #:optional (name "references"))
1657 "Return a file that contains the list of references of ITEM."
1658 (if (struct? item) ;lowerable object
1660 (with-imported-modules (source-module-closure
1661 '((guix build store-copy)))
1663 (use-modules (guix build store-copy))
1665 (call-with-output-file #$output
1667 (write (map store-info-item
1668 (call-with-input-file "graph"
1669 read-reference-graph))
1671 #:options `(#:local-build? #f
1672 #:references-graphs (("graph" ,item))))
1673 (plain-file name "()")))
1675 (define guix-service-type
1679 (list (service-extension shepherd-root-service-type guix-shepherd-service)
1680 (service-extension account-service-type guix-accounts)
1681 (service-extension activation-service-type guix-activation)
1682 (service-extension profile-service-type
1683 (compose list guix-configuration-guix))))
1685 ;; Extensions can specify extra directories to add to the build chroot.
1686 (compose concatenate)
1687 (extend (lambda (config directories)
1691 (append (guix-configuration-chroot-directories config)
1694 (default-value (guix-configuration))
1696 "Run the build daemon of GNU@tie{}Guix, aka. @command{guix-daemon}.")))
1698 (define-deprecated (guix-service #:optional
1699 (config %default-guix-configuration))
1701 "Return a service that runs the Guix build daemon according to
1703 (service guix-service-type config))
1706 (define-record-type* <guix-publish-configuration>
1707 guix-publish-configuration make-guix-publish-configuration
1708 guix-publish-configuration?
1709 (guix guix-publish-configuration-guix ;package
1711 (port guix-publish-configuration-port ;number
1713 (host guix-publish-configuration-host ;string
1714 (default "localhost"))
1715 (compression guix-publish-configuration-compression
1717 (default (default-compression this-record
1718 (current-source-location))))
1719 (compression-level %guix-publish-configuration-compression-level ;deprecated
1721 (nar-path guix-publish-configuration-nar-path ;string
1723 (cache guix-publish-configuration-cache ;#f | string
1725 (workers guix-publish-configuration-workers ;#f | integer
1727 (ttl guix-publish-configuration-ttl ;#f | integer
1730 (define-deprecated (guix-publish-configuration-compression-level config)
1731 "Return a compression level, the old way."
1732 (match (guix-publish-configuration-compression config)
1733 (((_ level) _ ...) level)))
1735 (define (default-compression config properties)
1736 "Return the default 'guix publish' compression according to CONFIG, and
1737 raise a deprecation warning if the 'compression-level' field was used."
1738 (match (%guix-publish-configuration-compression-level config)
1742 (warn-about-deprecation 'compression-level properties
1743 #:replacement 'compression)
1744 `(("gzip" ,level)))))
1746 (define (guix-publish-shepherd-service config)
1747 (define (config->compression-options config)
1748 (match (guix-publish-configuration-compression config)
1749 (() ;empty list means "no compression"
1752 (append-map (match-lambda
1754 `("-C" ,(string-append type ":"
1755 (number->string level)))))
1758 (match-record config <guix-publish-configuration>
1759 (guix port host nar-path cache workers ttl)
1760 (list (shepherd-service
1761 (provision '(guix-publish))
1762 (requirement '(guix-daemon))
1763 (start #~(make-forkexec-constructor
1764 (list #$(file-append guix "/bin/guix")
1765 "publish" "-u" "guix-publish"
1766 "-p" #$(number->string port)
1767 #$@(config->compression-options config)
1768 (string-append "--nar-path=" #$nar-path)
1769 (string-append "--listen=" #$host)
1771 #~((string-append "--workers="
1776 #~((string-append "--ttl="
1777 #$(number->string ttl)
1781 #~((string-append "--cache=" #$cache))
1784 ;; Make sure we run in a UTF-8 locale so we can produce
1785 ;; nars for packages that contain UTF-8 file names such
1786 ;; as 'nss-certs'. See <https://bugs.gnu.org/26948>.
1787 #:environment-variables
1788 (list (string-append "GUIX_LOCPATH="
1789 #$glibc-utf8-locales "/lib/locale")
1790 "LC_ALL=en_US.utf8")
1791 #:log-file "/var/log/guix-publish.log"))
1792 (stop #~(make-kill-destructor))))))
1794 (define %guix-publish-accounts
1795 (list (user-group (name "guix-publish") (system? #t))
1797 (name "guix-publish")
1798 (group "guix-publish")
1800 (comment "guix publish user")
1801 (home-directory "/var/empty")
1802 (shell (file-append shadow "/sbin/nologin")))))
1804 (define %guix-publish-log-rotations
1806 (files (list "/var/log/guix-publish.log")))))
1808 (define (guix-publish-activation config)
1809 (let ((cache (guix-publish-configuration-cache config)))
1811 (with-imported-modules '((guix build utils))
1813 (use-modules (guix build utils))
1816 (let* ((pw (getpw "guix-publish"))
1817 (uid (passwd:uid pw))
1818 (gid (passwd:gid pw)))
1819 (chown #$cache uid gid))))
1822 (define guix-publish-service-type
1823 (service-type (name 'guix-publish)
1825 (list (service-extension shepherd-root-service-type
1826 guix-publish-shepherd-service)
1827 (service-extension account-service-type
1828 (const %guix-publish-accounts))
1829 (service-extension rottlog-service-type
1830 (const %guix-publish-log-rotations))
1831 (service-extension activation-service-type
1832 guix-publish-activation)))
1833 (default-value (guix-publish-configuration))
1835 "Add a Shepherd service running @command{guix publish}, a
1836 command that allows you to share pre-built binaries with others over HTTP.")))
1838 (define-deprecated (guix-publish-service #:key (guix guix)
1839 (port 80) (host "localhost"))
1840 guix-publish-service-type
1841 "Return a service that runs @command{guix publish} listening on @var{host}
1842 and @var{port} (@pxref{Invoking guix publish}).
1844 This assumes that @file{/etc/guix} already contains a signing key pair as
1845 created by @command{guix archive --generate-key} (@pxref{Invoking guix
1846 archive}). If that is not the case, the service will fail to start."
1848 (service guix-publish-service-type
1849 (guix-publish-configuration (guix guix) (port port) (host host))))
1856 (define-record-type* <udev-configuration>
1857 udev-configuration make-udev-configuration
1859 (udev udev-configuration-udev ;<package>
1861 (rules udev-configuration-rules ;list of <package>
1864 (define (udev-rules-union packages)
1865 "Return the union of the @code{lib/udev/rules.d} directories found in each
1866 item of @var{packages}."
1868 (with-imported-modules '((guix build union)
1871 (use-modules (guix build union)
1876 (define %standard-locations
1877 '("/lib/udev/rules.d" "/libexec/udev/rules.d"))
1879 (define (rules-sub-directory directory)
1880 ;; Return the sub-directory of DIRECTORY containing udev rules, or
1881 ;; #f if none was found.
1882 (find directory-exists?
1883 (map (cut string-append directory <>) %standard-locations)))
1885 (mkdir-p (string-append #$output "/lib/udev"))
1886 (union-build (string-append #$output "/lib/udev/rules.d")
1887 (filter-map rules-sub-directory '#$packages)))))
1889 (computed-file "udev-rules" build))
1891 (define (udev-rule file-name contents)
1892 "Return a directory with a udev rule file FILE-NAME containing CONTENTS."
1893 (computed-file file-name
1894 (with-imported-modules '((guix build utils))
1896 (use-modules (guix build utils))
1899 (string-append #$output "/lib/udev/rules.d"))
1902 (call-with-output-file
1903 (string-append rules.d "/" #$file-name)
1905 (display #$contents port)))))))
1907 (define (file->udev-rule file-name file)
1908 "Return a directory with a udev rule file FILE-NAME which is a copy of FILE."
1909 (computed-file file-name
1910 (with-imported-modules '((guix build utils))
1912 (use-modules (guix build utils))
1915 (string-append #$output "/lib/udev/rules.d"))
1917 (define file-copy-dest
1918 (string-append rules.d "/" #$file-name))
1921 (copy-file #$file file-copy-dest)))))
1923 (define kvm-udev-rule
1924 ;; Return a directory with a udev rule that changes the group of /dev/kvm to
1925 ;; "kvm" and makes it #o660. Apparently QEMU-KVM used to ship this rule,
1926 ;; but now we have to add it by ourselves.
1928 ;; Build users are part of the "kvm" group, so we can fearlessly make
1929 ;; /dev/kvm 660 (see <http://bugs.gnu.org/18994>, for background.)
1930 (udev-rule "90-kvm.rules"
1931 "KERNEL==\"kvm\", GROUP=\"kvm\", MODE=\"0660\"\n"))
1933 (define udev-shepherd-service
1934 ;; Return a <shepherd-service> for UDEV with RULES.
1936 (($ <udev-configuration> udev rules)
1937 (let* ((rules (udev-rules-union (cons* udev kvm-udev-rule rules)))
1938 (udev.conf (computed-file "udev.conf"
1939 #~(call-with-output-file #$output
1942 "udev_rules=\"~a/lib/udev/rules.d\"\n"
1948 ;; Udev needs /dev to be a 'devtmpfs' mount so that new device nodes can
1950 ;; <http://www.linuxfromscratch.org/lfs/view/development/chapter07/udev.html>.
1951 (requirement '(root-file-system))
1953 (documentation "Populate the /dev directory, dynamically.")
1955 (with-imported-modules (source-module-closure
1956 '((gnu build linux-boot)))
1959 ;; 'udevd' from eudev.
1960 #$(file-append udev "/sbin/udevd"))
1962 (define (wait-for-udevd)
1963 ;; Wait until someone's listening on udevd's control
1965 (let ((sock (socket AF_UNIX SOCK_SEQPACKET 0)))
1967 (catch 'system-error
1969 (connect sock PF_UNIX "/run/udev/control")
1972 (format #t "waiting for udevd...~%")
1976 ;; Allow udev to find the modules.
1977 (setenv "LINUX_MODULE_DIRECTORY"
1978 "/run/booted-system/kernel/lib/modules")
1980 (let* ((kernel-release
1981 (utsname:release (uname)))
1982 (linux-module-directory
1983 (getenv "LINUX_MODULE_DIRECTORY"))
1985 (string-append linux-module-directory "/"
1987 (old-umask (umask #o022)))
1988 ;; If we're in a container, DIRECTORY might not exist,
1989 ;; for instance because the host runs a different
1990 ;; kernel. In that case, skip it; we'll just miss a few
1991 ;; nodes like /dev/fuse.
1992 (when (file-exists? directory)
1993 (make-static-device-nodes directory))
1996 (let ((pid (fork+exec-command (list udevd)
1997 #:environment-variables
1999 ;; The first one is for udev, the second one for
2001 (string-append "UDEV_CONFIG_FILE=" #$udev.conf)
2002 (string-append "EUDEV_RULES_DIRECTORY="
2004 rules "/lib/udev/rules.d"))
2005 (string-append "LINUX_MODULE_DIRECTORY="
2006 (getenv "LINUX_MODULE_DIRECTORY"))
2007 (default-environment-variables)))))
2008 ;; Wait until udevd is up and running. This appears to
2009 ;; be needed so that the events triggered below are
2010 ;; actually handled.
2013 ;; Trigger device node creation.
2014 (system* #$(file-append udev "/bin/udevadm")
2015 "trigger" "--action=add")
2017 ;; Wait for things to settle down.
2018 (system* #$(file-append udev "/bin/udevadm")
2021 (stop #~(make-kill-destructor))
2023 ;; When halting the system, 'udev' is actually killed by
2024 ;; 'user-processes', i.e., before its own 'stop' method was called.
2025 ;; Thus, make sure it is not respawned.
2027 ;; We need additional modules.
2028 (modules `((gnu build linux-boot) ;'make-static-device-nodes'
2029 ,@%default-modules))
2031 (actions (list (shepherd-action
2033 (documentation "Display the directory containing
2034 the udev rules in use.")
2035 (procedure #~(lambda (_)
2037 (newline))))))))))))
2039 (define udev-service-type
2040 (service-type (name 'udev)
2042 (list (service-extension shepherd-root-service-type
2043 udev-shepherd-service)))
2045 (compose concatenate) ;concatenate the list of rules
2046 (extend (lambda (config rules)
2048 (($ <udev-configuration> udev initial-rules)
2051 (rules (append initial-rules rules)))))))
2052 (default-value (udev-configuration))
2054 "Run @command{udev}, which populates the @file{/dev}
2055 directory dynamically. Get extra rules from the packages listed in the
2056 @code{rules} field of its value, @code{udev-configuration} object.")))
2058 (define* (udev-service #:key (udev eudev) (rules '()))
2059 "Run @var{udev}, which populates the @file{/dev} directory dynamically. Get
2060 extra rules from the packages listed in @var{rules}."
2061 (service udev-service-type
2062 (udev-configuration (udev udev) (rules rules))))
2064 (define* (udev-rules-service name rules #:key (groups '()))
2065 "Return a service that extends udev-service-type with RULES and
2066 account-service-type with GROUPS as system groups. This works by creating a
2067 singleton service type NAME-udev-rules, of which the returned service is an
2069 (let* ((name (symbol-append name '-udev-rules))
2071 (const (map (lambda (group)
2072 (user-group (name group) (system? #t)))
2074 (udev-extension (const (list rules)))
2079 account-service-type account-extension)
2081 udev-service-type udev-extension))))))
2084 (define swap-service-type
2085 (shepherd-service-type
2089 (if (string-prefix? "/dev/mapper/" device)
2090 (list (symbol-append 'device-mapping-
2091 (string->symbol (basename device))))
2095 (provision (list (symbol-append 'swap- (string->symbol device))))
2096 (requirement `(udev ,@requirement))
2097 (documentation "Enable the given swap device.")
2099 (restart-on-EINTR (swapon #$device))
2102 (restart-on-EINTR (swapoff #$device))
2106 (define (swap-service device)
2107 "Return a service that uses @var{device} as a swap device."
2108 (service swap-service-type device))
2110 (define %default-gpm-options
2111 ;; Default options for GPM.
2112 '("-m" "/dev/input/mice" "-t" "ps2"))
2114 (define-record-type* <gpm-configuration>
2115 gpm-configuration make-gpm-configuration gpm-configuration?
2116 (gpm gpm-configuration-gpm ;package
2118 (options gpm-configuration-options ;list of strings
2119 (default %default-gpm-options)))
2121 (define gpm-shepherd-service
2123 (($ <gpm-configuration> gpm options)
2124 (list (shepherd-service
2125 (requirement '(udev))
2128 ;; 'gpm' runs in the background and sets a PID file.
2129 ;; Note that it requires running as "root".
2130 (false-if-exception (delete-file "/var/run/gpm.pid"))
2131 (fork+exec-command (list #$(file-append gpm "/sbin/gpm")
2134 ;; Wait for the PID file to appear; declare failure if
2135 ;; it doesn't show up.
2137 (or (file-exists? "/var/run/gpm.pid")
2145 ;; Return #f if successfully stopped.
2146 (not (zero? (system* #$(file-append gpm "/sbin/gpm")
2149 (define gpm-service-type
2150 (service-type (name 'gpm)
2152 (list (service-extension shepherd-root-service-type
2153 gpm-shepherd-service)))
2154 (default-value (gpm-configuration))
2156 "Run GPM, the general-purpose mouse daemon, with the given
2157 command-line options. GPM allows users to use the mouse in the console,
2158 notably to select, copy, and paste text. The default options use the
2159 @code{ps2} protocol, which works for both USB and PS/2 mice.")))
2161 (define-deprecated (gpm-service #:key (gpm gpm)
2162 (options %default-gpm-options))
2164 "Run @var{gpm}, the general-purpose mouse daemon, with the given
2165 command-line @var{options}. GPM allows users to use the mouse in the console,
2166 notably to select, copy, and paste text. The default value of @var{options}
2167 uses the @code{ps2} protocol, which works for both USB and PS/2 mice.
2169 This service is not part of @var{%base-services}."
2170 ;; To test in QEMU, use "-usbdevice mouse" and then, in the monitor, use
2171 ;; "info mice" and "mouse_set X" to use the right mouse.
2172 (service gpm-service-type
2173 (gpm-configuration (gpm gpm) (options options))))
2175 (define-record-type* <kmscon-configuration>
2176 kmscon-configuration make-kmscon-configuration
2177 kmscon-configuration?
2178 (kmscon kmscon-configuration-kmscon
2180 (virtual-terminal kmscon-configuration-virtual-terminal)
2181 (login-program kmscon-configuration-login-program
2182 (default (file-append shadow "/bin/login")))
2183 (login-arguments kmscon-configuration-login-arguments
2185 (auto-login kmscon-configuration-auto-login
2187 (hardware-acceleration? kmscon-configuration-hardware-acceleration?
2188 (default #f))) ; #t causes failure
2190 (define kmscon-service-type
2191 (shepherd-service-type
2194 (let ((kmscon (kmscon-configuration-kmscon config))
2195 (virtual-terminal (kmscon-configuration-virtual-terminal config))
2196 (login-program (kmscon-configuration-login-program config))
2197 (login-arguments (kmscon-configuration-login-arguments config))
2198 (auto-login (kmscon-configuration-auto-login config))
2199 (hardware-acceleration? (kmscon-configuration-hardware-acceleration? config)))
2201 (define kmscon-command
2203 #$(file-append kmscon "/bin/kmscon") "--login"
2204 "--vt" #$virtual-terminal
2205 "--no-switchvt" ;Prevent a switch to the virtual terminal.
2206 #$@(if hardware-acceleration? '("--hwaccel") '())
2208 #$login-program #$@login-arguments
2214 (documentation "kmscon virtual terminal")
2215 (requirement '(user-processes udev dbus-system))
2216 (provision (list (symbol-append 'term- (string->symbol virtual-terminal))))
2217 (start #~(make-forkexec-constructor #$kmscon-command))
2218 (stop #~(make-kill-destructor)))))))
2220 (define-record-type* <static-networking>
2221 static-networking make-static-networking
2223 (interface static-networking-interface)
2224 (ip static-networking-ip)
2225 (netmask static-networking-netmask
2227 (gateway static-networking-gateway ;FIXME: doesn't belong here
2229 (provision static-networking-provision
2231 (requirement static-networking-requirement
2233 (name-servers static-networking-name-servers ;FIXME: doesn't belong here
2236 (define static-networking-shepherd-service
2238 (($ <static-networking> interface ip netmask gateway provision
2239 requirement name-servers)
2240 (let ((loopback? (and provision (memq 'loopback provision))))
2244 "Bring up the networking interface using a static IP address.")
2245 (requirement requirement)
2246 (provision (or provision
2247 (list (symbol-append 'networking-
2248 (string->symbol interface)))))
2251 ;; Return #t if successfully started.
2252 (let* ((addr (inet-pton AF_INET #$ip))
2253 (sockaddr (make-socket-address AF_INET addr 0))
2254 (mask (and #$netmask
2255 (inet-pton AF_INET #$netmask)))
2257 (make-socket-address AF_INET
2259 (gateway (and #$gateway
2260 (inet-pton AF_INET #$gateway)))
2261 (gatewayaddr (and gateway
2262 (make-socket-address AF_INET
2264 (configure-network-interface #$interface sockaddr
2271 (let ((sock (socket AF_INET SOCK_DGRAM 0)))
2272 (add-network-route/gateway sock gatewayaddr)
2273 (close-port sock))))))
2275 ;; Return #f is successfully stopped.
2276 (let ((sock (socket AF_INET SOCK_STREAM 0)))
2278 (delete-network-route sock
2279 (make-socket-address
2280 AF_INET INADDR_ANY 0)))
2281 (set-network-interface-flags sock #$interface 0)
2286 (define (static-networking-etc-files interfaces)
2287 "Return a /etc/resolv.conf entry for INTERFACES or the empty list."
2288 (match (delete-duplicates
2289 (append-map static-networking-name-servers
2294 (let ((content (string-join
2295 (map (cut string-append "nameserver " <>)
2299 ,(plain-file "resolv.conf"
2301 # Generated by 'static-networking-service'.\n"
2304 (define (static-networking-shepherd-services interfaces)
2305 "Return the list of Shepherd services to bring up INTERFACES, a list of
2306 <static-networking> objects."
2307 (define (loopback? service)
2308 (memq 'loopback (shepherd-service-provision service)))
2310 (let ((services (map static-networking-shepherd-service interfaces)))
2311 (match (remove loopback? services)
2313 ;; There's no interface other than 'loopback', so we assume that the
2314 ;; 'networking' service will be provided by dhclient or similar.
2317 ;; Assume we're providing all the interfaces, and thus, provide a
2318 ;; 'networking' service.
2319 (cons (shepherd-service
2320 (provision '(networking))
2321 (requirement (append-map shepherd-service-provision
2323 (start #~(const #t))
2325 (documentation "Bring up all the networking interfaces."))
2328 (define static-networking-service-type
2329 ;; The service type for statically-defined network interfaces.
2330 (service-type (name 'static-networking)
2333 (service-extension shepherd-root-service-type
2334 static-networking-shepherd-services)
2335 (service-extension etc-service-type
2336 static-networking-etc-files)))
2337 (compose concatenate)
2340 "Turn up the specified network interfaces upon startup,
2341 with the given IP address, gateway, netmask, and so on. The value for
2342 services of this type is a list of @code{static-networking} objects, one per
2343 network interface.")))
2345 (define* (static-networking-service interface ip
2347 netmask gateway provision
2348 ;; Most interfaces require udev to be usable.
2349 (requirement '(udev))
2351 "Return a service that starts @var{interface} with address @var{ip}. If
2352 @var{netmask} is true, use it as the network mask. If @var{gateway} is true,
2353 it must be a string specifying the default network gateway.
2355 This procedure can be called several times, one for each network
2356 interface of interest. Behind the scenes what it does is extend
2357 @code{static-networking-service-type} with additional network interfaces
2359 (simple-service 'static-network-interface
2360 static-networking-service-type
2361 (list (static-networking (interface interface) (ip ip)
2362 (netmask netmask) (gateway gateway)
2363 (provision provision)
2364 (requirement requirement)
2365 (name-servers name-servers)))))
2368 (define %base-services
2369 ;; Convenience variable holding the basic services.
2370 (list (service login-service-type)
2372 (service virtual-terminal-service-type)
2373 (service console-font-service-type
2375 (cons tty %default-console-font))
2376 '("tty1" "tty2" "tty3" "tty4" "tty5" "tty6")))
2378 (service agetty-service-type (agetty-configuration
2379 (extra-options '("-L")) ; no carrier detect
2381 (tty #f))) ; automatic
2383 (service mingetty-service-type (mingetty-configuration
2385 (service mingetty-service-type (mingetty-configuration
2387 (service mingetty-service-type (mingetty-configuration
2389 (service mingetty-service-type (mingetty-configuration
2391 (service mingetty-service-type (mingetty-configuration
2393 (service mingetty-service-type (mingetty-configuration
2396 (service static-networking-service-type
2397 (list (static-networking (interface "lo")
2400 (provision '(loopback)))))
2402 (service urandom-seed-service-type)
2403 (service guix-service-type)
2404 (service nscd-service-type)
2406 (service rottlog-service-type)
2408 ;; The LVM2 rules are needed as soon as LVM2 or the device-mapper is
2409 ;; used, so enable them by default. The FUSE and ALSA rules are
2410 ;; less critical, but handy.
2411 (service udev-service-type
2413 (rules (list lvm2 fuse alsa-utils crda))))
2415 (service special-files-service-type
2416 `(("/bin/sh" ,(file-append bash "/bin/sh"))
2417 ("/usr/bin/env" ,(file-append coreutils "/bin/env"))))))
2419 ;;; base.scm ends here