1 ;;; GNU Guix --- Functional package management for GNU
2 ;;; Copyright © 2013-2022 Ludovic Courtès <ludo@gnu.org>
3 ;;; Copyright © 2015, 2016 Alex Kost <alezost@gmail.com>
4 ;;; Copyright © 2015, 2016, 2020 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, 2021 Brice Waegeneire <brice@waegenei.re>
16 ;;; Copyright © 2021 qblade <qblade@protonmail.com>
17 ;;; Copyright © 2021 Hui Lu <luhuins@163.com>
18 ;;; Copyright © 2021, 2022 Maxim Cournoyer <maxim.cournoyer@gmail.com>
19 ;;; Copyright © 2022 Guillaume Le Vaillant <glv@posteo.net>
21 ;;; This file is part of GNU Guix.
23 ;;; GNU Guix is free software; you can redistribute it and/or modify it
24 ;;; under the terms of the GNU General Public License as published by
25 ;;; the Free Software Foundation; either version 3 of the License, or (at
26 ;;; your option) any later version.
28 ;;; GNU Guix is distributed in the hope that it will be useful, but
29 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
30 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
31 ;;; GNU General Public License for more details.
33 ;;; You should have received a copy of the GNU General Public License
34 ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
36 (define-module (gnu services base)
37 #:use-module (guix store)
38 #:use-module (guix deprecation)
39 #:autoload (guix diagnostics) (warning &fix-hint)
40 #:autoload (guix i18n) (G_)
41 #:use-module (guix combinators)
42 #:use-module (gnu services)
43 #:use-module (gnu services admin)
44 #:use-module (gnu services shepherd)
45 #:use-module (gnu services sysctl)
46 #:use-module (gnu system pam)
47 #:use-module (gnu system shadow) ; 'user-account', etc.
48 #:use-module (gnu system uuid)
49 #:use-module (gnu system file-systems) ; 'file-system', etc.
50 #:use-module (gnu system keyboard)
51 #:use-module (gnu system mapped-devices)
52 #:use-module ((gnu system linux-initrd)
53 #:select (file-system-packages))
54 #:use-module (gnu packages admin)
55 #:use-module ((gnu packages linux)
56 #:select (alsa-utils crda eudev e2fsprogs fuse gpm kbd lvm2 rng-tools))
57 #:use-module (gnu packages bash)
58 #:use-module ((gnu packages base)
59 #:select (coreutils glibc glibc-utf8-locales tar))
60 #:use-module ((gnu packages compression) #:select (gzip))
61 #:autoload (gnu packages guile-xyz) (guile-netlink)
62 #:autoload (gnu packages hurd) (hurd)
63 #:use-module (gnu packages package-management)
64 #:use-module ((gnu packages gnupg) #:select (guile-gcrypt))
65 #:use-module (gnu packages linux)
66 #:use-module (gnu packages terminals)
67 #:use-module ((gnu build file-systems)
68 #:select (mount-flags->bit-mask
69 swap-space->flags-bit-mask))
70 #:use-module (guix gexp)
71 #:use-module (guix records)
72 #:use-module (guix modules)
73 #:use-module ((guix self) #:select (make-config.scm))
74 #:use-module (guix diagnostics)
75 #:use-module (guix i18n)
76 #:use-module (srfi srfi-1)
77 #:use-module (srfi srfi-26)
78 #:use-module (srfi srfi-34)
79 #:use-module (srfi srfi-35)
80 #:use-module (ice-9 match)
81 #:use-module (ice-9 format)
82 #:re-export (user-processes-service-type ;backwards compatibility
83 %default-substitute-urls)
84 #:export (fstab-service-type
85 root-file-system-service
86 file-system-service-type
90 console-font-service-type
92 virtual-terminal-service-type
96 static-networking-addresses
97 static-networking-links
98 static-networking-routes
99 static-networking-requirement
103 network-address-device
104 network-address-value
105 network-address-ipv6?
111 network-link-arguments
115 network-route-destination
119 network-route-gateway
121 static-networking-service
122 static-networking-service-type
124 %loopback-static-networking
125 %qemu-static-networking
129 udev-configuration-rules
142 agetty-configuration?
146 mingetty-configuration
147 mingetty-configuration-tty
148 mingetty-configuration-auto-login
149 mingetty-configuration-login-program
150 mingetty-configuration-login-pause?
151 mingetty-configuration-clear-on-logout?
152 mingetty-configuration-mingetty
153 mingetty-configuration?
155 mingetty-service-type
158 %nscd-default-configuration
170 syslog-configuration?
175 %default-authorized-guix-keys
179 guix-configuration-guix
180 guix-configuration-build-group
181 guix-configuration-build-accounts
182 guix-configuration-authorize-key?
183 guix-configuration-authorized-keys
184 guix-configuration-use-substitutes?
185 guix-configuration-substitute-urls
186 guix-configuration-extra-options
187 guix-configuration-log-file
190 guix-publish-configuration
191 guix-publish-configuration?
192 guix-publish-configuration-guix
193 guix-publish-configuration-port
194 guix-publish-configuration-host
195 guix-publish-configuration-compression
196 guix-publish-configuration-compression-level ;deprecated
197 guix-publish-configuration-nar-path
198 guix-publish-configuration-cache
199 guix-publish-configuration-ttl
200 guix-publish-configuration-negative-ttl
201 guix-publish-service-type
207 urandom-seed-service-type
215 kmscon-configuration?
218 pam-limits-service-type
227 ;;; Base system services---i.e., services that 99% of the users will want to
238 (define (file-system->fstab-entry file-system)
239 "Return a @file{/etc/fstab} entry for @var{file-system}."
240 (string-append (match (file-system-device file-system)
241 ((? file-system-label? label)
242 (string-append "LABEL="
243 (file-system-label->string label)))
245 (string-append "UUID=" (uuid->string uuid)))
249 (file-system-mount-point file-system) "\t"
250 (file-system-type file-system) "\t"
251 (or (file-system-options file-system) "defaults") "\t"
253 ;; XXX: Omit the 'fs_freq' and 'fs_passno' fields because we
254 ;; don't have anything sensible to put in there.
257 (define (file-systems->fstab file-systems)
258 "Return a @file{/etc} entry for an @file{fstab} describing
260 `(("fstab" ,(plain-file "fstab"
263 # This file was generated from your Guix configuration. Any changes
264 # will be lost upon reboot or reconfiguration.\n\n"
265 (string-join (map file-system->fstab-entry
270 (define fstab-service-type
271 ;; The /etc/fstab service.
272 (service-type (name 'fstab)
274 (list (service-extension etc-service-type
275 file-systems->fstab)))
276 (compose concatenate)
279 "Populate the @file{/etc/fstab} based on the given file
282 (define %root-file-system-shepherd-service
284 (documentation "Take care of the root file system.")
285 (provision '(root-file-system))
288 ;; Return #f if successfully stopped.
291 (call-with-blocked-asyncs
293 (let ((null (%make-void-port "w")))
294 ;; Close 'shepherd.log'.
295 (display "closing log\n")
296 ((@ (shepherd comm) stop-logging))
298 ;; Redirect the default output ports..
299 (set-current-output-port null)
300 (set-current-error-port null)
302 ;; Close /dev/console.
303 (for-each close-fdes '(0 1 2))
305 ;; At this point, there are no open files left, so the
306 ;; root file system can be re-mounted read-only.
308 (logior MS_REMOUNT MS_RDONLY)
314 (define root-file-system-service-type
315 (shepherd-service-type 'root-file-system
316 (const %root-file-system-shepherd-service)
317 (description "Take care of syncing the root file
318 system and of remounting it read-only when the system shuts down.")))
320 (define (root-file-system-service)
321 "Return a service whose sole purpose is to re-mount read-only the root file
322 system upon shutdown (aka. cleanly \"umounting\" root.)
324 This service must be the root of the service dependency graph so that its
325 'stop' action is invoked when shepherd is the only process left."
326 (service root-file-system-service-type #f))
328 (define (file-system->shepherd-service-name file-system)
329 "Return the symbol that denotes the service mounting and unmounting
331 (symbol-append 'file-system-
332 (string->symbol (file-system-mount-point file-system))))
334 (define (mapped-device->shepherd-service-name md)
335 "Return the symbol that denotes the shepherd service of MD, a <mapped-device>."
336 (symbol-append 'device-mapping-
337 (string->symbol (string-join
338 (mapped-device-targets md) "-"))))
340 (define dependency->shepherd-service-name
342 ((? mapped-device? md)
343 (mapped-device->shepherd-service-name md))
345 (file-system->shepherd-service-name fs))))
347 (define (file-system-shepherd-service file-system)
348 "Return the shepherd service for @var{file-system}, or @code{#f} if
349 @var{file-system} is not auto-mounted or doesn't have its mount point created
351 (let ((target (file-system-mount-point file-system))
352 (create? (file-system-create-mount-point? file-system))
353 (mount? (file-system-mount? file-system))
354 (dependencies (file-system-dependencies file-system))
355 (packages (file-system-packages (list file-system))))
356 (and (or mount? create?)
357 (with-imported-modules (source-module-closure
358 '((gnu build file-systems)))
360 (provision (list (file-system->shepherd-service-name file-system)))
361 (requirement `(root-file-system
363 ,@(map dependency->shepherd-service-name dependencies)))
364 (documentation "Check, mount, and unmount the given file system.")
365 (start #~(lambda args
371 #~(let (($PATH (getenv "PATH")))
372 ;; Make sure fsck.ext2 & co. can be found.
375 ;; Don’t display the PATH settings.
376 (with-output-to-port (%make-void-port "w")
378 (set-path-environment-variable "PATH"
384 '#$(file-system->spec file-system))
387 (setenv "PATH" $PATH))))
391 ;; Normally there are no processes left at this point, so
392 ;; TARGET can be safely unmounted.
394 ;; Make sure PID 1 doesn't keep TARGET busy.
400 ;; We need additional modules.
401 (modules `(((gnu build file-systems)
402 #:select (mount-file-system))
403 (gnu system file-systems)
404 ,@%default-modules)))))))
406 (define (file-system-shepherd-services file-systems)
407 "Return the list of Shepherd services for FILE-SYSTEMS."
408 (let* ((file-systems (filter (lambda (x)
409 (or (file-system-mount? x)
410 (file-system-create-mount-point? x)))
414 (provision '(file-systems))
415 (requirement (cons* 'root-file-system 'user-file-systems
416 (map file-system->shepherd-service-name
418 (documentation "Target for all the initially-mounted file systems")
420 (stop #~(const #f))))
422 (define known-mount-points
423 (map file-system-mount-point file-systems))
427 (documentation "Unmount manually-mounted file systems.")
428 (provision '(user-file-systems))
431 (define (known? mount-point)
433 (cons* "/proc" "/sys" '#$known-mount-points)))
435 ;; Make sure we don't keep the user's mount points busy.
438 (for-each (lambda (mount-point)
439 (format #t "unmounting '~a'...~%" mount-point)
442 (umount mount-point))
444 (let ((errno (system-error-errno args)))
445 (format #t "failed to unmount '~a': ~a~%"
446 mount-point (strerror errno))))))
447 (filter (negate known?) (mount-points)))
450 (cons* sink user-unmount
451 (map file-system-shepherd-service file-systems))))
453 (define (file-system-fstab-entries file-systems)
454 "Return the subset of @var{file-systems} that should have an entry in
456 ;; /etc/fstab is about telling fsck(8), mount(8), and umount(8) about
457 ;; relevant file systems they'll have to deal with. That excludes "pseudo"
460 ;; In particular, things like GIO (part of GLib) use it to determine the set
461 ;; of mounts, which is then used by graphical file managers and desktop
462 ;; environments to display "volume" icons. Thus, we really need to exclude
463 ;; those pseudo file systems from the list.
464 (remove (lambda (file-system)
465 (or (member (file-system-type file-system)
466 %pseudo-file-system-types)
467 (memq 'bind-mount (file-system-flags file-system))))
470 (define file-system-service-type
471 (service-type (name 'file-systems)
473 (list (service-extension shepherd-root-service-type
474 file-system-shepherd-services)
475 (service-extension fstab-service-type
476 file-system-fstab-entries)
478 ;; Have 'user-processes' depend on 'file-systems'.
479 (service-extension user-processes-service-type
480 (const '(file-systems)))))
481 (compose concatenate)
484 "Provide Shepherd services to mount and unmount the given
485 file systems, as well as corresponding @file{/etc/fstab} entries.")))
490 ;;; Preserve entropy to seed /dev/urandom on boot.
493 (define %random-seed-file
494 "/var/lib/random-seed")
496 (define (urandom-seed-shepherd-service _)
497 "Return a shepherd service for the /dev/urandom seed."
498 (list (shepherd-service
499 (documentation "Preserve entropy across reboots for /dev/urandom.")
500 (provision '(urandom-seed))
502 ;; Depend on udev so that /dev/hwrng is available.
503 (requirement '(file-systems udev))
506 ;; On boot, write random seed into /dev/urandom.
507 (when (file-exists? #$%random-seed-file)
508 (call-with-input-file #$%random-seed-file
510 (call-with-output-file "/dev/urandom"
512 (dump-port seed urandom)
514 ;; Writing SEED to URANDOM isn't enough: we must
515 ;; also tell the kernel to account for these
516 ;; extra bits of entropy.
517 (let ((bits (* 8 (stat:size (stat seed)))))
518 (add-to-entropy-count urandom bits)))))))
520 ;; Try writing from /dev/hwrng into /dev/urandom.
521 ;; It seems that the file /dev/hwrng always exists, even
522 ;; when there is no hardware random number generator
523 ;; available. So, we handle a failed read or any other error
524 ;; reported by the operating system.
525 (let ((buf (catch 'system-error
527 (call-with-input-file "/dev/hwrng"
529 (get-bytevector-n hwrng 512))))
530 ;; Silence is golden...
533 (call-with-output-file "/dev/urandom"
535 (put-bytevector urandom buf)
536 (let ((bits (* 8 (bytevector-length buf))))
537 (add-to-entropy-count urandom bits))))))
539 ;; Immediately refresh the seed in case the system doesn't
540 ;; shut down cleanly.
541 (call-with-input-file "/dev/urandom"
543 (let ((previous-umask (umask #o077))
544 (buf (make-bytevector 512)))
545 (mkdir-p (dirname #$%random-seed-file))
546 (get-bytevector-n! urandom buf 0 512)
547 (call-with-output-file #$%random-seed-file
549 (put-bytevector seed buf)))
550 (umask previous-umask))))
553 ;; During shutdown, write from /dev/urandom into random seed.
554 (let ((buf (make-bytevector 512)))
555 (call-with-input-file "/dev/urandom"
557 (let ((previous-umask (umask #o077)))
558 (get-bytevector-n! urandom buf 0 512)
559 (mkdir-p (dirname #$%random-seed-file))
560 (call-with-output-file #$%random-seed-file
562 (put-bytevector seed buf)))
563 (umask previous-umask))
565 (modules `((rnrs bytevectors)
567 ,@%default-modules)))))
569 (define urandom-seed-service-type
570 (service-type (name 'urandom-seed)
572 (list (service-extension shepherd-root-service-type
573 urandom-seed-shepherd-service)
575 ;; Have 'user-processes' depend on 'urandom-seed'.
576 ;; This ensures that user processes and daemons don't
577 ;; start until we have seeded the PRNG.
578 (service-extension user-processes-service-type
579 (const '(urandom-seed)))))
582 "Seed the @file{/dev/urandom} pseudo-random number
583 generator (RNG) with the value recorded when the system was last shut
588 ;;; Add hardware random number generator to entropy pool.
591 (define-record-type* <rngd-configuration>
592 rngd-configuration make-rngd-configuration
594 (rng-tools rngd-configuration-rng-tools) ;file-like
595 (device rngd-configuration-device)) ;string
597 (define rngd-service-type
598 (shepherd-service-type
601 (define rng-tools (rngd-configuration-rng-tools config))
602 (define device (rngd-configuration-device config))
605 (list (file-append rng-tools "/sbin/rngd")
609 (documentation "Add TRNG to entropy pool.")
610 (requirement '(udev))
612 (start #~(make-forkexec-constructor '#$rngd-command))
613 (stop #~(make-kill-destructor))))
614 (description "Run the @command{rngd} random number generation daemon to
615 supply entropy to the kernel's pool.")))
617 (define* (rngd-service #:key
618 (rng-tools rng-tools)
619 (device "/dev/hwrng"))
620 "Return a service that runs the @command{rngd} program from @var{rng-tools}
621 to add @var{device} to the kernel's entropy pool. The service will fail if
622 @var{device} does not exist."
623 (service rngd-service-type
625 (rng-tools rng-tools)
633 (define host-name-service-type
634 (shepherd-service-type
638 (documentation "Initialize the machine's host name.")
639 (provision '(host-name))
641 (sethostname #$name)))
643 (description "Initialize the machine's host name.")))
645 (define (host-name-service name)
646 "Return a service that sets the host name to @var{name}."
647 (service host-name-service-type name))
649 (define virtual-terminal-service-type
650 ;; Ensure that virtual terminals run in UTF-8 mode. This is the case by
651 ;; default with recent Linux kernels, but this service allows us to ensure
652 ;; this. This service must start before any 'term-' service so that newly
653 ;; created terminals inherit this property. See
654 ;; <https://bugs.gnu.org/30505> for a discussion.
655 (shepherd-service-type
658 (let ((knob "/sys/module/vt/parameters/default_utf8"))
660 (documentation "Set virtual terminals in UTF-8 module.")
661 (provision '(virtual-terminal))
662 (requirement '(root-file-system))
664 ;; In containers /sys is read-only so don't insist on
665 ;; writing to this file.
666 (unless (= 1 (call-with-input-file #$knob read))
667 (call-with-output-file #$knob
671 (stop #~(const #f)))))
673 (description "Ensure the Linux virtual terminals run in UTF-8 mode.")))
675 (define console-keymap-service-type
676 (shepherd-service-type
680 (documentation (string-append "Load console keymap (loadkeys)."))
681 (provision '(console-keymap))
683 (zero? (system* #$(file-append kbd "/bin/loadkeys")
686 (description "@emph{This service is deprecated in favor of the
687 @code{keyboard-layout} field of @code{operating-system}.} Load the given list
688 of console keymaps with @command{loadkeys}.")))
690 (define %default-console-font
691 ;; Note: 'LatGrkCyr-8x16' has the advantage of providing three common
692 ;; scripts as well as glyphs for em dash, quotation marks, and other Unicode
693 ;; codepoints notably found in the UTF-8 manual.
696 (define (console-font-shepherd-services tty+font)
697 "Return a list of Shepherd services for each pair in TTY+FONT."
700 (let ((device (string-append "/dev/" tty)))
702 (documentation "Load a Unicode console font.")
703 (provision (list (symbol-append 'console-font-
704 (string->symbol tty))))
706 ;; Start after mingetty has been started on TTY, otherwise the settings
708 (requirement (list (symbol-append 'term-
709 (string->symbol tty))))
712 ;; It could be that mingetty is not fully ready yet,
713 ;; which we check by calling 'ttyname'.
715 (unless (or (zero? i)
716 (call-with-input-file #$device
718 (false-if-exception (ttyname port)))))
722 ;; Assume the VT is already in UTF-8 mode, thanks to
723 ;; the 'virtual-terminal' service.
725 ;; 'setfont' returns EX_OSERR (71) when an
726 ;; KDFONTOP ioctl fails, for example. Like
727 ;; systemd's vconsole support, let's not treat
729 (case (status:exit-val
730 (system* #$(file-append kbd "/bin/setfont")
731 "-C" #$device #$font))
738 (define console-font-service-type
739 (service-type (name 'console-fonts)
741 (list (service-extension shepherd-root-service-type
742 console-font-shepherd-services)))
743 (compose concatenate)
746 "Install the given fonts on the specified ttys (fonts are per
747 virtual console on GNU/Linux). The value of this service is a list of
748 tty/font pairs. The font can be the name of a font provided by the @code{kbd}
749 package or any valid argument to @command{setfont}, as in this example:
752 `((\"tty1\" . \"LatGrkCyr-8x16\")
753 (\"tty2\" . ,(file-append
755 \"/share/kbd/consolefonts/TamzenForPowerline10x20.psf\"))
756 (\"tty3\" . ,(file-append
758 \"/share/consolefonts/ter-132n\"))) ; for HDPI
761 (define* (console-font-service tty #:optional (font "LatGrkCyr-8x16"))
762 "This procedure is deprecated in favor of @code{console-font-service-type}.
764 Return a service that sets up Unicode support in @var{tty} and loads
765 @var{font} for that tty (fonts are per virtual console in Linux.)"
766 (simple-service (symbol-append 'console-font- (string->symbol tty))
767 console-font-service-type `((,tty . ,font))))
769 (define %default-motd
770 (plain-file "motd" "This is the GNU operating system, welcome!\n\n"))
772 (define-record-type* <login-configuration>
773 login-configuration make-login-configuration
775 (motd login-configuration-motd ;file-like
776 (default %default-motd))
777 ;; Allow empty passwords by default so that first-time users can log in when
778 ;; the 'root' account has just been created.
779 (allow-empty-passwords? login-configuration-allow-empty-passwords?
780 (default #t))) ;Boolean
782 (define (login-pam-service config)
783 "Return the list of PAM service needed for CONF."
784 ;; Let 'login' be known to PAM.
785 (list (unix-pam-service "login"
787 #:allow-empty-passwords?
788 (login-configuration-allow-empty-passwords? config)
790 (login-configuration-motd config))))
792 (define login-service-type
793 (service-type (name 'login)
794 (extensions (list (service-extension pam-root-service-type
796 (default-value (login-configuration))
798 "Provide a console log-in service as specified by its
799 configuration value, a @code{login-configuration} object.")))
801 (define* (login-service #:optional (config (login-configuration)))
802 "Return a service configure login according to @var{config}, which specifies
803 the message of the day, among other things."
804 (service login-service-type config))
806 (define-record-type* <agetty-configuration>
807 agetty-configuration make-agetty-configuration
808 agetty-configuration?
809 (agetty agetty-configuration-agetty ;file-like
810 (default util-linux))
811 (tty agetty-configuration-tty) ;string | #f
812 (term agetty-term ;string | #f
814 (baud-rate agetty-baud-rate ;string | #f
816 (auto-login agetty-auto-login ;list of strings | #f
818 (login-program agetty-login-program ;gexp
819 (default (file-append shadow "/bin/login")))
820 (login-pause? agetty-login-pause? ;Boolean
822 (eight-bits? agetty-eight-bits? ;Boolean
824 (no-reset? agetty-no-reset? ;Boolean
826 (remote? agetty-remote? ;Boolean
828 (flow-control? agetty-flow-control? ;Boolean
830 (host agetty-host ;string | #f
832 (no-issue? agetty-no-issue? ;Boolean
834 (init-string agetty-init-string ;string | #f
836 (no-clear? agetty-no-clear? ;Boolean
838 (local-line agetty-local-line ;always | never | auto
840 (extract-baud? agetty-extract-baud? ;Boolean
842 (skip-login? agetty-skip-login? ;Boolean
844 (no-newline? agetty-no-newline? ;Boolean
846 (login-options agetty-login-options ;string | #f
848 (chroot agetty-chroot ;string | #f
850 (hangup? agetty-hangup? ;Boolean
852 (keep-baud? agetty-keep-baud? ;Boolean
854 (timeout agetty-timeout ;integer | #f
856 (detect-case? agetty-detect-case? ;Boolean
858 (wait-cr? agetty-wait-cr? ;Boolean
860 (no-hints? agetty-no-hints? ;Boolean
862 (no-hostname? agetty-no hostname? ;Boolean
864 (long-hostname? agetty-long-hostname? ;Boolean
866 (erase-characters agetty-erase-characters ;string | #f
868 (kill-characters agetty-kill-characters ;string | #f
870 (chdir agetty-chdir ;string | #f
872 (delay agetty-delay ;integer | #f
874 (nice agetty-nice ;integer | #f
876 ;; "Escape hatch" for passing arbitrary command-line arguments.
877 (extra-options agetty-extra-options ;list of strings
879 ;;; XXX Unimplemented for now!
880 ;;; (issue-file agetty-issue-file ;file-like
884 (define (default-serial-port)
885 "Return a gexp that determines a reasonable default serial port
886 to use as the tty. This is primarily useful for headless systems."
887 (with-imported-modules (source-module-closure
888 '((gnu build linux-boot))) ;for 'find-long-options'
890 ;; console=device,options
891 ;; device: can be tty0, ttyS0, lp0, ttyUSB0 (serial).
892 ;; options: BBBBPNF. P n|o|e, N number of bits,
893 ;; F flow control (r RTS)
894 (let* ((not-comma (char-set-complement (char-set #\,)))
895 (command (linux-command-line))
896 (agetty-specs (find-long-options "agetty.tty" command))
897 (console-specs (filter (lambda (spec)
898 (and (string-prefix? "tty" spec)
900 (string-prefix? "tty0" spec)
901 (string-prefix? "tty1" spec)
902 (string-prefix? "tty2" spec)
903 (string-prefix? "tty3" spec)
904 (string-prefix? "tty4" spec)
905 (string-prefix? "tty5" spec)
906 (string-prefix? "tty6" spec)
907 (string-prefix? "tty7" spec)
908 (string-prefix? "tty8" spec)
909 (string-prefix? "tty9" spec)))))
910 (find-long-options "console" command)))
911 (specs (append agetty-specs console-specs)))
915 ;; Extract device name from first spec.
916 (match (string-tokenize spec not-comma)
920 (define agetty-shepherd-service
922 (($ <agetty-configuration> agetty tty term baud-rate auto-login
923 login-program login-pause? eight-bits? no-reset? remote? flow-control?
924 host no-issue? init-string no-clear? local-line extract-baud?
925 skip-login? no-newline? login-options chroot hangup? keep-baud? timeout
926 detect-case? wait-cr? no-hints? no-hostname? long-hostname?
927 erase-characters kill-characters chdir delay nice extra-options)
930 (documentation "Run agetty on a tty.")
931 (provision (list (symbol-append 'term- (string->symbol (or tty "auto")))))
933 ;; Since the login prompt shows the host name, wait for the 'host-name'
934 ;; service to be done. Also wait for udev essentially so that the tty
935 ;; text is not lost in the middle of kernel messages (see also
936 ;; mingetty-shepherd-service).
937 (requirement '(user-processes host-name udev))
939 (modules '((ice-9 match) (gnu build linux-boot)))
941 (with-imported-modules (source-module-closure
942 '((gnu build linux-boot)))
944 (let ((defaulted-tty #$(or tty (default-serial-port))))
947 (make-forkexec-constructor
948 (list #$(file-append util-linux "/sbin/agetty")
969 #~("--init-string" #$init-string)
974 ;;; FIXME This doesn't work as expected. According to agetty(8), if this option
975 ;;; is not passed, then the default is 'auto'. However, in my tests, when that
976 ;;; option is selected, agetty never presents the login prompt, and the
977 ;;; term-ttyS0 service respawns every few seconds.
979 #~(#$(match local-line
980 ('auto "--local-line=auto")
981 ('always "--local-line=always")
982 ('never "-local-line=never")))
997 #~("--login-options" #$login-options)
1000 #~("--chroot" #$chroot)
1009 #~("--timeout" #$(number->string timeout))
1023 #$@(if long-hostname?
1024 #~("--long-hostname")
1026 #$@(if erase-characters
1027 #~("--erase-chars" #$erase-characters)
1029 #$@(if kill-characters
1030 #~("--kill-chars" #$kill-characters)
1033 #~("--chdir" #$chdir)
1036 #~("--delay" #$(number->string delay))
1039 #~("--nice" #$(number->string nice))
1042 (list "--autologin" auto-login)
1044 #$@(if login-program
1045 #~("--login-program" #$login-program)
1057 (const #f)) ; never start.
1059 (stop #~(make-kill-destructor)))))))
1061 (define agetty-service-type
1062 (service-type (name 'agetty)
1063 (extensions (list (service-extension shepherd-root-service-type
1064 agetty-shepherd-service)))
1066 "Provide console login using the @command{agetty}
1069 (define* (agetty-service config)
1070 "Return a service to run agetty according to @var{config}, which specifies
1071 the tty to run, among other things."
1072 (service agetty-service-type config))
1074 (define-record-type* <mingetty-configuration>
1075 mingetty-configuration make-mingetty-configuration
1076 mingetty-configuration?
1077 (mingetty mingetty-configuration-mingetty ;file-like
1079 (tty mingetty-configuration-tty) ;string
1080 (auto-login mingetty-auto-login ;string | #f
1082 (login-program mingetty-login-program ;gexp
1084 (login-pause? mingetty-login-pause? ;Boolean
1086 (clear-on-logout? mingetty-clear-on-logout? ;Boolean
1089 (define mingetty-shepherd-service
1091 (($ <mingetty-configuration> mingetty tty auto-login login-program
1092 login-pause? clear-on-logout?)
1095 (documentation "Run mingetty on an tty.")
1096 (provision (list (symbol-append 'term- (string->symbol tty))))
1098 ;; Since the login prompt shows the host name, wait for the 'host-name'
1099 ;; service to be done. Also wait for udev essentially so that the tty
1100 ;; text is not lost in the middle of kernel messages (XXX).
1101 (requirement '(user-processes host-name udev virtual-terminal))
1103 (start #~(make-forkexec-constructor
1104 (list #$(file-append mingetty "/sbin/mingetty")
1106 ;; Avoiding 'vhangup' allows us to avoid 'setfont'
1107 ;; errors down the path where various ioctls get
1108 ;; EIO--see 'hung_up_tty_ioctl' in driver/tty/tty_io.c
1112 #$@(if clear-on-logout?
1116 #~("--autologin" #$auto-login)
1118 #$@(if login-program
1119 #~("--loginprog" #$login-program)
1124 (stop #~(make-kill-destructor)))))))
1126 (define mingetty-service-type
1127 (service-type (name 'mingetty)
1128 (extensions (list (service-extension shepherd-root-service-type
1129 mingetty-shepherd-service)))
1131 "Provide console login using the @command{mingetty}
1134 (define* (mingetty-service config)
1135 "Return a service to run mingetty according to @var{config}, which specifies
1136 the tty to run, among other things."
1137 (service mingetty-service-type config))
1139 (define-record-type* <nscd-configuration> nscd-configuration
1140 make-nscd-configuration
1142 (log-file nscd-configuration-log-file ;string
1143 (default "/var/log/nscd.log"))
1144 (debug-level nscd-debug-level ;integer
1146 ;; TODO: See nscd.conf in glibc for other options to add.
1147 (caches nscd-configuration-caches ;list of <nscd-cache>
1148 (default %nscd-default-caches))
1149 (name-services nscd-configuration-name-services ;list of file-like
1151 (glibc nscd-configuration-glibc ;file-like
1154 (define-record-type* <nscd-cache> nscd-cache make-nscd-cache
1156 (database nscd-cache-database) ;symbol
1157 (positive-time-to-live nscd-cache-positive-time-to-live) ;integer
1158 (negative-time-to-live nscd-cache-negative-time-to-live
1159 (default 20)) ;integer
1160 (suggested-size nscd-cache-suggested-size ;integer ("default module
1163 (check-files? nscd-cache-check-files? ;Boolean
1165 (persistent? nscd-cache-persistent? ;Boolean
1167 (shared? nscd-cache-shared? ;Boolean
1169 (max-database-size nscd-cache-max-database-size ;integer
1170 (default (* 32 (expt 2 20))))
1171 (auto-propagate? nscd-cache-auto-propagate? ;Boolean
1174 (define %nscd-default-caches
1175 ;; Caches that we want to enable by default. Note that when providing an
1176 ;; empty nscd.conf, all caches are disabled.
1177 (list (nscd-cache (database 'hosts)
1179 ;; Aggressively cache the host name cache to improve
1180 ;; privacy and resilience.
1181 (positive-time-to-live (* 3600 12))
1182 (negative-time-to-live 20)
1185 (nscd-cache (database 'services)
1187 ;; Services are unlikely to change, so we can be even more
1189 (positive-time-to-live (* 3600 24))
1190 (negative-time-to-live 3600)
1191 (check-files? #t) ;check /etc/services changes
1194 (define %nscd-default-configuration
1195 ;; Default nscd configuration.
1196 (nscd-configuration))
1198 (define (nscd.conf-file config)
1199 "Return the @file{nscd.conf} configuration file for @var{config}, an
1200 @code{<nscd-configuration>} object."
1201 (define cache->config
1203 (($ <nscd-cache> (= symbol->string database)
1204 positive-ttl negative-ttl size check-files?
1205 persistent? shared? max-size propagate?)
1206 (string-append "\nenable-cache\t" database "\tyes\n"
1208 "positive-time-to-live\t" database "\t"
1209 (number->string positive-ttl) "\n"
1210 "negative-time-to-live\t" database "\t"
1211 (number->string negative-ttl) "\n"
1212 "suggested-size\t" database "\t"
1213 (number->string size) "\n"
1214 "check-files\t" database "\t"
1215 (if check-files? "yes\n" "no\n")
1216 "persistent\t" database "\t"
1217 (if persistent? "yes\n" "no\n")
1218 "shared\t" database "\t"
1219 (if shared? "yes\n" "no\n")
1220 "max-db-size\t" database "\t"
1221 (number->string max-size) "\n"
1222 "auto-propagate\t" database "\t"
1223 (if propagate? "yes\n" "no\n")))))
1226 (($ <nscd-configuration> log-file debug-level caches)
1227 (plain-file "nscd.conf"
1229 # Configuration of libc's name service cache daemon (nscd).\n\n"
1231 (string-append "logfile\t" log-file)
1235 (string-append "debug-level\t"
1236 (number->string debug-level))
1240 (map cache->config caches)))))))
1242 (define (nscd-action-procedure nscd config option)
1243 ;; XXX: This is duplicated from mcron; factorize.
1244 #~(lambda (_ . args)
1245 ;; Run 'nscd' in a pipe so we can explicitly redirect its output to
1246 ;; 'current-output-port', which at this stage is bound to the client
1248 (let ((pipe (apply open-pipe* OPEN_READ #$nscd
1249 "-f" #$config #$option args)))
1251 (match (read-line pipe 'concat)
1253 (catch 'system-error
1255 (zero? (close-pipe pipe)))
1257 ;; There's a race with the SIGCHLD handler, which could
1258 ;; call 'waitpid' before 'close-pipe' above does. If we
1259 ;; get ECHILD, that means we lost the race; in that case, we
1260 ;; cannot tell what the exit code was (FIXME).
1261 (or (= ECHILD (system-error-errno args))
1262 (apply throw args)))))
1267 (define (nscd-actions nscd config)
1268 "Return Shepherd actions for NSCD."
1269 ;; Make this functionality available as actions because that's a simple way
1270 ;; to run the right 'nscd' binary with the right config file.
1271 (list (shepherd-action
1273 (documentation "Display statistics about nscd usage.")
1274 (procedure (nscd-action-procedure nscd config "--statistics")))
1278 "Invalidate the given cache--e.g., 'hosts' for host name lookups.")
1279 (procedure (nscd-action-procedure nscd config "--invalidate")))))
1281 (define (nscd-shepherd-service config)
1282 "Return a shepherd service for CONFIG, an <nscd-configuration> object."
1283 (let ((nscd (file-append (nscd-configuration-glibc config)
1285 (nscd.conf (nscd.conf-file config))
1286 (name-services (nscd-configuration-name-services config)))
1287 (list (shepherd-service
1288 (documentation "Run libc's name service cache daemon (nscd).")
1290 (requirement '(user-processes))
1291 (start #~(make-forkexec-constructor
1292 (list #$nscd "-f" #$nscd.conf "--foreground")
1294 ;; Wait for the PID file. However, the PID file is
1295 ;; written before nscd is actually listening on its
1297 #:pid-file "/var/run/nscd/nscd.pid"
1299 #:environment-variables
1300 (list (string-append "LD_LIBRARY_PATH="
1303 (string-append dir "/lib"))
1304 (list #$@name-services))
1306 (stop #~(make-kill-destructor))
1307 (modules `((ice-9 popen) ;for the actions
1310 ,@%default-modules))
1311 (actions (nscd-actions nscd nscd.conf))))))
1313 (define nscd-activation
1314 ;; Actions to take before starting nscd.
1316 (use-modules (guix build utils))
1317 (mkdir-p "/var/run/nscd")
1318 (mkdir-p "/var/db/nscd") ;for the persistent cache
1320 ;; In libc 2.25 nscd uses inotify to watch /etc/resolv.conf, but only if
1321 ;; that file exists when it is started. Thus create it here. Note: on
1322 ;; some systems, such as when NetworkManager is used, /etc/resolv.conf
1323 ;; is a symlink, hence 'lstat'.
1324 (unless (false-if-exception (lstat "/etc/resolv.conf"))
1325 (call-with-output-file "/etc/resolv.conf"
1327 (display "# This is a placeholder.\n" port))))))
1329 (define nscd-service-type
1330 (service-type (name 'nscd)
1332 (list (service-extension activation-service-type
1333 (const nscd-activation))
1334 (service-extension shepherd-root-service-type
1335 nscd-shepherd-service)))
1337 ;; This can be extended by providing additional name services
1338 ;; such as nss-mdns.
1339 (compose concatenate)
1340 (extend (lambda (config name-services)
1343 (name-services (append
1344 (nscd-configuration-name-services config)
1346 (default-value %nscd-default-configuration)
1348 "Runs libc's @dfn{name service cache daemon} (nscd) with the
1349 given configuration---an @code{<nscd-configuration>} object. @xref{Name
1350 Service Switch}, for an example.")))
1352 (define* (nscd-service #:optional (config %nscd-default-configuration))
1353 "Return a service that runs libc's name service cache daemon (nscd) with the
1354 given @var{config}---an @code{<nscd-configuration>} object. @xref{Name
1355 Service Switch}, for an example."
1356 (service nscd-service-type config))
1359 (define-record-type* <syslog-configuration>
1360 syslog-configuration make-syslog-configuration
1361 syslog-configuration?
1362 (syslogd syslog-configuration-syslogd
1363 (default (file-append inetutils "/libexec/syslogd")))
1364 (config-file syslog-configuration-config-file
1365 (default %default-syslog.conf)))
1367 (define syslog-service-type
1368 (shepherd-service-type
1372 (documentation "Run the syslog daemon (syslogd).")
1373 (provision '(syslogd))
1374 (requirement '(user-processes))
1375 (start #~(let ((spawn (make-forkexec-constructor
1376 (list #$(syslog-configuration-syslogd config)
1378 #$(syslog-configuration-config-file config))
1379 #:pid-file "/var/run/syslog.pid")))
1381 ;; Set the umask such that file permissions are #o640.
1382 (let ((mask (umask #o137))
1386 (stop #~(make-kill-destructor))))
1387 (description "Run the syslog daemon, @command{syslogd}, which is
1388 responsible for logging system messages.")))
1390 ;; Snippet adapted from the GNU inetutils manual.
1391 (define %default-syslog.conf
1392 (plain-file "syslog.conf" "
1393 # Log all error messages, authentication messages of
1394 # level notice or higher and anything of level err or
1395 # higher to the console.
1396 # Don't log private authentication messages!
1397 *.alert;auth.notice;authpriv.none /dev/console
1399 # Log anything (except mail) of level info or higher.
1400 # Don't log private authentication messages!
1401 *.info;mail.none;authpriv.none /var/log/messages
1403 # Like /var/log/messages, but also including \"debug\"-level logs.
1404 *.debug;mail.none;authpriv.none /var/log/debug
1406 # Same, in a different place.
1407 *.info;mail.none;authpriv.none /dev/tty12
1409 # The authpriv file has restricted access.
1410 authpriv.* /var/log/secure
1412 # Log all the mail messages in one place.
1413 mail.* /var/log/maillog
1416 (define* (syslog-service #:optional (config (syslog-configuration)))
1417 "Return a service that runs @command{syslogd} and takes
1418 @var{<syslog-configuration>} as a parameter.
1420 @xref{syslogd invocation,,, inetutils, GNU Inetutils}, for more
1421 information on the configuration file syntax."
1422 (service syslog-service-type config))
1425 (define pam-limits-service-type
1426 (let ((security-limits
1427 ;; Create /etc/security containing the provided "limits.conf" file.
1428 (lambda (limits-file)
1429 `(("security/limits.conf"
1433 (let ((pam-limits (pam-entry
1434 (control "required")
1435 (module "pam_limits.so")
1436 (arguments '("conf=/etc/security/limits.conf")))))
1437 (if (member (pam-service-name pam)
1438 '("login" "su" "slim" "gdm-password" "sddm"))
1441 (session (cons pam-limits
1442 (pam-service-session pam))))
1447 (list (service-extension etc-service-type security-limits)
1448 (service-extension pam-root-service-type
1449 (lambda _ (list pam-extension)))))
1451 "Install the specified resource usage limits by populating
1452 @file{/etc/security/limits.conf} and using the @code{pam_limits}
1453 authentication module."))))
1455 (define* (pam-limits-service #:optional (limits '()))
1456 "Return a service that makes selected programs respect the list of
1457 pam-limits-entry specified in LIMITS via pam_limits.so."
1458 (service pam-limits-service-type
1459 (plain-file "limits.conf"
1460 (string-join (map pam-limits-entry->string limits)
1468 (define* (guix-build-accounts count #:key
1471 "Return a list of COUNT user accounts for Guix build users with the given
1473 (unfold (cut > <> count)
1476 (name (format #f "guixbuilder~2,'0d" n))
1480 ;; guix-daemon expects GROUP to be listed as a
1481 ;; supplementary group too:
1482 ;; <http://lists.gnu.org/archive/html/bug-guix/2013-01/msg00239.html>.
1483 (supplementary-groups (list group "kvm"))
1485 (comment (format #f "Guix Build User ~2d" n))
1486 (home-directory "/var/empty")
1487 (shell (file-append shadow "/sbin/nologin"))))
1492 ;; Select (guix …) and (gnu …) modules, except (guix config).
1494 (('guix 'config) #f)
1495 (('guix rest ...) #t)
1496 (('gnu rest ...) #t)
1499 (define (substitute-key-authorization keys guix)
1500 "Return a gexp with code to register KEYS, a list of files containing 'guix
1501 archive' public keys, with GUIX."
1503 (with-extensions (list guile-gcrypt)
1504 (with-imported-modules `(((guix config) => ,(make-config.scm))
1505 ,@(source-module-closure '((guix pki))
1506 #:select? not-config?))
1507 (computed-file "acl"
1509 (use-modules (guix pki)
1515 (call-with-input-file file
1516 (compose string->canonical-sexp
1520 (call-with-output-file #$output
1522 (write-acl (public-keys->acl keys)
1525 (with-imported-modules '((guix build utils))
1527 (use-modules (guix build utils))
1529 ;; If the ACL already exists, move it out of the way. Create a backup
1530 ;; if it's a regular file: it's likely that the user manually updated
1531 ;; it with 'guix archive --authorize'.
1532 (if (file-exists? "/etc/guix/acl")
1533 (if (and (symbolic-link? "/etc/guix/acl")
1534 (store-file-name? (readlink "/etc/guix/acl")))
1535 (delete-file "/etc/guix/acl")
1536 (rename-file "/etc/guix/acl" "/etc/guix/acl.bak"))
1537 (mkdir-p "/etc/guix"))
1539 ;; Installed the declared ACL.
1540 (symlink #+default-acl "/etc/guix/acl"))))
1542 (define %default-authorized-guix-keys
1543 ;; List of authorized substitute keys.
1544 (list (file-append guix "/share/guix/berlin.guix.gnu.org.pub")
1545 (file-append guix "/share/guix/bordeaux.guix.gnu.org.pub")))
1547 (define-record-type* <guix-configuration>
1548 guix-configuration make-guix-configuration
1550 (guix guix-configuration-guix ;file-like
1552 (build-group guix-configuration-build-group ;string
1553 (default "guixbuild"))
1554 (build-accounts guix-configuration-build-accounts ;integer
1556 (authorize-key? guix-configuration-authorize-key? ;Boolean
1558 (authorized-keys guix-configuration-authorized-keys ;list of gexps
1559 (default %default-authorized-guix-keys))
1560 (use-substitutes? guix-configuration-use-substitutes? ;Boolean
1562 (substitute-urls guix-configuration-substitute-urls ;list of strings
1563 (default %default-substitute-urls))
1564 (chroot-directories guix-configuration-chroot-directories ;list of file-like/strings
1566 (max-silent-time guix-configuration-max-silent-time ;integer
1568 (timeout guix-configuration-timeout ;integer
1570 (log-compression guix-configuration-log-compression
1572 (discover? guix-configuration-discover?
1574 (extra-options guix-configuration-extra-options ;list of strings
1576 (log-file guix-configuration-log-file ;string
1577 (default "/var/log/guix-daemon.log"))
1578 (http-proxy guix-http-proxy ;string | #f
1580 (tmpdir guix-tmpdir ;string | #f
1583 (define %default-guix-configuration
1584 (guix-configuration))
1586 (define shepherd-set-http-proxy-action
1587 ;; Shepherd action to change the HTTP(S) proxy.
1589 (name 'set-http-proxy)
1591 "Change the HTTP(S) proxy used by 'guix-daemon' and restart it.")
1592 (procedure #~(lambda* (_ #:optional proxy)
1593 (let ((environment (environ)))
1594 ;; A bit of a hack: communicate PROXY to the 'start'
1595 ;; method via environment variables.
1598 (format #t "changing HTTP/HTTPS \
1599 proxy of 'guix-daemon' to ~s...~%"
1601 (setenv "http_proxy" proxy))
1603 (format #t "clearing HTTP/HTTPS \
1604 proxy of 'guix-daemon'...~%")
1605 (unsetenv "http_proxy")))
1606 (action 'guix-daemon 'restart)
1607 (environ environment)
1610 (define shepherd-discover-action
1611 ;; Shepherd action to enable or disable substitute servers discovery.
1615 "Enable or disable substitute servers discovery and restart the
1617 (procedure #~(lambda* (_ status)
1618 (let ((environment (environ)))
1620 (string=? status "on"))
1622 (format #t "enable substitute servers discovery~%")
1623 (setenv "discover" "on"))
1625 (format #t "disable substitute servers discovery~%")
1626 (unsetenv "discover")))
1627 (action 'guix-daemon 'restart)
1628 (environ environment)
1631 (define (guix-shepherd-service config)
1632 "Return a <shepherd-service> for the Guix daemon service with CONFIG."
1633 (match-record config <guix-configuration>
1634 (guix build-group build-accounts authorize-key? authorized-keys
1635 use-substitutes? substitute-urls max-silent-time timeout
1636 log-compression discover? extra-options log-file
1637 http-proxy tmpdir chroot-directories)
1638 (list (shepherd-service
1639 (documentation "Run the Guix daemon.")
1640 (provision '(guix-daemon))
1641 (requirement '(user-processes))
1642 (actions (list shepherd-set-http-proxy-action
1643 shepherd-discover-action))
1644 (modules '((srfi srfi-1)
1646 (gnu build shepherd)))
1648 (with-imported-modules `(((guix config) => ,(make-config.scm))
1649 ,@(source-module-closure
1650 '((gnu build shepherd))
1651 #:select? not-config?))
1654 ;; HTTP/HTTPS proxy. The 'http_proxy' variable is set by
1655 ;; the 'set-http-proxy' action.
1656 (or (getenv "http_proxy") #$http-proxy))
1659 (or (getenv "discover") #$discover?))
1661 ;; Start the guix-daemon from a container, when supported,
1662 ;; to solve an installation issue. See the comment below for
1664 (fork+exec-command/container
1665 (cons* #$(file-append guix "/bin/guix-daemon")
1666 "--build-users-group" #$build-group
1668 #$(number->string max-silent-time)
1669 "--timeout" #$(number->string timeout)
1671 #$(symbol->string log-compression)
1672 #$@(if use-substitutes?
1674 '("--no-substitutes"))
1675 (string-append "--discover="
1676 (if discover? "yes" "no"))
1677 "--substitute-urls" #$(string-join substitute-urls)
1680 ;; Add CHROOT-DIRECTORIES and all their dependencies
1681 ;; (if these are store items) to the chroot.
1684 (append-map (lambda (directory)
1685 (list "--chroot-directory"
1687 (call-with-input-file file
1689 '#$(map references-file
1690 chroot-directories)))
1692 ;; When running the installer, we need guix-daemon to
1693 ;; operate from within the same MNT namespace as the
1694 ;; installation container. In that case only, enter the
1695 ;; namespace of the process PID passed as start argument.
1696 ;; Otherwise, for symmetry purposes enter the caller
1697 ;; namespaces which is a no-op.
1699 ((pid) (string->number pid))
1702 #:environment-variables
1703 (append (list #$@(if tmpdir
1704 (list (string-append "TMPDIR=" tmpdir))
1707 ;; Make sure we run in a UTF-8 locale so that
1708 ;; 'guix offload' correctly restores nars
1709 ;; that contain UTF-8 file names such as
1711 ;; <https://bugs.gnu.org/32942>.
1712 (string-append "GUIX_LOCPATH="
1713 #$glibc-utf8-locales
1716 ;; Make 'tar' and 'gzip' available so
1717 ;; that 'guix perform-download' can use
1718 ;; them when downloading from Software
1719 ;; Heritage via '(guix swh)'.
1720 (string-append "PATH="
1721 #$(file-append tar "/bin") ":"
1722 #$(file-append gzip "/bin")))
1724 (list (string-append "http_proxy=" proxy)
1725 (string-append "https_proxy=" proxy))
1728 #:log-file #$log-file))))
1729 (stop #~(make-kill-destructor))))))
1731 (define (guix-accounts config)
1732 "Return the user accounts and user groups for CONFIG."
1734 (($ <guix-configuration> _ build-group build-accounts)
1739 ;; Use a fixed GID so that we can create the store with the right
1742 (guix-build-accounts build-accounts
1743 #:group build-group)))))
1745 (define (guix-activation config)
1746 "Return the activation gexp for CONFIG."
1747 (match-record config <guix-configuration>
1748 (guix authorize-key? authorized-keys)
1750 ;; Assume that the store has BUILD-GROUP as its group. We could
1751 ;; otherwise call 'chown' here, but the problem is that on a COW overlayfs,
1752 ;; chown leads to an entire copy of the tree, which is a bad idea.
1754 ;; Generate a key pair and optionally authorize substitute server keys.
1755 (unless (file-exists? "/etc/guix/signing-key.pub")
1756 (system* #$(file-append guix "/bin/guix") "archive"
1759 #$(if authorize-key?
1760 (substitute-key-authorization authorized-keys guix)
1763 (define* (references-file item #:optional (name "references"))
1764 "Return a file that contains the list of references of ITEM."
1765 (if (struct? item) ;lowerable object
1767 (with-extensions (list guile-gcrypt) ;for store-copy
1768 (with-imported-modules (source-module-closure
1769 '((guix build store-copy)))
1771 (use-modules (guix build store-copy))
1773 (call-with-output-file #$output
1775 (write (map store-info-item
1776 (call-with-input-file "graph"
1777 read-reference-graph))
1779 #:options `(#:local-build? #f
1780 #:references-graphs (("graph" ,item))))
1781 (plain-file name "()")))
1783 (define guix-service-type
1787 (list (service-extension shepherd-root-service-type guix-shepherd-service)
1788 (service-extension account-service-type guix-accounts)
1789 (service-extension activation-service-type guix-activation)
1790 (service-extension profile-service-type
1791 (compose list guix-configuration-guix))))
1793 ;; Extensions can specify extra directories to add to the build chroot.
1794 (compose concatenate)
1795 (extend (lambda (config directories)
1799 (append (guix-configuration-chroot-directories config)
1802 (default-value (guix-configuration))
1804 "Run the build daemon of GNU@tie{}Guix, aka. @command{guix-daemon}.")))
1807 (define-record-type* <guix-publish-configuration>
1808 guix-publish-configuration make-guix-publish-configuration
1809 guix-publish-configuration?
1810 (guix guix-publish-configuration-guix ;file-like
1812 (port guix-publish-configuration-port ;number
1814 (host guix-publish-configuration-host ;string
1815 (default "localhost"))
1816 (advertise? guix-publish-advertise? ;boolean
1818 (compression guix-publish-configuration-compression
1820 (default (default-compression this-record
1821 (current-source-location))))
1822 (compression-level %guix-publish-configuration-compression-level ;deprecated
1824 (nar-path guix-publish-configuration-nar-path ;string
1826 (cache guix-publish-configuration-cache ;#f | string
1828 (cache-bypass-threshold guix-publish-configuration-cache-bypass-threshold
1829 (default (* 10 (expt 2 20)))) ;integer
1830 (workers guix-publish-configuration-workers ;#f | integer
1832 (ttl guix-publish-configuration-ttl ;#f | integer
1834 (negative-ttl guix-publish-configuration-negative-ttl ;#f | integer
1837 (define-deprecated (guix-publish-configuration-compression-level config)
1838 "Return a compression level, the old way."
1839 (match (guix-publish-configuration-compression config)
1840 (((_ level) _ ...) level)))
1842 (define (default-compression config properties)
1843 "Return the default 'guix publish' compression according to CONFIG, and
1844 raise a deprecation warning if the 'compression-level' field was used."
1845 (match (%guix-publish-configuration-compression-level config)
1847 ;; Default to low compression levels when there's no cache so that users
1848 ;; get good bandwidth by default.
1849 (if (guix-publish-configuration-cache config)
1850 '(("gzip" 5) ("zstd" 19))
1851 '(("gzip" 3) ("zstd" 3)))) ;zstd compresses faster
1853 (warn-about-deprecation 'compression-level properties
1854 #:replacement 'compression)
1855 `(("gzip" ,level)))))
1857 (define (guix-publish-shepherd-service config)
1858 (define (config->compression-options config)
1859 (match (guix-publish-configuration-compression config)
1860 (() ;empty list means "no compression"
1863 (append-map (match-lambda
1865 `("-C" ,(string-append type ":"
1866 (number->string level)))))
1869 (match-record config <guix-publish-configuration>
1870 (guix port host nar-path cache workers ttl negative-ttl
1871 cache-bypass-threshold advertise?)
1872 (list (shepherd-service
1873 (provision '(guix-publish))
1874 (requirement `(user-processes
1876 ,@(if advertise? '(avahi-daemon) '())))
1877 (start #~(make-forkexec-constructor
1878 (list #$(file-append guix "/bin/guix")
1879 "publish" "-u" "guix-publish"
1880 "-p" #$(number->string port)
1881 #$@(config->compression-options config)
1882 (string-append "--nar-path=" #$nar-path)
1883 (string-append "--listen=" #$host)
1888 #~((string-append "--workers="
1893 #~((string-append "--ttl="
1894 #$(number->string ttl)
1898 #~((string-append "--negative-ttl="
1899 #$(number->string negative-ttl)
1903 #~((string-append "--cache=" #$cache)
1905 "--cache-bypass-threshold="
1907 cache-bypass-threshold)))
1910 ;; Make sure we run in a UTF-8 locale so we can produce
1911 ;; nars for packages that contain UTF-8 file names such
1912 ;; as 'nss-certs'. See <https://bugs.gnu.org/26948>.
1913 #:environment-variables
1914 (list (string-append "GUIX_LOCPATH="
1915 #$glibc-utf8-locales "/lib/locale")
1916 "LC_ALL=en_US.utf8")
1917 #:log-file "/var/log/guix-publish.log"))
1918 (stop #~(make-kill-destructor))))))
1920 (define %guix-publish-accounts
1921 (list (user-group (name "guix-publish") (system? #t))
1923 (name "guix-publish")
1924 (group "guix-publish")
1926 (comment "guix publish user")
1927 (home-directory "/var/empty")
1928 (shell (file-append shadow "/sbin/nologin")))))
1930 (define %guix-publish-log-rotations
1932 (files (list "/var/log/guix-publish.log")))))
1934 (define (guix-publish-activation config)
1935 (let ((cache (guix-publish-configuration-cache config)))
1937 (with-imported-modules '((guix build utils))
1939 (use-modules (guix build utils))
1942 (let* ((pw (getpw "guix-publish"))
1943 (uid (passwd:uid pw))
1944 (gid (passwd:gid pw)))
1945 (chown #$cache uid gid))))
1948 (define guix-publish-service-type
1949 (service-type (name 'guix-publish)
1951 (list (service-extension shepherd-root-service-type
1952 guix-publish-shepherd-service)
1953 (service-extension account-service-type
1954 (const %guix-publish-accounts))
1955 (service-extension rottlog-service-type
1956 (const %guix-publish-log-rotations))
1957 (service-extension activation-service-type
1958 guix-publish-activation)))
1959 (default-value (guix-publish-configuration))
1961 "Add a Shepherd service running @command{guix publish}, a
1962 command that allows you to share pre-built binaries with others over HTTP.")))
1969 (define-record-type* <udev-configuration>
1970 udev-configuration make-udev-configuration
1972 (udev udev-configuration-udev ;file-like
1974 (rules udev-configuration-rules ;list of file-like
1977 (define (udev-rules-union packages)
1978 "Return the union of the @code{lib/udev/rules.d} directories found in each
1979 item of @var{packages}."
1981 (with-imported-modules '((guix build union)
1984 (use-modules (guix build union)
1989 (define %standard-locations
1990 '("/lib/udev/rules.d" "/libexec/udev/rules.d"))
1992 (define (rules-sub-directory directory)
1993 ;; Return the sub-directory of DIRECTORY containing udev rules, or
1994 ;; #f if none was found.
1995 (find directory-exists?
1996 (map (cut string-append directory <>) %standard-locations)))
1998 (union-build #$output
1999 (filter-map rules-sub-directory '#$packages)))))
2001 (computed-file "udev-rules" build))
2003 (define (udev-rule file-name contents)
2004 "Return a directory with a udev rule file FILE-NAME containing CONTENTS."
2005 (computed-file file-name
2006 (with-imported-modules '((guix build utils))
2008 (use-modules (guix build utils))
2011 (string-append #$output "/lib/udev/rules.d"))
2014 (call-with-output-file
2015 (string-append rules.d "/" #$file-name)
2017 (display #$contents port)))))))
2019 (define (file->udev-rule file-name file)
2020 "Return a directory with a udev rule file FILE-NAME which is a copy of FILE."
2021 (computed-file file-name
2022 (with-imported-modules '((guix build utils))
2024 (use-modules (guix build utils))
2027 (string-append #$output "/lib/udev/rules.d"))
2029 (define file-copy-dest
2030 (string-append rules.d "/" #$file-name))
2033 (copy-file #$file file-copy-dest)))))
2035 (define kvm-udev-rule
2036 ;; Return a directory with a udev rule that changes the group of /dev/kvm to
2037 ;; "kvm" and makes it #o660. Apparently QEMU-KVM used to ship this rule,
2038 ;; but now we have to add it by ourselves.
2040 ;; Build users are part of the "kvm" group, so we can fearlessly make
2041 ;; /dev/kvm 660 (see <http://bugs.gnu.org/18994>, for background.)
2042 (udev-rule "90-kvm.rules"
2043 "KERNEL==\"kvm\", GROUP=\"kvm\", MODE=\"0660\"\n"))
2045 (define udev-shepherd-service
2046 ;; Return a <shepherd-service> for UDEV with RULES.
2048 (($ <udev-configuration> udev)
2053 ;; Udev needs /dev to be a 'devtmpfs' mount so that new device nodes can
2055 ;; <http://www.linuxfromscratch.org/lfs/view/development/chapter07/udev.html>.
2056 (requirement '(root-file-system))
2058 (documentation "Populate the /dev directory, dynamically.")
2060 (with-imported-modules (source-module-closure
2061 '((gnu build linux-boot)))
2064 ;; 'udevd' from eudev.
2065 #$(file-append udev "/sbin/udevd"))
2067 (define (wait-for-udevd)
2068 ;; Wait until someone's listening on udevd's control
2070 (let ((sock (socket AF_UNIX SOCK_SEQPACKET 0)))
2072 (catch 'system-error
2074 (connect sock PF_UNIX "/run/udev/control")
2077 (format #t "waiting for udevd...~%")
2081 ;; Allow udev to find the modules.
2082 (setenv "LINUX_MODULE_DIRECTORY"
2083 "/run/booted-system/kernel/lib/modules")
2085 (let* ((kernel-release
2086 (utsname:release (uname)))
2087 (linux-module-directory
2088 (getenv "LINUX_MODULE_DIRECTORY"))
2090 (string-append linux-module-directory "/"
2092 (old-umask (umask #o022)))
2093 ;; If we're in a container, DIRECTORY might not exist,
2094 ;; for instance because the host runs a different
2095 ;; kernel. In that case, skip it; we'll just miss a few
2096 ;; nodes like /dev/fuse.
2097 (when (file-exists? directory)
2098 (make-static-device-nodes directory))
2101 (let ((pid (fork+exec-command
2103 #:environment-variables
2105 ;; The first one is for udev, the second one for
2107 "UDEV_CONFIG_FILE=/etc/udev/udev.conf"
2108 "EUDEV_RULES_DIRECTORY=/etc/udev/rules.d"
2109 (string-append "LINUX_MODULE_DIRECTORY="
2110 (getenv "LINUX_MODULE_DIRECTORY"))
2111 (default-environment-variables)))))
2112 ;; Wait until udevd is up and running. This appears to
2113 ;; be needed so that the events triggered below are
2114 ;; actually handled.
2117 ;; Trigger device node creation.
2118 (system* #$(file-append udev "/bin/udevadm")
2119 "trigger" "--action=add")
2121 ;; Wait for things to settle down.
2122 (system* #$(file-append udev "/bin/udevadm")
2125 (stop #~(make-kill-destructor))
2127 ;; When halting the system, 'udev' is actually killed by
2128 ;; 'user-processes', i.e., before its own 'stop' method was called.
2129 ;; Thus, make sure it is not respawned.
2131 ;; We need additional modules.
2132 (modules `((gnu build linux-boot) ;'make-static-device-nodes'
2133 ,@%default-modules)))))))
2136 (computed-file "udev.conf"
2137 #~(call-with-output-file #$output
2139 (format port "udev_rules=\"/etc/udev/rules.d\"~%")))))
2143 (($ <udev-configuration> udev rules)
2146 "udev" `(("udev.conf" ,udev.conf)
2147 ("rules.d" ,(udev-rules-union (cons* udev kvm-udev-rule
2150 (define udev-service-type
2151 (service-type (name 'udev)
2153 (list (service-extension shepherd-root-service-type
2154 udev-shepherd-service)
2155 (service-extension etc-service-type udev-etc)))
2156 (compose concatenate) ;concatenate the list of rules
2157 (extend (lambda (config rules)
2159 (($ <udev-configuration> udev initial-rules)
2162 (rules (append initial-rules rules)))))))
2163 (default-value (udev-configuration))
2165 "Run @command{udev}, which populates the @file{/dev}
2166 directory dynamically. Get extra rules from the packages listed in the
2167 @code{rules} field of its value, @code{udev-configuration} object.")))
2169 (define* (udev-service #:key (udev eudev) (rules '()))
2170 "Run @var{udev}, which populates the @file{/dev} directory dynamically. Get
2171 extra rules from the packages listed in @var{rules}."
2172 (service udev-service-type
2173 (udev-configuration (udev udev) (rules rules))))
2175 (define* (udev-rules-service name rules #:key (groups '()))
2176 "Return a service that extends udev-service-type with RULES and
2177 account-service-type with GROUPS as system groups. This works by creating a
2178 singleton service type NAME-udev-rules, of which the returned service is an
2180 (let* ((name (symbol-append name '-udev-rules))
2182 (const (map (lambda (group)
2183 (user-group (name group) (system? #t)))
2185 (udev-extension (const (list rules)))
2190 account-service-type account-extension)
2192 udev-service-type udev-extension))))))
2195 (define (swap-space->shepherd-service-name space)
2196 (let ((target (swap-space-target space)))
2197 (symbol-append 'swap-
2199 (cond ((uuid? target)
2200 (uuid->string target))
2201 ((file-system-label? target)
2202 (file-system-label->string target))
2206 ; TODO Remove after deprecation
2207 (define (swap-deprecated->shepherd-service-name sdep)
2208 (symbol-append 'swap-
2211 (string-take (uuid->string sdep) 6))
2212 ((file-system-label? sdep)
2213 (file-system-label->string sdep))
2217 (define swap->shepherd-service-name
2218 (match-lambda ((? swap-space? space)
2219 (swap-space->shepherd-service-name space))
2221 (swap-deprecated->shepherd-service-name sdep))))
2223 (define swap-service-type
2224 (shepherd-service-type
2227 (define requirements
2228 (cond ((swap-space? swap)
2229 (map dependency->shepherd-service-name
2230 (swap-space-dependencies swap)))
2231 ; TODO Remove after deprecation
2232 ((and (string? swap) (string-prefix? "/dev/mapper/" swap))
2233 (list (symbol-append 'device-mapping-
2234 (string->symbol (basename swap)))))
2238 (define device-lookup
2239 ;; The generic 'find-partition' procedures could return a partition
2240 ;; that's not swap space, but that's unlikely.
2241 (cond ((swap-space? swap)
2242 (let ((target (swap-space-target swap)))
2243 (cond ((uuid? target)
2244 #~(find-partition-by-uuid #$(uuid-bytevector target)))
2245 ((file-system-label? target)
2246 #~(find-partition-by-label
2247 #$(file-system-label->string target)))
2250 ; TODO Remove after deprecation
2252 #~(find-partition-by-uuid #$(uuid-bytevector swap)))
2253 ((file-system-label? swap)
2254 #~(find-partition-by-label
2255 #$(file-system-label->string swap)))
2259 (with-imported-modules (source-module-closure '((gnu build file-systems)))
2261 (provision (list (swap->shepherd-service-name swap)))
2262 (requirement `(udev ,@requirements))
2263 (documentation "Enable the given swap space.")
2264 (modules `((gnu build file-systems)
2265 ,@%default-modules))
2267 (let ((device #$device-lookup))
2270 (restart-on-EINTR (swapon device
2271 #$(if (swap-space? swap)
2272 (swap-space->flags-bit-mask
2277 (let ((device #$device-lookup))
2279 (restart-on-EINTR (swapoff device)))
2282 (description "Turn on the virtual memory swap area.")))
2284 (define (swap-service swap)
2285 "Return a service that uses @var{swap} as a swap space."
2286 (service swap-service-type swap))
2288 (define %default-gpm-options
2289 ;; Default options for GPM.
2290 '("-m" "/dev/input/mice" "-t" "ps2"))
2292 (define-record-type* <gpm-configuration>
2293 gpm-configuration make-gpm-configuration gpm-configuration?
2294 (gpm gpm-configuration-gpm ;file-like
2296 (options gpm-configuration-options ;list of strings
2297 (default %default-gpm-options)))
2299 (define gpm-shepherd-service
2301 (($ <gpm-configuration> gpm options)
2302 (list (shepherd-service
2303 (requirement '(udev))
2305 ;; 'gpm' runs in the background and sets a PID file.
2306 ;; Note that it requires running as "root".
2307 (start #~(make-forkexec-constructor
2308 (list #$(file-append gpm "/sbin/gpm")
2310 #:pid-file "/var/run/gpm.pid"
2311 #:pid-file-timeout 3))
2313 ;; Return #f if successfully stopped.
2314 (not (zero? (system* #$(file-append gpm "/sbin/gpm")
2317 (define gpm-service-type
2318 (service-type (name 'gpm)
2320 (list (service-extension shepherd-root-service-type
2321 gpm-shepherd-service)))
2322 (default-value (gpm-configuration))
2324 "Run GPM, the general-purpose mouse daemon, with the given
2325 command-line options. GPM allows users to use the mouse in the console,
2326 notably to select, copy, and paste text. The default options use the
2327 @code{ps2} protocol, which works for both USB and PS/2 mice.")))
2330 (define-record-type* <kmscon-configuration>
2331 kmscon-configuration make-kmscon-configuration
2332 kmscon-configuration?
2333 (kmscon kmscon-configuration-kmscon
2335 (virtual-terminal kmscon-configuration-virtual-terminal)
2336 (login-program kmscon-configuration-login-program
2337 (default (file-append shadow "/bin/login")))
2338 (login-arguments kmscon-configuration-login-arguments
2340 (auto-login kmscon-configuration-auto-login
2342 (hardware-acceleration? kmscon-configuration-hardware-acceleration?
2343 (default #f)) ; #t causes failure
2344 (font-engine kmscon-configuration-font-engine
2346 (font-size kmscon-configuration-font-size
2348 (keyboard-layout kmscon-configuration-keyboard-layout
2349 (default #f))) ; #f | <keyboard-layout>
2351 (define kmscon-service-type
2352 (shepherd-service-type
2355 (let ((kmscon (kmscon-configuration-kmscon config))
2356 (virtual-terminal (kmscon-configuration-virtual-terminal config))
2357 (login-program (kmscon-configuration-login-program config))
2358 (login-arguments (kmscon-configuration-login-arguments config))
2359 (auto-login (kmscon-configuration-auto-login config))
2360 (hardware-acceleration? (kmscon-configuration-hardware-acceleration? config))
2361 (font-engine (kmscon-configuration-font-engine config))
2362 (font-size (kmscon-configuration-font-size config))
2363 (keyboard-layout (kmscon-configuration-keyboard-layout config)))
2365 (define kmscon-command
2367 #$(file-append kmscon "/bin/kmscon") "--login"
2368 "--vt" #$virtual-terminal
2369 "--no-switchvt" ;Prevent a switch to the virtual terminal.
2370 "--font-engine" #$font-engine
2371 "--font-size" #$(number->string font-size)
2372 #$@(if keyboard-layout
2373 (let* ((layout (keyboard-layout-name keyboard-layout))
2374 (variant (keyboard-layout-variant keyboard-layout))
2375 (model (keyboard-layout-model keyboard-layout))
2376 (options (keyboard-layout-options keyboard-layout)))
2377 `("--xkb-layout" ,layout
2378 ,@(if variant `("--xkb-variant" ,variant) '())
2379 ,@(if model `("--xkb-model" ,model) '())
2380 ,@(if (null? options)
2382 `("--xkb-options" ,(string-join options ",")))))
2384 #$@(if hardware-acceleration? '("--hwaccel") '())
2386 #$login-program #$@login-arguments
2392 (documentation "kmscon virtual terminal")
2393 (requirement '(user-processes udev dbus-system))
2394 (provision (list (symbol-append 'term- (string->symbol virtual-terminal))))
2395 (start #~(make-forkexec-constructor #$kmscon-command))
2396 (stop #~(make-kill-destructor)))))
2397 (description "Start the @command{kmscon} virtual terminal emulator for the
2398 Linux @dfn{kernel mode setting} (KMS).")))
2402 ;;; Static networking.
2405 (define (ipv6-address? str)
2406 "Return true if STR denotes an IPv6 address."
2407 (false-if-exception (->bool (inet-pton AF_INET6 str))))
2409 (define-compile-time-procedure (assert-valid-address (address string?))
2410 "Ensure ADDRESS has a valid netmask."
2411 (unless (cidr->netmask address)
2413 (make-compound-condition
2414 (formatted-message (G_ "address '~a' lacks a network mask")
2416 (condition (&error-location
2418 (source-properties->location procedure-call-location))))
2419 (condition (&fix-hint
2420 (hint (format #f (G_ "\
2421 Write, say, @samp{\"~a/24\"} for a 24-bit network mask.")
2425 (define-record-type* <static-networking>
2426 static-networking make-static-networking
2428 (addresses static-networking-addresses) ;list of <network-address>
2429 (links static-networking-links (default '())) ;list of <network-link>
2430 (routes static-networking-routes (default '())) ;list of <network-routes>
2431 (provision static-networking-provision
2432 (default '(networking)))
2433 (requirement static-networking-requirement
2435 (name-servers static-networking-name-servers ;FIXME: doesn't belong here
2438 (define-record-type* <network-address>
2439 network-address make-network-address
2441 (device network-address-device) ;string--e.g., "en01"
2442 (value network-address-value ;string--CIDR notation
2443 (sanitize assert-valid-address))
2444 (ipv6? network-address-ipv6? ;Boolean
2447 (ipv6-address? (cidr->ip (network-address-value this-record))))))
2449 (define-record-type* <network-link>
2450 network-link make-network-link
2452 (name network-link-name) ;string--e.g, "v0p0"
2453 (type network-link-type) ;symbol--e.g.,'veth
2454 (arguments network-link-arguments)) ;list
2456 (define-record-type* <network-route>
2457 network-route make-network-route
2459 (destination network-route-destination)
2460 (source network-route-source (default #f))
2461 (device network-route-device (default #f))
2462 (ipv6? network-route-ipv6? (thunked)
2464 (or (ipv6-address? (network-route-destination this-record))
2465 (and=> (network-route-gateway this-record)
2467 (gateway network-route-gateway (default #f)))
2469 (define* (cidr->netmask str #:optional (family AF_INET))
2470 "Given @var{str}, a string in CIDR notation (e.g., \"1.2.3.4/24\"), return
2471 the netmask as a string like \"255.255.255.0\"."
2472 (match (string-split str #\/)
2473 ((ip (= string->number bits))
2474 (let ((mask (ash (- (expt 2 bits) 1)
2475 (- (if (= family AF_INET6) 128 32)
2477 (inet-ntop family mask)))
2480 (define (cidr->ip str)
2481 "Strip the netmask bit of @var{str}, a CIDR-notation IP/netmask address."
2482 (match (string-split str #\/)
2486 (define* (ip+netmask->cidr ip netmask #:optional (family AF_INET))
2487 "Return the CIDR notation (a string) for @var{ip} and @var{netmask}, two
2488 @var{family} address strings, where @var{family} is @code{AF_INET} or
2490 (let* ((netmask (inet-pton family netmask))
2491 (bits (logcount netmask)))
2492 (string-append ip "/" (number->string bits))))
2494 (define (static-networking->hurd-pfinet-options config)
2495 "Return command-line options for the Hurd's pfinet translator corresponding
2497 (unless (null? (static-networking-links config))
2498 ;; XXX: Presumably this is not supported, or perhaps could be approximated
2499 ;; by running separate pfinet instances in some cases?
2500 (warning (G_ "network links are currently ignored on GNU/Hurd~%")))
2502 (match (static-networking-addresses config)
2503 ((and addresses (first _ ...))
2504 `("--ipv6" "/servers/socket/26"
2505 "--interface" ,(network-address-device first)
2506 ,@(append-map (lambda (address)
2507 `(,(if (network-address-ipv6? address)
2510 ,(cidr->ip (network-address-value address))
2511 ,@(match (cidr->netmask (network-address-value address)
2512 (if (network-address-ipv6? address)
2516 (mask (list "--netmask" mask)))))
2518 ,@(append-map (lambda (route)
2520 (($ <network-route> "default" #f device _ gateway)
2521 (if (network-route-ipv6? route)
2522 `("--gateway6" ,gateway)
2523 `("--gateway" ,gateway)))
2524 (($ <network-route> destination)
2525 (warning (G_ "ignoring network route for '~a'~%")
2528 (static-networking-routes config))))))
2530 (define (network-set-up/hurd config)
2531 "Set up networking for the Hurd."
2532 ;; The Hurd implements SIOCGIFADDR and other old-style ioctls, but the only
2533 ;; way to set up IPv6 is by starting pfinet with the right options.
2534 (if (equal? (static-networking-provision config) '(loopback))
2535 (scheme-file "set-up-pflocal" #~(begin 'nothing-to-do! #t))
2536 (scheme-file "set-up-pfinet"
2537 (with-imported-modules '((guix build utils))
2539 (use-modules (guix build utils)
2542 ;; TODO: Do that without forking.
2543 (let ((options '#$(static-networking->hurd-pfinet-options
2545 (format #t "starting '~a~{ ~s~}'~%"
2546 #$(file-append hurd "/hurd/pfinet")
2548 (apply invoke #$(file-append hurd "/bin/settrans") "-fac"
2550 #$(file-append hurd "/hurd/pfinet")
2553 (define (network-tear-down/hurd config)
2554 (scheme-file "tear-down-pfinet"
2555 (with-imported-modules '((guix build utils))
2557 (use-modules (guix build utils))
2559 ;; Forcefully terminate pfinet. XXX: In theory this
2560 ;; should just undo the addresses and routes of CONFIG;
2561 ;; this could be done using ioctls like SIOCDELRT, but
2562 ;; these are IPv4-only; another option would be to use
2563 ;; fsysopts but that seems to crash pfinet.
2564 (invoke #$(file-append hurd "/bin/settrans") "-fg"
2565 "/servers/socket/2")
2568 (define network-set-up/linux
2570 (($ <static-networking> addresses links routes)
2571 (scheme-file "set-up-network"
2572 (with-extensions (list guile-netlink)
2574 (use-modules (ip addr) (ip link) (ip route))
2576 #$@(map (lambda (address)
2578 (addr-add #$(network-address-device address)
2579 #$(network-address-value address)
2581 #$(network-address-ipv6? address))
2583 (link-set #$(network-address-device address)
2587 #$@(map (match-lambda
2588 (($ <network-link> name type arguments)
2589 #~(link-add #$name #$type
2590 #:type-args '#$arguments)))
2592 #$@(map (lambda (route)
2593 #~(route-add #$(network-route-destination route)
2595 #$(network-route-device route)
2597 #$(network-route-ipv6? route)
2599 #$(network-route-gateway route)
2601 #$(network-route-source route)))
2605 (define network-tear-down/linux
2607 (($ <static-networking> addresses links routes)
2608 (scheme-file "tear-down-network"
2609 (with-extensions (list guile-netlink)
2611 (use-modules (ip addr) (ip link) (ip route)
2615 (define-syntax-rule (false-if-netlink-error exp)
2616 (guard (c ((netlink-error? c) #f))
2619 ;; Wrap calls in 'false-if-netlink-error' so this
2620 ;; script goes as far as possible undoing the effects
2621 ;; of "set-up-network".
2623 #$@(map (lambda (route)
2624 #~(false-if-netlink-error
2625 (route-del #$(network-route-destination route)
2627 #$(network-route-device route)
2629 #$(network-route-ipv6? route)
2631 #$(network-route-gateway route)
2633 #$(network-route-source route))))
2635 #$@(map (match-lambda
2636 (($ <network-link> name type arguments)
2637 #~(false-if-netlink-error
2638 (link-del #$name))))
2640 #$@(map (lambda (address)
2641 #~(false-if-netlink-error
2642 (addr-del #$(network-address-device
2644 #$(network-address-value address)
2646 #$(network-address-ipv6? address))))
2650 (define (static-networking-shepherd-service config)
2652 (($ <static-networking> addresses links routes
2653 provision requirement name-servers)
2654 (let ((loopback? (and provision (memq 'loopback provision))))
2658 "Bring up the networking interface using a static IP address.")
2659 (requirement requirement)
2660 (provision provision)
2663 ;; Return #t if successfully started.
2664 (load #$(let-system (system target)
2665 (if (string-contains (or target system) "-linux")
2666 (network-set-up/linux config)
2667 (network-set-up/hurd config))))))
2669 ;; Return #f is successfully stopped.
2670 (load #$(let-system (system target)
2671 (if (string-contains (or target system) "-linux")
2672 (network-tear-down/linux config)
2673 (network-tear-down/hurd config))))))
2676 (define (static-networking-shepherd-services networks)
2677 (map static-networking-shepherd-service networks))
2679 (define (static-networking-etc-files interfaces)
2680 "Return a /etc/resolv.conf entry for INTERFACES or the empty list."
2681 (match (delete-duplicates
2682 (append-map static-networking-name-servers
2687 (let ((content (string-join
2688 (map (cut string-append "nameserver " <>)
2692 ,(plain-file "resolv.conf"
2694 # Generated by 'static-networking-service'.\n"
2697 (define static-networking-service-type
2698 ;; The service type for statically-defined network interfaces.
2699 (service-type (name 'static-networking)
2702 (service-extension shepherd-root-service-type
2703 static-networking-shepherd-services)
2704 (service-extension etc-service-type
2705 static-networking-etc-files)))
2706 (compose concatenate)
2709 "Turn up the specified network interfaces upon startup,
2710 with the given IP address, gateway, netmask, and so on. The value for
2711 services of this type is a list of @code{static-networking} objects, one per
2712 network interface.")))
2714 (define-deprecated (static-networking-service interface ip
2716 netmask gateway provision
2717 ;; Most interfaces require udev to be usable.
2718 (requirement '(udev))
2720 static-networking-service-type
2721 "Return a service that starts @var{interface} with address @var{ip}. If
2722 @var{netmask} is true, use it as the network mask. If @var{gateway} is true,
2723 it must be a string specifying the default network gateway.
2725 This procedure can be called several times, one for each network
2726 interface of interest. Behind the scenes what it does is extend
2727 @code{static-networking-service-type} with additional network interfaces
2729 (simple-service 'static-network-interface
2730 static-networking-service-type
2731 (list (static-networking
2733 (list (network-address
2736 (ip+netmask->cidr ip netmask)
2741 (list (network-route
2742 (destination "default")
2746 (requirement requirement)
2747 (provision (or provision '(networking)))
2748 (name-servers name-servers)))))
2750 (define %loopback-static-networking
2751 ;; The loopback device.
2753 (addresses (list (network-address
2755 (value "127.0.0.1/8"))))
2757 (provision '(loopback))))
2759 (define %qemu-static-networking
2760 ;; Networking configuration for QEMU's user-mode network stack (info "(QEMU)
2761 ;; Using the user mode network stack").
2763 (addresses (list (network-address
2765 (value "10.0.2.15/24"))))
2766 (routes (list (network-route
2767 (destination "default")
2768 (gateway "10.0.2.2"))))
2770 (provision '(networking))
2771 (name-servers '("10.0.2.3"))))
2774 (define %base-services
2775 ;; Convenience variable holding the basic services.
2776 (list (service login-service-type)
2778 (service virtual-terminal-service-type)
2779 (service console-font-service-type
2781 (cons tty %default-console-font))
2782 '("tty1" "tty2" "tty3" "tty4" "tty5" "tty6")))
2784 (service agetty-service-type (agetty-configuration
2785 (extra-options '("-L")) ; no carrier detect
2787 (tty #f))) ; automatic
2789 (service mingetty-service-type (mingetty-configuration
2791 (service mingetty-service-type (mingetty-configuration
2793 (service mingetty-service-type (mingetty-configuration
2795 (service mingetty-service-type (mingetty-configuration
2797 (service mingetty-service-type (mingetty-configuration
2799 (service mingetty-service-type (mingetty-configuration
2802 (service static-networking-service-type
2803 (list %loopback-static-networking))
2805 (service urandom-seed-service-type)
2806 (service guix-service-type)
2807 (service nscd-service-type)
2809 (service rottlog-service-type)
2811 ;; The LVM2 rules are needed as soon as LVM2 or the device-mapper is
2812 ;; used, so enable them by default. The FUSE and ALSA rules are
2813 ;; less critical, but handy.
2814 (service udev-service-type
2816 (rules (list lvm2 fuse alsa-utils crda))))
2818 (service sysctl-service-type)
2820 (service special-files-service-type
2821 `(("/bin/sh" ,(file-append bash "/bin/sh"))
2822 ("/usr/bin/env" ,(file-append coreutils "/bin/env"))))))
2824 ;;; base.scm ends here
HCoop / jackhill / guix / guix.git / blob