projects/guix·blob python-team · refs

4513 lines · 195.5 KiB

1;;; GNU Guix --- Functional package management for GNU
2;;; Copyright © 2013-2026 Ludovic Courtès <[email protected]>
3;;; Copyright © 2015, 2016 Alex Kost <[email protected]>
4;;; Copyright © 2015, 2016, 2020 Mark H Weaver <[email protected]>
5;;; Copyright © 2015 Sou Bunnbu <[email protected]>
6;;; Copyright © 2016, 2017 Leo Famulari <[email protected]>
7;;; Copyright © 2016 David Craven <[email protected]>
8;;; Copyright © 2016 Ricardo Wurmus <[email protected]>
9;;; Copyright © 2018 Mathieu Othacehe <[email protected]>
10;;; Copyright © 2019 Efraim Flashner <[email protected]>
11;;; Copyright © 2019 Tobias Geerinckx-Rice <[email protected]>
12;;; Copyright © 2019 John Soo <[email protected]>
13;;; Copyright © 2019, 2023 Janneke Nieuwenhuizen <[email protected]>
14;;; Copyright © 2020 Florian Pelz <[email protected]>
15;;; Copyright © 2020, 2021 Brice Waegeneire <[email protected]>
16;;; Copyright © 2021 qblade <[email protected]>
17;;; Copyright © 2021 Hui Lu <[email protected]>
18;;; Copyright © 2021-2023, 2025 Maxim Cournoyer <[email protected]>
19;;; Copyright © 2021, 2025 muradm <[email protected]>
20;;; Copyright © 2022 Guillaume Le Vaillant <[email protected]>
21;;; Copyright © 2022 Justin Veilleux <[email protected]>
22;;; Copyright © 2022 ( <[email protected]>
23;;; Copyright © 2023 Bruno Victal <[email protected]>
24;;; Copyright © 2024 Zheng Junjie <[email protected]>
25;;; Copyright © 2024 Andreas Enge <[email protected]>
26;;; Copyright © 2026 Sughosha <[email protected]>
27;;;
28;;; This file is part of GNU Guix.
29;;;
30;;; GNU Guix is free software; you can redistribute it and/or modify it
31;;; under the terms of the GNU General Public License as published by
32;;; the Free Software Foundation; either version 3 of the License, or (at
33;;; your option) any later version.
34;;;
35;;; GNU Guix is distributed in the hope that it will be useful, but
36;;; WITHOUT ANY WARRANTY; without even the implied warranty of
37;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
38;;; GNU General Public License for more details.
39;;;
40;;; You should have received a copy of the GNU General Public License
41;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
42
43;;; Commentary:
44;;;
45;;; Base system services---i.e., services that 99% of the users will want to
46;;; use.
47;;;
48;;; Code:
49
50(define-module (gnu services base)
51 #:use-module (guix store)
52 #:use-module (guix deprecation)
53 #:autoload (guix diagnostics) (warning formatted-message &fix-hint)
54 #:autoload (guix i18n) (G_)
55 #:use-module (guix combinators)
56 #:use-module (guix packages)
57 #:use-module (guix utils)
58 #:use-module (gnu services)
59 #:use-module (gnu services admin)
60 #:use-module (gnu services configuration)
61 #:use-module (gnu services shepherd)
62 #:use-module (gnu services sysctl)
63 #:use-module (gnu system pam)
64 #:use-module (gnu system shadow) ; 'user-account', etc.
65 #:use-module (gnu system uuid)
66 #:use-module (gnu system file-systems) ; 'file-system', etc.
67 #:use-module (gnu system keyboard)
68 #:use-module (gnu system mapped-devices)
69 #:use-module ((gnu system linux-initrd)
70 #:select (file-system-packages))
71 #:use-module (gnu packages admin)
72 #:use-module ((gnu packages linux)
73 #:select (alsa-utils btrfs-progs crda eudev
74 e2fsprogs f2fs-tools fuse gpm kbd lvm2 rng-tools
75 util-linux xfsprogs))
76 #:use-module (gnu packages bash)
77 #:use-module ((gnu packages base)
78 #:select (coreutils glibc glibc/hurd
79 glibc-utf8-locales
80 libc-utf8-locales-for-target
81 make-glibc-utf8-locales
82 tar canonical-package))
83 #:use-module ((gnu packages cross-base)
84 #:select (cross-libc))
85 #:use-module ((gnu packages compression) #:select (gzip))
86 #:use-module (gnu packages fonts)
87 #:autoload (gnu packages guile-xyz) (guile-netlink)
88 #:autoload (gnu packages hurd) (hurd)
89 #:use-module (gnu packages package-management)
90 #:use-module ((gnu packages gnupg) #:select (guile-gcrypt))
91 #:use-module ((gnu packages disk)
92 #:select (dosfstools))
93 #:use-module ((gnu packages file-systems)
94 #:select (bcachefs-tools exfat-utils jfsutils zfs))
95 #:use-module (gnu packages fonts)
96 #:use-module ((gnu packages nwg-shell) #:select (nwg-hello))
97 #:use-module (gnu packages terminals)
98 #:use-module ((gnu packages window-management) #:select (sway))
99 #:use-module ((gnu build file-systems)
100 #:select (mount-flags->bit-mask
101 swap-space->flags-bit-mask))
102 #:autoload (guix channels) (%default-channels channel->code)
103 #:use-module (guix gexp)
104 #:use-module ((guix packages) #:select (package-version))
105 #:use-module (guix records)
106 #:use-module (guix modules)
107 #:use-module (guix pki)
108 #:use-module ((guix self) #:select (make-config.scm))
109 #:use-module (guix diagnostics)
110 #:use-module (guix i18n)
111 #:autoload (guix utils) (target-hurd?)
112 #:use-module (srfi srfi-1)
113 #:use-module (srfi srfi-26)
114 #:use-module (srfi srfi-34)
115 #:use-module (srfi srfi-35)
116 #:use-module (ice-9 match)
117 #:use-module (ice-9 format)
118 #:use-module (ice-9 pretty-print)
119 #:re-export (user-processes-service-type ;backwards compatibility
120 %default-substitute-urls)
121 #:export (fstab-service-type
122 root-file-system-service
123 file-system-service-type
124 file-system-utilities
125 swap-service
126 host-name-service ; deprecated
127 host-name-service-type
128 %default-console-font
129 console-font-service-type
130 console-font-service
131 virtual-terminal-service-type
132
133 host
134 host?
135 host-address
136 host-canonical-name
137 host-aliases
138 hosts-service-type
139
140 static-networking
141 static-networking?
142 static-networking-addresses
143 static-networking-links
144 static-networking-routes
145 static-networking-requirement
146
147 network-address
148 network-address?
149 network-address-device
150 network-address-value
151 network-address-ipv6?
152
153 network-link
154 network-link?
155 network-link-name
156 network-link-type
157 network-link-arguments
158
159 network-route
160 network-route?
161 network-route-destination
162 network-route-source
163 network-route-device
164 network-route-ipv6?
165 network-route-gateway
166
167 static-networking-service
168 static-networking-service-type
169
170 %loopback-static-networking
171 %qemu-static-networking
172
173 udev-configuration
174 udev-configuration?
175 udev-configuration-udev
176 udev-configuration-debug?
177 udev-configuration-rules
178 udev-configuration-hardware
179 udev-service-type
180 udev-service ; deprecated
181 udev-rule
182 udev-hardware
183 file->udev-rule
184 file->udev-hardware
185 udev-rules-service
186 udev-hardware-service
187
188 login-configuration
189 login-configuration?
190 login-service-type
191 login-service ; deprecated
192
193 agetty-configuration
194 agetty-configuration?
195 agetty-service ; deprecated
196 agetty-service-type
197
198 mingetty-configuration
199 mingetty-configuration-tty
200 mingetty-configuration-auto-login
201 mingetty-configuration-login-program
202 mingetty-configuration-login-pause?
203 mingetty-configuration-clear-on-logout?
204 mingetty-configuration-mingetty
205 mingetty-configuration-delay
206 mingetty-configuration-print-issue
207 mingetty-configuration-print-hostname
208 mingetty-configuration-nice
209 mingetty-configuration-working-directory
210 mingetty-configuration-root-directory
211 mingetty-configuration-shepherd-requirement
212 mingetty-configuration?
213 mingetty-service ; deprecated
214 mingetty-service-type
215
216 %nscd-default-caches
217 %nscd-default-configuration ; deprecated
218
219 nscd-configuration
220 nscd-configuration?
221
222 nscd-cache
223 nscd-cache?
224
225 nscd-service-type
226 nscd-service ; deprecated
227
228 syslog-configuration
229 syslog-configuration?
230 syslog-configuration-syslogd
231 syslog-configuration-config-file
232 syslog-configuration-pid-file
233 syslog-configuration-extra-options
234 syslog-service ; deprecated
235 syslog-service-type
236 %default-syslog.conf
237
238 %default-authorized-guix-keys
239 guix-configuration
240 guix-configuration?
241
242 guix-configuration-guix
243 guix-configuration-build-group
244 guix-configuration-build-accounts
245 guix-configuration-build-machines
246 guix-configuration-chroot?
247 guix-configuration-authorize-key?
248 guix-configuration-authorized-keys
249 guix-configuration-use-substitutes?
250 guix-configuration-substitute-urls
251 guix-configuration-generate-substitute-key?
252 guix-configuration-channels
253 guix-configuration-extra-options
254 guix-configuration-log-file
255 guix-configuration-environment
256
257 guix-extension
258 guix-extension?
259 guix-extension-authorized-keys
260 guix-extension-substitute-urls
261 guix-extension-chroot-directories
262
263 guix-service-type
264 guix-publish-configuration
265 guix-publish-configuration?
266 guix-publish-configuration-guix
267 guix-publish-configuration-port
268 guix-publish-configuration-host
269 guix-publish-configuration-compression
270 guix-publish-configuration-nar-path
271 guix-publish-configuration-cache
272 guix-publish-configuration-ttl
273 guix-publish-configuration-negative-ttl
274 guix-publish-service-type
275
276 gpm-configuration
277 gpm-configuration?
278 gpm-service-type
279
280 urandom-seed-service-type
281
282 rngd-configuration
283 rngd-configuration?
284 rngd-service-type
285 rngd-service ; deprecated
286
287 kmscon-configuration
288 kmscon-configuration?
289 kmscon-service-type
290
291 pam-limits-service-type
292 pam-limits-service ; deprecated
293
294 greetd-service-type
295 greetd-configuration
296 greetd-terminal-configuration
297 greetd-user-session
298 greetd-agreety-session
299 greetd-wlgreet-session ; deprecated
300 greetd-wlgreet-configuration
301 greetd-wlgreet-sway-session
302 greetd-gtkgreet-sway-session
303 nwg-hello-configuration
304 nwg-hello-configuration?
305 nwg-hello-configuration-session-dirs
306 nwg-hello-configuration-custom-sessions
307 nwg-hello-configuration-environment-variables
308 nwg-hello-configuration-halt-command
309 nwg-hello-configuration-reboot-command
310 nwg-hello-configuration-shutdown-command
311 nwg-hello-configuration-gtk-theme
312 nwg-hello-configuration-icon-theme
313 nwg-hello-configuration-cursor-theme
314 nwg-hello-configuration-prefer-dark-theme?
315 nwg-hello-configuration-extra-config
316 nwg-hello-style
317 nwg-hello-style?
318 nwg-hello-style-background-image
319 nwg-hello-style-background-size
320 nwg-hello-style-extra-style
321 greetd-nwg-hello-sway-session
322 greetd-nwg-hello-sway-session?
323 greetd-nwg-hello-sway-session-sway
324 greetd-nwg-hello-sway-session-sway-configuration
325 greetd-nwg-hello-sway-session-nwg-hello
326 greetd-nwg-hello-sway-session-nwg-hello-config
327 greetd-nwg-hello-sway-session-nwg-hello-style
328
329 %base-services))
330
331
332
333;;;
334;;; File systems.
335;;;
336
337(define (file-system->fstab-entry file-system)
338 "Return a @file{/etc/fstab} entry for @var{file-system}."
339 (string-append (match (file-system-device file-system)
340 ((? file-system-label? label)
341 (string-append "LABEL="
342 (file-system-label->string label)))
343 ((? uuid? uuid)
344 (string-append "UUID=" (uuid->string uuid)))
345 ((? string? device)
346 device))
347 "\t"
348 (file-system-mount-point file-system) "\t"
349 (file-system-type file-system) "\t"
350 (or (file-system-options file-system) "defaults") "\t"
351
352 ;; XXX: Omit the 'fs_freq' and 'fs_passno' fields because we
353 ;; don't have anything sensible to put in there.
354 ))
355
356(define (file-systems->fstab file-systems)
357 "Return a @file{/etc} entry for an @file{fstab} describing
358@var{file-systems}."
359 `(("fstab" ,(plain-file "fstab"
360 (string-append
361 "\
362# This file was generated from your Guix configuration. Any changes
363# will be lost upon reboot or reconfiguration.\n\n"
364 (string-join (map file-system->fstab-entry
365 file-systems)
366 "\n")
367 "\n")))))
368
369(define fstab-service-type
370 ;; The /etc/fstab service.
371 (service-type (name 'fstab)
372 (extensions
373 (list (service-extension etc-service-type
374 file-systems->fstab)))
375 (compose concatenate)
376 (extend append)
377 (description
378 "Populate the @file{/etc/fstab} based on the given file
379system objects.")))
380
381(define %root-file-system-shepherd-service
382 (shepherd-service
383 (documentation "Take care of the root file system.")
384 (provision '(root-file-system))
385 (start #~(const #t))
386 (stop #~(lambda _
387 ;; Return #f if successfully stopped.
388 (sync)
389
390 (let ((null (%make-void-port "w")))
391 ;; Redirect the default output ports.
392 (set-current-output-port null)
393 (set-current-error-port null)
394
395 ;; Close /dev/console.
396 (for-each close-fdes '(0 1 2))
397
398 ;; At this point, there should be no open files left so the
399 ;; root file system can be re-mounted read-only.
400 (let loop ((n 10))
401 (unless (catch 'system-error
402 (lambda ()
403 (mount #f "/" #f
404 (logior MS_REMOUNT MS_RDONLY)
405 #:update-mtab? #f)
406 #t)
407 (const #f))
408 (unless (zero? n)
409 ;; Yield to the other fibers. That gives logging fibers
410 ;; an opportunity to close log files so the 'mount' call
411 ;; doesn't fail with EBUSY.
412 ((@ (fibers) sleep) 1)
413 (loop (- n 1)))))
414
415 #f)))
416 (respawn? #f)))
417
418(define root-file-system-service-type
419 (shepherd-service-type 'root-file-system
420 (const %root-file-system-shepherd-service)
421 (description "Take care of syncing the root file
422system and of remounting it read-only when the system shuts down.")))
423
424(define (root-file-system-service)
425 "Return a service whose sole purpose is to re-mount read-only the root file
426system upon shutdown (aka. cleanly \"umounting\" root.)
427
428This service must be the root of the service dependency graph so that its
429'stop' action is invoked when shepherd is the only process left."
430 (service root-file-system-service-type #f))
431
432(define (file-system->shepherd-service-name file-system)
433 "Return the symbol that denotes the service mounting and unmounting
434FILE-SYSTEM."
435 (symbol-append 'file-system-
436 (string->symbol (file-system-mount-point file-system))))
437
438(define (mapped-device->shepherd-service-name md)
439 "Return the symbol that denotes the shepherd service of MD, a <mapped-device>."
440 (symbol-append 'device-mapping-
441 (string->symbol (string-join
442 (mapped-device-targets md) "-"))))
443
444(define dependency->shepherd-service-name
445 (match-lambda
446 ((? mapped-device? md)
447 (mapped-device->shepherd-service-name md))
448 ((? file-system? fs)
449 (file-system->shepherd-service-name fs))))
450
451(define (file-system-shepherd-service file-system)
452 "Return the shepherd service for @var{file-system}, or @code{#f} if
453@var{file-system} is not auto-mounted or doesn't have its mount point created
454upon boot."
455 (let ((target (file-system-mount-point file-system))
456 (create? (file-system-create-mount-point? file-system))
457 (mount? (file-system-mount? file-system))
458 (dependencies (file-system-dependencies file-system))
459 (requirements (file-system-shepherd-requirements file-system))
460 (packages (file-system-packages (list file-system))))
461 (and (or mount? create?)
462 (with-imported-modules (source-module-closure
463 '((gnu build file-systems)))
464 (shepherd-service
465 (provision (list (file-system->shepherd-service-name file-system)))
466 (requirement `(root-file-system
467 udev
468 ,@(map dependency->shepherd-service-name dependencies)
469 ,@requirements))
470 (documentation "Check, mount, and unmount the given file system.")
471 (start #~(lambda args
472 #$(if create?
473 #~(mkdir-p #$target)
474 #t)
475
476 #$(if mount?
477 #~(let (($PATH (getenv "PATH")))
478 ;; Make sure fsck.ext2 & co. can be found.
479 (dynamic-wind
480 (lambda ()
481 ;; Don’t display the PATH settings.
482 (with-output-to-port (%make-void-port "w")
483 (lambda ()
484 (set-path-environment-variable "PATH"
485 '("bin" "sbin")
486 '#$packages))))
487 (lambda ()
488 (mount-file-system
489 (spec->file-system
490 '#$(file-system->spec file-system))
491 #:root "/"))
492 (lambda ()
493 (setenv "PATH" $PATH))))
494 #t)
495 #t))
496 (stop #~(lambda args
497 ;; Normally there are no processes left at this point, so
498 ;; TARGET can be safely unmounted.
499
500 ;; Make sure PID 1 doesn't keep TARGET busy.
501 (chdir "/")
502
503 #$(if (file-system-mount-may-fail? file-system)
504 #~(catch 'system-error
505 (lambda () (umount #$target))
506 (const #f))
507 #~(umount #$target))
508 #f))
509
510 ;; We need additional modules.
511 (modules `(((gnu build file-systems)
512 #:select (mount-file-system))
513 (gnu system file-systems)
514 ,@%default-modules)))))))
515
516(define (file-system-shepherd-services file-systems)
517 "Return the list of Shepherd services for FILE-SYSTEMS."
518 (let* ((file-systems (filter (lambda (x)
519 (or (file-system-mount? x)
520 (file-system-create-mount-point? x)))
521 file-systems)))
522
523 (define sink
524 (shepherd-service
525 (provision '(file-systems))
526 (requirement (cons* 'root-file-system
527 (map file-system->shepherd-service-name
528 ;; Do not require file systems with Shepherd
529 ;; requirements to provision
530 ;; 'file-systems. Many Shepherd services
531 ;; require 'file-systems, so we would likely
532 ;; deadlock.
533 (filter (lambda (file-system)
534 (null? (file-system-shepherd-requirements file-system)))
535 file-systems))))
536 (documentation "Target for all the initially-mounted file systems")
537 (start #~(const #t))
538 (stop #~(const #f))))
539
540 (define known-mount-points
541 (map file-system-mount-point file-systems))
542
543 (define user-unmount
544 (shepherd-service
545 (documentation "Unmount manually-mounted file systems.")
546 (provision '(user-file-systems))
547 ;; Unmount manually-mounted file systems before shepherd-managed
548 ;; ones, e.g /run/user/$UID and /run/user.
549 (requirement '(file-systems))
550 (start #~(const #t))
551 (stop #~(lambda args
552 (define (known? mount-point)
553 (member mount-point
554 ;; Count file systems mounted by the initrd to as
555 ;; "known" and not user-mounted file systems.
556 (cons* "/" "/dev" "/proc" "/sys"
557 '#$known-mount-points)))
558
559 ;; Make sure we don't keep the user's mount points busy.
560 (chdir "/")
561
562 (for-each (lambda (mount-point)
563 (format #t "unmounting '~a'...~%" mount-point)
564 (catch 'system-error
565 (lambda ()
566 (umount mount-point))
567 (lambda args
568 (let ((errno (system-error-errno args)))
569 (format #t "failed to unmount '~a': ~a~%"
570 mount-point (strerror errno))))))
571 ;; Unmount mount points in reverse order of mounting.
572 (reverse (filter (negate known?) (mount-points))))
573 #f))))
574
575 (cons* sink user-unmount
576 (map file-system-shepherd-service file-systems))))
577
578(define (file-system-fstab-entries file-systems)
579 "Return the subset of @var{file-systems} that should have an entry in
580@file{/etc/fstab}."
581 ;; /etc/fstab is about telling fsck(8), mount(8), and umount(8) about
582 ;; relevant file systems they'll have to deal with. That excludes "pseudo"
583 ;; file systems.
584 ;;
585 ;; In particular, things like GIO (part of GLib) use it to determine the set
586 ;; of mounts, which is then used by graphical file managers and desktop
587 ;; environments to display "volume" icons. Thus, we really need to exclude
588 ;; those pseudo file systems from the list.
589 (remove (lambda (file-system)
590 (or (member (file-system-type file-system)
591 %pseudo-file-system-types)
592 (memq 'bind-mount (file-system-flags file-system))))
593 file-systems))
594
595(define (file-system-type->utilities type)
596 "Return the package providing the utilities for file system TYPE, #f
597otherwise."
598 (assoc-ref
599 `(("bcachefs" . ,bcachefs-tools)
600 ("btrfs" . ,btrfs-progs)
601 ("exfat" . ,exfat-utils)
602 ("ext2" . ,e2fsprogs)
603 ("ext3" . ,e2fsprogs)
604 ("ext4" . ,e2fsprogs)
605 ("fat" . ,dosfstools)
606 ("f2fs" . ,f2fs-tools)
607 ("jfs" . ,jfsutils)
608 ("vfat" . ,dosfstools)
609 ("xfs" . ,xfsprogs)
610 ("zfs" . ,zfs))
611 type))
612
613(define (file-system-utilities file-systems)
614 "Return a list of packages containing file system utilities for
615FILE-SYSTEMS."
616 (filter-map (lambda (file-system)
617 (file-system-type->utilities (file-system-type file-system)))
618 file-systems))
619
620(define file-system-service-type
621 (service-type (name 'file-systems)
622 (extensions
623 (list (service-extension shepherd-root-service-type
624 file-system-shepherd-services)
625 (service-extension fstab-service-type
626 file-system-fstab-entries)
627 (service-extension profile-service-type
628 file-system-utilities)
629
630 ;; Have 'user-processes' depend on 'file-systems'.
631 (service-extension user-processes-service-type
632 (const '(file-systems
633 user-file-systems)))))
634 (compose concatenate)
635 (extend append)
636 (description
637 "Provide Shepherd services to mount and unmount the given
638file systems, as well as corresponding @file{/etc/fstab} entries.")))
639
640
641
642;;;
643;;; Preserve entropy to seed /dev/urandom on boot.
644;;;
645
646(define %random-seed-file
647 "/var/lib/random-seed")
648
649(define (urandom-seed-shepherd-service _)
650 "Return a shepherd service for the /dev/urandom seed."
651 (list (shepherd-service
652 (documentation "Preserve entropy across reboots for /dev/urandom.")
653 (provision '(urandom-seed))
654
655 ;; Depend on udev so that /dev/hwrng is available.
656 (requirement '(file-systems udev))
657
658 (start #~(lambda _
659 ;; On boot, write random seed into /dev/urandom.
660 (when (file-exists? #$%random-seed-file)
661 (call-with-input-file #$%random-seed-file
662 (lambda (seed)
663 (call-with-output-file "/dev/urandom"
664 (lambda (urandom)
665 (dump-port seed urandom)
666
667 ;; Writing SEED to URANDOM isn't enough: we must
668 ;; also tell the kernel to account for these
669 ;; extra bits of entropy.
670 (let ((bits (* 8 (stat:size (stat seed)))))
671 (add-to-entropy-count urandom bits)))))))
672
673 ;; Try writing from /dev/hwrng into /dev/urandom.
674 ;; It seems that the file /dev/hwrng always exists, even
675 ;; when there is no hardware random number generator
676 ;; available. So, we handle a failed read or any other error
677 ;; reported by the operating system.
678 (let ((buf (catch 'system-error
679 (lambda ()
680 (call-with-input-file "/dev/hwrng"
681 (lambda (hwrng)
682 (get-bytevector-n hwrng 512))))
683 ;; Silence is golden...
684 (const #f))))
685 (when buf
686 (call-with-output-file "/dev/urandom"
687 (lambda (urandom)
688 (put-bytevector urandom buf)
689 (let ((bits (* 8 (bytevector-length buf))))
690 (add-to-entropy-count urandom bits))))))
691
692 ;; Immediately refresh the seed in case the system doesn't
693 ;; shut down cleanly.
694 (call-with-input-file "/dev/urandom"
695 (lambda (urandom)
696 (let ((previous-umask (umask #o077))
697 (buf (make-bytevector 512)))
698 (mkdir-p (dirname #$%random-seed-file))
699 (get-bytevector-n! urandom buf 0 512)
700 (call-with-output-file #$%random-seed-file
701 (lambda (seed)
702 (put-bytevector seed buf)))
703 (umask previous-umask))))
704 #t))
705 (stop #~(lambda _
706 ;; During shutdown, write from /dev/urandom into random seed.
707 (let ((buf (make-bytevector 512)))
708 (call-with-input-file "/dev/urandom"
709 (lambda (urandom)
710 (let ((previous-umask (umask #o077)))
711 (get-bytevector-n! urandom buf 0 512)
712 (mkdir-p (dirname #$%random-seed-file))
713 (call-with-output-file #$%random-seed-file
714 (lambda (seed)
715 (put-bytevector seed buf)))
716 (umask previous-umask))
717 )))
718 #f))
719 (modules `((rnrs bytevectors)
720 (rnrs io ports)
721 ,@%default-modules)))))
722
723(define urandom-seed-service-type
724 (service-type (name 'urandom-seed)
725 (extensions
726 (list (service-extension shepherd-root-service-type
727 urandom-seed-shepherd-service)
728
729 ;; Have 'user-processes' depend on 'urandom-seed'.
730 ;; This ensures that user processes and daemons don't
731 ;; start until we have seeded the PRNG.
732 (service-extension user-processes-service-type
733 (const '(urandom-seed)))))
734 (default-value #f)
735 (description
736 "Seed the @file{/dev/urandom} pseudo-random number
737generator (RNG) with the value recorded when the system was last shut
738down.")))
739
740
741;;;
742;;; Add hardware random number generator to entropy pool.
743;;;
744
745(define-record-type* <rngd-configuration>
746 rngd-configuration make-rngd-configuration
747 rngd-configuration?
748 (rng-tools rngd-configuration-rng-tools ;file-like
749 (default rng-tools))
750 (device rngd-configuration-device ;string
751 (default "/dev/hwrng")))
752
753(define rngd-service-type
754 (shepherd-service-type
755 'rngd
756 (lambda (config)
757 (define rng-tools (rngd-configuration-rng-tools config))
758 (define device (rngd-configuration-device config))
759
760 (define rngd-command
761 (list (file-append rng-tools "/sbin/rngd")
762 "-f" "-r" device))
763
764 (shepherd-service
765 (documentation "Add TRNG to entropy pool.")
766 (requirement '(user-processes udev))
767 (provision '(trng))
768 (start #~(make-forkexec-constructor '#$rngd-command))
769 (stop #~(make-kill-destructor))))
770 (rngd-configuration)
771 (description "Run the @command{rngd} random number generation daemon to
772supply entropy to the kernel's pool.")))
773
774(define-deprecated (rngd-service #:key (rng-tools rng-tools)
775 (device "/dev/hwrng"))
776 rngd-service-type
777 "Return a service that runs the @command{rngd} program from @var{rng-tools}
778to add @var{device} to the kernel's entropy pool. The service will fail if
779@var{device} does not exist."
780 (service rngd-service-type
781 (rngd-configuration
782 (rng-tools rng-tools)
783 (device device))))
784
785;;;
786;;; /etc/hosts
787;;;
788
789(eval-when (expand load eval)
790 (define (valid-name? name)
791 "Return true if @var{name} is likely to be a valid host name."
792 (false-if-exception (not (string-any char-set:whitespace name)))))
793
794(define-compile-time-procedure (assert-valid-name (name valid-name?))
795 "Ensure @var{name} is likely to be a valid host name."
796 ;; TODO: RFC compliant implementation.
797 (unless (valid-name? name)
798 (raise
799 (make-compound-condition
800 (formatted-message (G_ "host name '~a' contains invalid characters")
801 name)
802 (condition (&error-location
803 (location
804 (source-properties->location procedure-call-location)))))))
805 name)
806
807(define-record-type* <host> %host
808 ;; XXX: Using the record type constructor becomes tiresome when
809 ;; there's multiple records to make.
810 make-host host?
811 (address host-address)
812 (canonical-name host-canonical-name
813 (sanitize assert-valid-name))
814 (aliases host-aliases
815 (default '())
816 (sanitize (cut map assert-valid-name <>))))
817
818(define* (host address canonical-name #:optional (aliases '()))
819 "Return a new record for the host at @var{address} with the given
820@var{canonical-name} and possibly @var{aliases}.
821
822@var{address} must be a string denoting a valid IPv4 or IPv6 address, and
823@var{canonical-name} and the strings listed in @var{aliases} must be valid
824host names."
825 (%host
826 (address address)
827 (canonical-name canonical-name)
828 (aliases aliases)))
829
830(define hosts-service-type
831 ;; Extend etc-service-type with a entry for @file{/etc/hosts}.
832 (let* ((serialize-host-record
833 (lambda (record)
834 (match-record record <host> (address canonical-name aliases)
835 (format #f "~a~/~a~{~^~/~a~}~%" address canonical-name aliases))))
836 (host-etc-service
837 (lambda (lst)
838 `(("hosts" ,(plain-file "hosts"
839 (format #f "~{~a~}"
840 (map serialize-host-record
841 lst))))))))
842 (service-type
843 (name 'etc-hosts)
844 (extensions
845 (list
846 (service-extension etc-service-type
847 host-etc-service)))
848 (compose concatenate)
849 (extend append)
850 (description "Populate the @file{/etc/hosts} file."))))
851
852
853;;;
854;;; Console & co.
855;;;
856
857(define host-name-service-type
858 (shepherd-service-type
859 'host-name
860 (lambda (name)
861 (shepherd-service
862 (documentation "Initialize the machine's host name.")
863 (provision '(host-name))
864 (start #~(lambda _
865 (sethostname #$name)
866 #$name))
867 (one-shot? #t)))
868 (description "Initialize the machine's host name.")))
869
870(define-deprecated (host-name-service name)
871 host-name-service-type
872 "Return a service that sets the host name to @var{name}."
873 (service host-name-service-type name))
874
875(define virtual-terminal-service-type
876 ;; Ensure that virtual terminals run in UTF-8 mode. This is the case by
877 ;; default with recent Linux kernels, but this service allows us to ensure
878 ;; this. This service must start before any 'term-' service so that newly
879 ;; created terminals inherit this property. See
880 ;; <https://bugs.gnu.org/30505> for a discussion.
881 (shepherd-service-type
882 'virtual-terminal
883 (lambda (utf8?)
884 (let ((knob "/sys/module/vt/parameters/default_utf8"))
885 (shepherd-service
886 (documentation "Set virtual terminals in UTF-8 module.")
887 (provision '(virtual-terminal))
888 (requirement '(root-file-system))
889 (start #~(lambda _
890 ;; In containers /sys is read-only so don't insist on
891 ;; writing to this file.
892 (unless (= 1 (call-with-input-file #$knob read))
893 (call-with-output-file #$knob
894 (lambda (port)
895 (display 1 port))))
896 #t))
897 (stop #~(const #f)))))
898 #t ;default to UTF-8
899 (description "Ensure the Linux virtual terminals run in UTF-8 mode.")))
900
901(define %default-console-font
902 ;; Note: the 'font-gnu-unifont' package cannot be cross-compiled (yet), but
903 ;; its "psf" output is the same whether it's built natively or not, hence
904 ;; 'ungexp-native'.
905 #~(string-append #+font-gnu-unifont:psf
906 "/share/consolefonts/Unifont-APL8x16.psf.gz"))
907
908(define (console-font-shepherd-services tty+font)
909 "Return a list of Shepherd services for each pair in TTY+FONT."
910 (map (match-lambda
911 ((tty . font)
912 (let ((device (string-append "/dev/" tty)))
913 (shepherd-service
914 (documentation "Load a Unicode console font.")
915 (provision (list (symbol-append 'console-font-
916 (string->symbol tty))))
917
918 ;; Start after mingetty has been started on TTY, otherwise the settings
919 ;; are ignored.
920 (requirement (list (symbol-append 'term-
921 (string->symbol tty))))
922
923 (start #~(lambda _
924 ;; It could be that mingetty is not fully ready yet,
925 ;; which we check by calling 'ttyname'.
926 (let loop ((i 10))
927 (unless (or (zero? i)
928 (call-with-input-file #$device
929 (lambda (port)
930 (false-if-exception (ttyname port)))))
931 (usleep 500)
932 (loop (- i 1))))
933
934 ;; Assume the VT is already in UTF-8 mode, thanks to
935 ;; the 'virtual-terminal' service.
936 ;;
937 ;; 'setfont' returns EX_OSERR (71) when an
938 ;; KDFONTOP ioctl fails, for example. Like
939 ;; systemd's vconsole support, let's not treat
940 ;; this as an error.
941 (case (status:exit-val
942 (system* #$(file-append kbd "/bin/setfont")
943 "-C" #$device #$font))
944 ((0 71) #t)
945 (else #f))))
946 (stop #~(const #f))
947 (respawn? #f)))))
948 tty+font))
949
950(define console-font-service-type
951 (service-type (name 'console-fonts)
952 (extensions
953 (list (service-extension shepherd-root-service-type
954 console-font-shepherd-services)))
955 (compose concatenate)
956 (extend append)
957 (description
958 "Install the given fonts on the specified ttys (fonts are per
959virtual console on GNU/Linux). The value of this service is a list of
960tty/font pairs. The font can be the name of a font provided by the @code{kbd}
961package or any valid argument to @command{setfont}, as in this example:
962
963@example
964`((\"tty1\" . \"LatGrkCyr-8x16\")
965 (\"tty2\" . ,(file-append
966 font-tamzen
967 \"/share/kbd/consolefonts/TamzenForPowerline10x20.psf\"))
968 (\"tty3\" . ,(file-append
969 font-terminus
970 \"/share/consolefonts/ter-132n\"))) ; for HDPI
971@end example\n")))
972
973(define %default-motd
974 (plain-file "motd" "This is the GNU operating system, welcome!\n\n"))
975
976(define-record-type* <login-configuration>
977 login-configuration make-login-configuration
978 login-configuration?
979 (motd login-configuration-motd ;file-like
980 (default %default-motd))
981 ;; Allow empty passwords by default so that first-time users can log in when
982 ;; the 'root' account has just been created.
983 (allow-empty-passwords? login-configuration-allow-empty-passwords?
984 (default #t))) ;Boolean
985
986(define (login-pam-service config)
987 "Return the list of PAM service needed for CONF."
988 ;; Let 'login' be known to PAM.
989 (list (unix-pam-service "login"
990 #:login-uid? #t
991 #:allow-empty-passwords?
992 (login-configuration-allow-empty-passwords? config)
993 #:motd
994 (login-configuration-motd config))))
995
996(define login-service-type
997 (service-type (name 'login)
998 (extensions (list (service-extension pam-root-service-type
999 login-pam-service)))
1000 (default-value (login-configuration))
1001 (description
1002 "Provide a console log-in service as specified by its
1003configuration value, a @code{login-configuration} object.")))
1004
1005(define-deprecated (login-service #:optional (config (login-configuration)))
1006 login-service-type
1007 "Return a service configure login according to @var{config}, which specifies
1008the message of the day, among other things."
1009 (service login-service-type config))
1010
1011(define-record-type* <agetty-configuration>
1012 agetty-configuration make-agetty-configuration
1013 agetty-configuration?
1014 (agetty agetty-configuration-agetty ;file-like
1015 (default util-linux))
1016 (tty agetty-configuration-tty) ;string | #f
1017 (term agetty-term ;string | #f
1018 (default #f))
1019 (baud-rate agetty-baud-rate ;string | #f
1020 (default #f))
1021 (auto-login agetty-auto-login ;list of strings | #f
1022 (default #f))
1023 (login-program agetty-login-program ;gexp
1024 (default (file-append shadow "/bin/login")))
1025 (login-pause? agetty-login-pause? ;Boolean
1026 (default #f))
1027 (eight-bits? agetty-eight-bits? ;Boolean
1028 (default #f))
1029 (no-reset? agetty-no-reset? ;Boolean
1030 (default #f))
1031 (remote? agetty-remote? ;Boolean
1032 (default #f))
1033 (flow-control? agetty-flow-control? ;Boolean
1034 (default #f))
1035 (host agetty-host ;string | #f
1036 (default #f))
1037 (no-issue? agetty-no-issue? ;Boolean
1038 (default #f))
1039 (init-string agetty-init-string ;string | #f
1040 (default #f))
1041 (no-clear? agetty-no-clear? ;Boolean
1042 (default #f))
1043 (local-line agetty-local-line ;always | never | auto
1044 (default #f))
1045 (extract-baud? agetty-extract-baud? ;Boolean
1046 (default #f))
1047 (skip-login? agetty-skip-login? ;Boolean
1048 (default #f))
1049 (no-newline? agetty-no-newline? ;Boolean
1050 (default #f))
1051 (login-options agetty-login-options ;string | #f
1052 (default #f))
1053 (chroot agetty-chroot ;string | #f
1054 (default #f))
1055 (hangup? agetty-hangup? ;Boolean
1056 (default #f))
1057 (keep-baud? agetty-keep-baud? ;Boolean
1058 (default #f))
1059 (timeout agetty-timeout ;integer | #f
1060 (default #f))
1061 (detect-case? agetty-detect-case? ;Boolean
1062 (default #f))
1063 (wait-cr? agetty-wait-cr? ;Boolean
1064 (default #f))
1065 (no-hints? agetty-no-hints? ;Boolean
1066 (default #f))
1067 (no-hostname? agetty-no-hostname? ;Boolean
1068 (default #f))
1069 (long-hostname? agetty-long-hostname? ;Boolean
1070 (default #f))
1071 (erase-characters agetty-erase-characters ;string | #f
1072 (default #f))
1073 (kill-characters agetty-kill-characters ;string | #f
1074 (default #f))
1075 (chdir agetty-chdir ;string | #f
1076 (default #f))
1077 (delay agetty-delay ;integer | #f
1078 (default #f))
1079 (nice agetty-nice ;integer | #f
1080 (default #f))
1081 ;; "Escape hatch" for passing arbitrary command-line arguments.
1082 (extra-options agetty-extra-options ;list of strings
1083 (default '()))
1084 (shepherd-requirement agetty-shepherd-requirement ;list of SHEPHERD requirements
1085 (default '()))
1086;;; XXX Unimplemented for now!
1087;;; (issue-file agetty-issue-file ;file-like
1088;;; (default #f))
1089 )
1090
1091(define (default-serial-port)
1092 "Return a gexp that determines a reasonable default serial port
1093to use as the tty. This is primarily useful for headless systems."
1094 (with-imported-modules (source-module-closure
1095 '((gnu build linux-boot))) ;for 'find-long-options'
1096 #~(begin
1097 (use-modules (gnu build linux-boot)
1098 (srfi srfi-1))
1099
1100 ;; console=device,options
1101 ;; device: can be tty0, ttyS0, lp0, ttyUSB0 (serial).
1102 ;; options: BBBBPNF. P n|o|e, N number of bits,
1103 ;; F flow control (r RTS)
1104 (let* ((not-comma (char-set-complement (char-set #\,)))
1105 (command (linux-command-line))
1106 (agetty-specs (find-long-options "agetty.tty" command))
1107 (console-specs (filter (lambda (spec)
1108 (and (string-prefix? "tty" spec)
1109 (not (or
1110 (string-prefix? "tty0" spec)
1111 (string-prefix? "tty1" spec)
1112 (string-prefix? "tty2" spec)
1113 (string-prefix? "tty3" spec)
1114 (string-prefix? "tty4" spec)
1115 (string-prefix? "tty5" spec)
1116 (string-prefix? "tty6" spec)
1117 (string-prefix? "tty7" spec)
1118 (string-prefix? "tty8" spec)
1119 (string-prefix? "tty9" spec)))))
1120 (find-long-options "console" command)))
1121 (specs (append agetty-specs console-specs)))
1122 (match specs
1123 ;; Fallback to a physical console registered in /proc/consoles.
1124 (() (let* ((consoles (read-linux-consoles))
1125 (chosen-console
1126 ;; Prioritize preferred, if none, choose any enabled.
1127 (or (find (lambda (c)
1128 (and (not (linux-console-virtual? c))
1129 (linux-console-preferred? c)))
1130 consoles)
1131 (find (lambda (c)
1132 (and (not (linux-console-virtual? c))
1133 (linux-console-enabled? c)))
1134 consoles))))
1135 (and chosen-console
1136 (linux-console-device chosen-console))))
1137 ((spec _ ...)
1138 ;; Extract device name from first spec.
1139 (match (string-tokenize spec not-comma)
1140 ((device-name _ ...)
1141 device-name))))))))
1142
1143(define (agetty-shepherd-service config)
1144 (match-record config <agetty-configuration>
1145 (agetty tty term baud-rate auto-login
1146 login-program login-pause? eight-bits? no-reset? remote? flow-control?
1147 host no-issue? init-string no-clear? local-line extract-baud?
1148 skip-login? no-newline? login-options chroot hangup? keep-baud? timeout
1149 detect-case? wait-cr? no-hints? no-hostname? long-hostname?
1150 erase-characters kill-characters chdir delay nice extra-options
1151 shepherd-requirement)
1152 (list
1153 (shepherd-service
1154 (documentation "Run agetty on a tty.")
1155 (provision (list (symbol-append 'term- (string->symbol (or tty "console")))))
1156
1157 ;; Since the login prompt shows the host name, wait for the 'host-name'
1158 ;; service to be done. Also wait for udev essentially so that the tty
1159 ;; text is not lost in the middle of kernel messages (see also
1160 ;; mingetty-shepherd-service).
1161 (requirement (cons* 'user-processes 'host-name 'udev
1162 shepherd-requirement))
1163
1164 (modules '((ice-9 match) (gnu build linux-boot)
1165 (srfi srfi-1)))
1166 (start
1167 (with-imported-modules (source-module-closure
1168 '((gnu build linux-boot)))
1169 #~(lambda args
1170 (let ((defaulted-tty #$(or tty (default-serial-port))))
1171 (apply
1172 (if defaulted-tty
1173 (make-forkexec-constructor
1174 (list #$(file-append util-linux "/sbin/agetty")
1175 #$@extra-options
1176 #$@(if eight-bits?
1177 #~("--8bits")
1178 #~())
1179 #$@(if no-reset?
1180 #~("--noreset")
1181 #~())
1182 #$@(if remote?
1183 #~("--remote")
1184 #~())
1185 #$@(if flow-control?
1186 #~("--flow-control")
1187 #~())
1188 #$@(if host
1189 #~("--host" #$host)
1190 #~())
1191 #$@(if no-issue?
1192 #~("--noissue")
1193 #~())
1194 #$@(if init-string
1195 #~("--init-string" #$init-string)
1196 #~())
1197 #$@(if no-clear?
1198 #~("--noclear")
1199 #~())
1200;;; FIXME This doesn't work as expected. According to agetty(8), if this option
1201;;; is not passed, then the default is 'auto'. However, in my tests, when that
1202;;; option is selected, agetty never presents the login prompt, and the
1203;;; term-ttyS0 service respawns every few seconds.
1204 #$@(if local-line
1205 #~(#$(match local-line
1206 ('auto "--local-line=auto")
1207 ('always "--local-line=always")
1208 ('never "-local-line=never")))
1209 #~())
1210 #$@(if tty
1211 #~()
1212 #~("--keep-baud"))
1213 #$@(if extract-baud?
1214 #~("--extract-baud")
1215 #~())
1216 #$@(if skip-login?
1217 #~("--skip-login")
1218 #~())
1219 #$@(if no-newline?
1220 #~("--nonewline")
1221 #~())
1222 #$@(if login-options
1223 #~("--login-options" #$login-options)
1224 #~())
1225 #$@(if chroot
1226 #~("--chroot" #$chroot)
1227 #~())
1228 #$@(if hangup?
1229 #~("--hangup")
1230 #~())
1231 #$@(if keep-baud?
1232 #~("--keep-baud")
1233 #~())
1234 #$@(if timeout
1235 #~("--timeout" #$(number->string timeout))
1236 #~())
1237 #$@(if detect-case?
1238 #~("--detect-case")
1239 #~())
1240 #$@(if wait-cr?
1241 #~("--wait-cr")
1242 #~())
1243 #$@(if no-hints?
1244 #~("--nohints?")
1245 #~())
1246 #$@(if no-hostname?
1247 #~("--nohostname")
1248 #~())
1249 #$@(if long-hostname?
1250 #~("--long-hostname")
1251 #~())
1252 #$@(if erase-characters
1253 #~("--erase-chars" #$erase-characters)
1254 #~())
1255 #$@(if kill-characters
1256 #~("--kill-chars" #$kill-characters)
1257 #~())
1258 #$@(if chdir
1259 #~("--chdir" #$chdir)
1260 #~())
1261 #$@(if delay
1262 #~("--delay" #$(number->string delay))
1263 #~())
1264 #$@(if nice
1265 #~("--nice" #$(number->string nice))
1266 #~())
1267 #$@(if auto-login
1268 (list "--autologin" auto-login)
1269 '())
1270 #$@(if login-program
1271 #~("--login-program" #$login-program)
1272 #~())
1273 #$@(if login-pause?
1274 #~("--login-pause")
1275 #~())
1276 defaulted-tty
1277 #$@(if baud-rate
1278 #~(#$baud-rate)
1279 #~())
1280 #$@(if term
1281 #~(#$term)
1282 #~())))
1283 #$(if tty
1284 #~(const #f) ;always fail to start
1285 #~(lambda _ ;succeed, but don't do anything
1286 (format #t "~a: \
1287no serial port console requested; doing nothing~%"
1288 '#$(car provision))
1289 'idle)))
1290 args)))))
1291 (stop #~(let ((stop (make-kill-destructor)))
1292 (lambda (running)
1293 (if (eq? 'idle running)
1294 #f
1295 (stop running)))))))))
1296
1297(define agetty-service-type
1298 (service-type (name 'agetty)
1299 (extensions (list (service-extension shepherd-root-service-type
1300 agetty-shepherd-service)))
1301 (description
1302 "Provide console login using the @command{agetty}
1303program.")))
1304
1305(define-deprecated (agetty-service config)
1306 agetty-service-type
1307 "Return a service to run agetty according to @var{config}, which specifies
1308the tty to run, among other things."
1309 (service agetty-service-type config))
1310
1311(define-record-type* <mingetty-configuration>
1312 mingetty-configuration make-mingetty-configuration
1313 mingetty-configuration?
1314 (mingetty mingetty-configuration-mingetty ;file-like
1315 (default mingetty))
1316 (tty mingetty-configuration-tty) ;string
1317 (auto-login mingetty-configuration-auto-login ;string | #f
1318 (default #f))
1319 (login-program mingetty-configuration-login-program ;gexp
1320 (default #f))
1321 (login-pause? mingetty-configuration-login-pause? ;boolean
1322 (default #f))
1323 (clear-on-logout? mingetty-configuration-clear-on-logout? ;boolean
1324 (default #t))
1325 (delay mingetty-configuration-delay ;integer | #f
1326 (default #f))
1327 (print-issue mingetty-configuration-print-issue ;boolean | Symbol
1328 (default #t))
1329 (print-hostname mingetty-configuration-print-hostname ;boolean | Symbol
1330 (default #t))
1331 (nice mingetty-configuration-nice ;integer | #f
1332 (default #f))
1333 (working-directory mingetty-configuration-working-directory ;string | #f
1334 (default #f))
1335 (root-directory mingetty-configuration-root-directory ;string | #f
1336 (default #f))
1337 (shepherd-requirement mingetty-configuration-shepherd-requirement
1338 ;; Since the login prompt shows the host name, wait
1339 ;; for the 'host-name' service to be done. Also wait
1340 ;; for udev essentially so that the tty text is not
1341 ;; lost in the middle of kernel messages (XXX).
1342 (default '(user-processes host-name udev
1343 virtual-terminal))))
1344
1345(define (mingetty-shepherd-service config)
1346 (match-record config <mingetty-configuration>
1347 ( mingetty tty auto-login login-program
1348 login-pause? clear-on-logout? delay
1349 print-issue print-hostname nice
1350 working-directory root-directory shepherd-requirement)
1351 (list
1352 (shepherd-service
1353 (documentation "Run mingetty on an tty.")
1354 (provision (list (symbol-append 'term- (string->symbol tty))))
1355
1356 (requirement shepherd-requirement)
1357
1358 (start #~(make-forkexec-constructor
1359 (list #$(file-append mingetty "/sbin/mingetty")
1360
1361 ;; Avoiding 'vhangup' allows us to avoid 'setfont'
1362 ;; errors down the path where various ioctls get
1363 ;; EIO--see 'hung_up_tty_ioctl' in driver/tty/tty_io.c
1364 ;; in Linux.
1365 "--nohangup" #$tty
1366
1367 #$@(if clear-on-logout?
1368 #~()
1369 #~("--noclear"))
1370 #$@(if auto-login
1371 #~("--autologin" #$auto-login)
1372 #~())
1373 #$@(if login-program
1374 #~("--loginprog" #$login-program)
1375 #~())
1376 #$@(if login-pause?
1377 #~("--loginpause")
1378 #~())
1379 #$@(if delay
1380 #~("--delay" #$(number->string delay))
1381 #~())
1382 #$@(match print-issue
1383 (#t
1384 #~())
1385 ('no-nl
1386 #~("--nonewline"))
1387 (#f
1388 #~("--noissue")))
1389 #$@(match print-hostname
1390 (#t
1391 #~())
1392 ('long
1393 #~("--long-hostname"))
1394 (#f
1395 #~("--nohostname")))
1396 #$@(if nice
1397 #~("--nice" #$(number->string nice))
1398 #~())
1399 #$@(if working-directory
1400 #~("--chdir" #$working-directory)
1401 #~())
1402 #$@(if root-directory
1403 #~("--chroot" #$root-directory)
1404 #~()))))
1405 (stop #~(make-kill-destructor))))))
1406
1407(define mingetty-service-type
1408 (service-type (name 'mingetty)
1409 (extensions (list (service-extension shepherd-root-service-type
1410 mingetty-shepherd-service)))
1411 (description
1412 "Provide console login using the @command{mingetty}
1413program.")))
1414
1415(define-deprecated (mingetty-service config)
1416 mingetty-service-type
1417 "Return a service to run mingetty according to @var{config}, which specifies
1418the tty to run, among other things."
1419 (service mingetty-service-type config))
1420
1421(define-record-type* <nscd-configuration> nscd-configuration
1422 make-nscd-configuration
1423 nscd-configuration?
1424 (log-file nscd-configuration-log-file ;string
1425 (default #f))
1426 (debug-level nscd-debug-level ;integer
1427 (default 0))
1428 ;; TODO: See nscd.conf in glibc for other options to add.
1429 (caches nscd-configuration-caches ;list of <nscd-cache>
1430 (default %nscd-default-caches))
1431 (name-services nscd-configuration-name-services ;list of file-like
1432 (default '()))
1433 (glibc nscd-configuration-glibc ;file-like
1434 (default (let-system (system target)
1435 ;; Unless we're cross-compiling, arrange to use nscd
1436 ;; from 'glibc-final' instead of pulling in a second
1437 ;; glibc copy.
1438 (if target
1439 (cross-libc target)
1440 (canonical-package glibc))))))
1441
1442(define-record-type* <nscd-cache> nscd-cache make-nscd-cache
1443 nscd-cache?
1444 (database nscd-cache-database) ;symbol
1445 (positive-time-to-live nscd-cache-positive-time-to-live) ;integer
1446 (negative-time-to-live nscd-cache-negative-time-to-live
1447 (default 20)) ;integer
1448 (suggested-size nscd-cache-suggested-size ;integer ("default module
1449 ;of hash table")
1450 (default 211))
1451 (check-files? nscd-cache-check-files? ;Boolean
1452 (default #t))
1453 (persistent? nscd-cache-persistent? ;Boolean
1454 (default #t))
1455 (shared? nscd-cache-shared? ;Boolean
1456 (default #t))
1457 (max-database-size nscd-cache-max-database-size ;integer
1458 (default (* 32 (expt 2 20))))
1459 (auto-propagate? nscd-cache-auto-propagate? ;Boolean
1460 (default #t)))
1461
1462(define %nscd-default-caches
1463 ;; Caches that we want to enable by default. Note that when providing an
1464 ;; empty nscd.conf, all caches are disabled.
1465 (list (nscd-cache (database 'hosts)
1466
1467 ;; Aggressively cache the host name cache to improve
1468 ;; privacy and resilience.
1469 (positive-time-to-live (* 3600 12))
1470 (negative-time-to-live 20)
1471 (persistent? #t))
1472
1473 (nscd-cache (database 'services)
1474
1475 ;; Services are unlikely to change, so we can be even more
1476 ;; aggressive.
1477 (positive-time-to-live (* 3600 24))
1478 (negative-time-to-live 3600)
1479 (check-files? #t) ;check /etc/services changes
1480 (persistent? #t))
1481
1482 ;; Enable minimal caching of the user databases, not so much for
1483 ;; caching but rather to allow that uses of NSS plugins like LDAP
1484 ;; don't lead user processes to dlopen them (which is likely to fail
1485 ;; due to them not being found in $LD_LIBRARY_PATH).
1486 (nscd-cache (database 'passwd)
1487 (positive-time-to-live 600)
1488 (negative-time-to-live 20)
1489 (check-files? #t) ;check /etc/passwd changes
1490 (persistent? #f))
1491 (nscd-cache (database 'group)
1492 (positive-time-to-live 600)
1493 (negative-time-to-live 20)
1494 (check-files? #t) ;check /etc/group changes
1495 (persistent? #f))))
1496
1497(define-deprecated %nscd-default-configuration
1498 #f
1499 ;; Default nscd configuration.
1500 (nscd-configuration))
1501
1502(define (nscd.conf-file config)
1503 "Return the @file{nscd.conf} configuration file for @var{config}, an
1504@code{<nscd-configuration>} object."
1505 (define (cache->config cache)
1506 (match-record cache <nscd-cache>
1507 (database positive-time-to-live negative-time-to-live
1508 suggested-size check-files?
1509 persistent? shared? max-database-size auto-propagate?)
1510 (let ((database (symbol->string database)))
1511 (string-append "\nenable-cache\t" database "\tyes\n"
1512
1513 "positive-time-to-live\t" database "\t"
1514 (number->string positive-time-to-live) "\n"
1515 "negative-time-to-live\t" database "\t"
1516 (number->string negative-time-to-live) "\n"
1517 "suggested-size\t" database "\t"
1518 (number->string suggested-size) "\n"
1519 "check-files\t" database "\t"
1520 (if check-files? "yes\n" "no\n")
1521 "persistent\t" database "\t"
1522 (if persistent? "yes\n" "no\n")
1523 "shared\t" database "\t"
1524 (if shared? "yes\n" "no\n")
1525 "max-db-size\t" database "\t"
1526 (number->string max-database-size) "\n"
1527 "auto-propagate\t" database "\t"
1528 (if auto-propagate? "yes\n" "no\n")))))
1529
1530 (match-record config <nscd-configuration>
1531 (log-file debug-level caches)
1532 (plain-file "nscd.conf"
1533 (string-append "\
1534# Configuration of libc's name service cache daemon (nscd).\n\n"
1535 (if log-file
1536 (string-append "logfile\t" log-file)
1537 "")
1538 "\n"
1539 (if debug-level
1540 (string-append "debug-level\t"
1541 (number->string debug-level))
1542 "")
1543 "\n"
1544 (string-concatenate
1545 (map cache->config caches))))))
1546
1547(define (nscd-action-procedure nscd config option)
1548 ;; XXX: This is duplicated from mcron; factorize.
1549 #~(lambda (_ . args)
1550 ;; Run 'nscd' in a pipe so we can explicitly redirect its output to
1551 ;; 'current-output-port', which at this stage is bound to the client
1552 ;; connection.
1553 (let ((pipe (apply open-pipe* OPEN_READ #$nscd
1554 "-f" #$config #$option args)))
1555 (let loop ()
1556 (match (read-line pipe 'concat)
1557 ((? eof-object?)
1558 (catch 'system-error
1559 (lambda ()
1560 (zero? (close-pipe pipe)))
1561 (lambda args
1562 ;; There's a race with the SIGCHLD handler, which could
1563 ;; call 'waitpid' before 'close-pipe' above does. If we
1564 ;; get ECHILD, that means we lost the race; in that case, we
1565 ;; cannot tell what the exit code was (FIXME).
1566 (or (= ECHILD (system-error-errno args))
1567 (apply throw args)))))
1568 (line
1569 (display line)
1570 (loop)))))))
1571
1572(define (nscd-actions nscd config)
1573 "Return Shepherd actions for NSCD using CONFIG its config file."
1574 ;; Make this functionality available as actions because that's a simple way
1575 ;; to run the right 'nscd' binary with the right config file.
1576 (list (shepherd-configuration-action config)
1577 (shepherd-action
1578 (name 'statistics)
1579 (documentation "Display statistics about nscd usage.")
1580 (procedure (nscd-action-procedure nscd config "--statistics")))
1581 (shepherd-action
1582 (name 'invalidate)
1583 (documentation
1584 "Invalidate the given cache--e.g., 'hosts' for host name lookups.")
1585 (procedure (nscd-action-procedure nscd config "--invalidate")))))
1586
1587(define (nscd-shepherd-service config)
1588 "Return a shepherd service for CONFIG, an <nscd-configuration> object."
1589 (let ((nscd (file-append (nscd-configuration-glibc config)
1590 "/sbin/nscd"))
1591 (nscd.conf (nscd.conf-file config))
1592 (name-services (nscd-configuration-name-services config)))
1593 (list (shepherd-service
1594 (documentation "Run libc's name service cache daemon (nscd).")
1595 (provision '(nscd))
1596
1597 ;; Logs are written with syslog(3), which writes to /dev/console
1598 ;; when nobody's listening--ugly. Thus, wait for syslogd.
1599 (requirement '(user-processes syslogd))
1600
1601 (start #~(make-forkexec-constructor
1602 (list #$nscd "-f" #$nscd.conf "--foreground")
1603
1604 ;; Wait for the PID file. However, the PID file is
1605 ;; written before nscd is actually listening on its
1606 ;; socket (XXX).
1607 #:pid-file "/var/run/nscd/nscd.pid"
1608
1609 #:environment-variables
1610 (list (string-append "LD_LIBRARY_PATH="
1611 (string-join
1612 (map (lambda (dir)
1613 (string-append dir "/lib"))
1614 (list #$@name-services))
1615 ":")))))
1616 (stop #~(let ((terminate (make-kill-destructor)))
1617 (lambda (process)
1618 (terminate process)
1619
1620 ;; PID 1 might have mapped nscd database files via
1621 ;; '__nscd_get_mapping'. Call the relevant libc
1622 ;; functions (those with a corresponding GETFD* request
1623 ;; type) to cause PID 1 to notice that those mappings
1624 ;; are stale and to unmap them. Failure to do so would
1625 ;; prevent the root file system from being remounted
1626 ;; read-only when shutting down.
1627 (false-if-exception (getpw "root"))
1628 (false-if-exception (getgr "root"))
1629 (false-if-exception (getaddrinfo "localhost" "http"))
1630 #f)))
1631 (modules `((ice-9 popen) ;for the actions
1632 (ice-9 rdelim)
1633 (ice-9 match)
1634 ,@%default-modules))
1635 (actions (nscd-actions nscd nscd.conf))))))
1636
1637(define nscd-activation
1638 ;; Actions to take before starting nscd.
1639 #~(begin
1640 (use-modules (guix build utils))
1641 (mkdir-p "/var/run/nscd")
1642 (mkdir-p "/var/db/nscd"))) ;for the persistent cache
1643
1644(define nscd-service-type
1645 (service-type (name 'nscd)
1646 (extensions
1647 (list (service-extension activation-service-type
1648 (const nscd-activation))
1649 (service-extension shepherd-root-service-type
1650 nscd-shepherd-service)))
1651
1652 ;; This can be extended by providing additional name services
1653 ;; such as nss-mdns.
1654 (compose concatenate)
1655 (extend (lambda (config name-services)
1656 (nscd-configuration
1657 (inherit config)
1658 (name-services (append
1659 (nscd-configuration-name-services config)
1660 name-services)))))
1661 (default-value (nscd-configuration))
1662 (description
1663 "Runs libc's @dfn{name service cache daemon} (nscd) with the
1664given configuration---an @code{<nscd-configuration>} object. @xref{Name
1665Service Switch}, for an example.")))
1666
1667(define-deprecated (nscd-service #:optional (config (nscd-configuration)))
1668 nscd-service-type
1669 "Return a service that runs libc's name service cache daemon (nscd) with the
1670given @var{config}---an @code{<nscd-configuration>} object. @xref{Name
1671Service Switch}, for an example."
1672 (service nscd-service-type config))
1673
1674;;; Snippet adapted from the GNU inetutils manual.
1675(define %default-syslog.conf
1676 (plain-file "syslog.conf" "\
1677# See info '(inetutils) syslogd invocation' for the documentation
1678# of the syslogd configuration syntax.
1679
1680# Log all error messages, authentication messages of
1681# level notice or higher and anything of level err or
1682# higher to the console.
1683# Don't log private authentication messages!
1684*.alert;auth.notice;authpriv.none -/dev/console
1685
1686# Log anything (except mail) of level info or higher.
1687# Don't log private authentication messages!
1688*.info;mail.none;authpriv.none -/var/log/messages
1689
1690# Log \"debug\"-level entries and nothing else.
1691*.=debug -/var/log/debug
1692
1693# Same, in a different place.
1694*.info;mail.none;authpriv.none -/dev/tty12
1695
1696# The authpriv file has restricted access.
1697# 'fsync' the file after each line (hence the lack of a leading dash).
1698# Also include unprivileged auth logs of info or higher level
1699# to conveniently gather the authentication data at the same place.
1700authpriv.*;auth.info /var/log/secure
1701
1702# Log all the mail messages in one place.
1703mail.* -/var/log/maillog
1704"))
1705
1706(define-record-type* <syslog-configuration>
1707 syslog-configuration make-syslog-configuration
1708 syslog-configuration?
1709 (syslogd syslog-configuration-syslogd
1710 (default (file-append inetutils "/libexec/syslogd")))
1711 (config-file syslog-configuration-config-file
1712 (default %default-syslog.conf))
1713 (pid-file syslog-configuration-pid-file
1714 (default "/var/run/syslog.pid"))
1715 (extra-options syslog-configuration-extra-options
1716 (default '())))
1717
1718;;; Note: a static file name is used for syslog.conf so that the reload action
1719;;; work as intended.
1720(define syslog.conf "/etc/syslog.conf")
1721
1722(define (syslog-etc configuration)
1723 (match-record configuration <syslog-configuration>
1724 (config-file)
1725 (list `(,(basename syslog.conf) ,config-file))))
1726
1727(define (syslog-shepherd-service config)
1728 (define config-file
1729 (syslog-configuration-config-file config))
1730
1731 (shepherd-service
1732 (documentation "Run the syslog daemon (syslogd).")
1733 (provision '(syslogd))
1734 (requirement '(user-processes))
1735 (actions
1736 (list (shepherd-configuration-action syslog.conf)
1737 (shepherd-signal-action
1738 'reload SIGHUP
1739 #:documentation "Reload the configuration file from disk."
1740 #:message "Service syslog has been asked to \
1741reload its settings file.")))
1742 ;; Note: a static file name is used for syslog.conf so that the reload
1743 ;; action work as intended.
1744 (start #~(make-forkexec-constructor
1745 (list #$(syslog-configuration-syslogd config)
1746 ;; the -f option here is compatible with rsyslog
1747 "-f" #$syslog.conf
1748 #$@(syslog-configuration-extra-options config))
1749 #:file-creation-mask #o137
1750 #:pid-file #$(syslog-configuration-pid-file config)))
1751 (stop #~(make-kill-destructor))))
1752
1753(define %default-syslog-files
1754 ;; List of files usually produced by syslogd that should be rotated.
1755 '("/var/log/messages" "/var/log/secure" "/var/log/debug"
1756 "/var/log/maillog"))
1757
1758(define syslog-service-type
1759 (service-type
1760 (name 'syslog)
1761 (default-value (syslog-configuration))
1762 (extensions (list (service-extension shepherd-root-service-type
1763 (compose list
1764 syslog-shepherd-service))
1765 (service-extension log-rotation-service-type
1766 (const %default-syslog-files))
1767 (service-extension etc-service-type syslog-etc)))
1768 (description "Run the syslog daemon, @command{syslogd}, which is
1769responsible for logging system messages.")))
1770
1771(define-deprecated (syslog-service #:optional (config (syslog-configuration)))
1772 syslog-service-type
1773 "Return a service that runs @command{syslogd} and takes
1774@var{<syslog-configuration>} as a parameter.
1775
1776@xref{syslogd invocation,,, inetutils, GNU Inetutils}, for more
1777information on the configuration file syntax."
1778 (service syslog-service-type config))
1779
1780
1781(define pam-limits-service-type
1782 (let ((pam-extension
1783 (lambda (limits-file)
1784 (pam-extension
1785 (transformer
1786 (lambda (pam)
1787 (let ((pam-limits (pam-entry
1788 (control "required")
1789 (module "pam_limits.so")
1790 (arguments
1791 (list #~(string-append "conf=" #$limits-file))))))
1792 (if (member (pam-service-name pam)
1793 '("login" "greetd" "su" "slim" "gdm-password"
1794 "sddm" "lightdm" "sudo" "sshd"))
1795 (pam-service
1796 (inherit pam)
1797 (session (cons pam-limits
1798 (pam-service-session pam))))
1799 pam)))))))
1800 (make-limits-file
1801 (match-lambda
1802 ;; XXX: Using file-like objects is deprecated, use lists instead.
1803 ;; This is to be reduced into the list? case when the deprecated
1804 ;; code gets removed.
1805 ((? file-like? obj)
1806 (warning (G_ "Using file-like value for \
1807'pam-limits-service-type' is deprecated~%"))
1808 obj)
1809 ((? list? lst)
1810 (plain-file "limits.conf"
1811 (string-join (map pam-limits-entry->string lst)
1812 "\n" 'suffix)))
1813 (_ (raise
1814 (formatted-message
1815 (G_ "invalid input for 'pam-limits-service-type'~%")))))))
1816
1817 (service-type
1818 (name 'limits)
1819 (compose concatenate)
1820 (extend append)
1821 (extensions
1822 (list (service-extension pam-root-service-type
1823 (lambda (config)
1824 (list (pam-extension (make-limits-file config)))))))
1825 (description
1826 "Use the @code{pam_limits} authentication module to set the specified
1827resource usage limits.")
1828 (default-value '()))))
1829
1830(define-deprecated (pam-limits-service #:optional (limits '()))
1831 pam-limits-service-type
1832 "Return a service that makes selected programs respect the list of
1833pam-limits-entry specified in LIMITS via pam_limits.so."
1834 (service pam-limits-service-type
1835 (plain-file "limits.conf"
1836 (string-join (map pam-limits-entry->string limits)
1837 "\n"))))
1838
1839
1840;;;
1841;;; Guix services.
1842;;;
1843
1844(define* (guix-build-accounts count #:key
1845 (group "guixbuild")
1846 (shadow shadow))
1847 "Return a list of COUNT user accounts for Guix build users with the given
1848GID."
1849 (unfold (cut > <> count)
1850 (lambda (n)
1851 (user-account
1852 (name (format #f "guixbuilder~2,'0d" n))
1853 (system? #t)
1854 (group group)
1855
1856 ;; guix-daemon expects GROUP to be listed as a
1857 ;; supplementary group too:
1858 ;; <http://lists.gnu.org/archive/html/bug-guix/2013-01/msg00239.html>.
1859 (supplementary-groups (list group "kvm"))
1860
1861 (comment (format #f "Guix Build User ~2d" n))
1862 (home-directory "/var/empty")
1863 (shell (file-append shadow "/sbin/nologin"))))
1864 1+
1865 1))
1866
1867(define not-config?
1868 ;; Select (guix …) and (gnu …) modules, except (guix config).
1869 (match-lambda
1870 (('guix 'config) #f)
1871 (('guix rest ...) #t)
1872 (('gnu rest ...) #t)
1873 (rest #f)))
1874
1875(define (guix-configuration-file-installation name file)
1876 "Return a gexp that create a symlink '/etc/guix/NAME' to FILE."
1877 (with-imported-modules '((guix build utils))
1878 #~(begin
1879 (use-modules (guix build utils))
1880
1881 (let* ((target #$(string-append "/etc/guix/" name))
1882 (install (lambda ()
1883 ;; Installed the declared channels.
1884 (symlink #+file target))))
1885 (catch 'system-error
1886 install
1887 (lambda args
1888 (cond ((= (system-error-errno args) EEXIST)
1889 ;; If NAME already exists, move it out of the way.
1890 ;; Create a backup if it's a regular file: it's likely
1891 ;; that the user manually defined it.
1892 (if (and (symbolic-link? target)
1893 (store-file-name? (readlink target)))
1894 (delete-file target)
1895 (rename-file target (string-append target ".bak")))
1896 (install)) ;retry
1897 ((= (system-error-errno args) ENOENT)
1898 (mkdir-p "/etc/guix")
1899 (install)) ;retry
1900 (else
1901 (apply throw args)))))))))
1902
1903(define (substitute-key-authorization keys guix)
1904 "Return a gexp with code to register KEYS, a list of files containing 'guix
1905archive' public keys, with GUIX."
1906 (define default-acl
1907 (with-extensions (list guile-gcrypt)
1908 (with-imported-modules `(((guix config) => ,(make-config.scm))
1909 ,@(source-module-closure '((guix pki))
1910 #:select? not-config?))
1911 (computed-file "acl"
1912 #~(begin
1913 (use-modules (guix pki)
1914 (gcrypt pk-crypto)
1915 (ice-9 rdelim))
1916
1917 (define keys
1918 (map (lambda (file)
1919 (call-with-input-file file
1920 (compose string->canonical-sexp
1921 read-string)))
1922 '(#$@keys)))
1923
1924 (call-with-output-file #$output
1925 (lambda (port)
1926 (write-acl (public-keys->acl keys)
1927 port))))))))
1928
1929 (guix-configuration-file-installation "acl" default-acl))
1930
1931(define (install-channels-file channels)
1932 "Return a gexp with code to install CHANNELS, a list of channels, in
1933/etc/guix/channels.scm."
1934 (define channels-file
1935 (plain-file "channels.scm"
1936 (call-with-output-string
1937 (lambda (port)
1938 (pretty-print
1939 `(list ,@(map channel->code channels))
1940 port)))))
1941
1942 (guix-configuration-file-installation "channels.scm" channels-file))
1943
1944(define %default-authorized-guix-keys
1945 ;; List of authorized substitute keys.
1946 (list (file-append guix "/share/guix/berlin.guix.gnu.org.pub")
1947 (file-append guix "/share/guix/bordeaux.guix.gnu.org.pub")))
1948
1949(define (guix-machines-files-installation machines)
1950 "Return a gexp to install MACHINES, a list of gexps, as
1951/etc/guix/machines.scm, which is used for offloading."
1952 (guix-configuration-file-installation
1953 "machines.scm"
1954 (scheme-file "machines.scm"
1955 #~((@ (srfi srfi-1) append-map)
1956 (lambda (entry)
1957 (if (build-machine? entry)
1958 (list entry)
1959 entry))
1960 #$machines))))
1961
1962(define (run-with-writable-store)
1963 "Return a wrapper that runs the given command under the specified UID and
1964GID in a context where the store is writable, even if it was bind-mounted
1965read-only via %IMMUTABLE-STORE (this wrapper must run as root)."
1966 (program-file "run-with-writable-store"
1967 (with-imported-modules (source-module-closure
1968 '((guix build syscalls)
1969 (gnu build accounts)))
1970 #~(begin
1971 (use-modules (guix build syscalls)
1972 (gnu build accounts)
1973 (srfi srfi-1)
1974 (ice-9 match))
1975
1976 (define (ensure-writable-store store)
1977 ;; Create a new mount namespace and remount STORE with
1978 ;; write permissions if it's read-only.
1979 (let ((fs (statfs store)))
1980 (when (logand (file-system-mount-flags fs) ST_RDONLY)
1981 (unshare CLONE_NEWNS)
1982 (mount store store "none"
1983 (logior MS_BIND MS_REMOUNT)))))
1984
1985 (match (command-line)
1986 ((_ user group command args ...)
1987 (ensure-writable-store #$(%store-prefix))
1988 (let* ((uid (or (string->number user)
1989 (passwd:uid (getpwnam user))))
1990 (gid (or (string->number group)
1991 (group:gid (getgrnam group))))
1992 (user (passwd:name (getpwuid uid)))
1993 (groups (filter-map
1994 (lambda (group)
1995 (and (member user
1996 (group-entry-members
1997 group))
1998 (group-entry-gid group)))
1999 (read-group))))
2000 (setgroups (list->vector groups))
2001 (setgid gid)
2002 (setuid uid)
2003 (apply execl command command args))))))))
2004
2005(define (guix-ownership-change-program)
2006 "Return a program that changes ownership of the store and other data files
2007of Guix to the given UID and GID."
2008 (program-file
2009 "validate-guix-ownership"
2010 (with-imported-modules (source-module-closure
2011 '((guix build utils)))
2012 #~(begin
2013 (use-modules (guix build utils)
2014 (ice-9 ftw)
2015 (ice-9 match))
2016
2017 (define (lchown file uid gid)
2018 (let ((parent (open (dirname file) O_DIRECTORY)))
2019 (chown-at parent (basename file) uid gid
2020 AT_SYMLINK_NOFOLLOW)
2021 (close-port parent)))
2022
2023 (define (change-ownership directory uid gid)
2024 ;; chown -R UID:GID DIRECTORY
2025 (file-system-fold (const #t) ;enter?
2026 (lambda (file stat result) ;leaf
2027 (if (eq? 'symlink (stat:type stat))
2028 (lchown file uid gid)
2029 (chown file uid gid)))
2030 (const #t) ;down
2031 (lambda (directory stat result) ;up
2032 (chown directory uid gid))
2033 (const #t) ;skip
2034 (lambda (file stat errno result)
2035 (format (current-error-port)
2036 "i/o error: ~a: ~a~%"
2037 file (strerror errno))
2038 #f)
2039 #t ;seed
2040 directory
2041 lstat))
2042
2043 (define (claim-data-ownership uid gid)
2044 (format #t "Changing file ownership for ~a \
2045and data directories to ~a:~a...~%"
2046 #$(%store-prefix) uid gid)
2047 (let ((excluded '("." ".." "profiles" "userpool")))
2048 (for-each (lambda (directory)
2049 (change-ownership (in-vicinity "/var/guix" directory)
2050 uid gid))
2051 (scandir "/var/guix"
2052 (lambda (file)
2053 (not (member file
2054 excluded))))))
2055 (chown "/var/guix" uid gid)
2056 (change-ownership "/etc/guix" uid gid)
2057 (mkdir-p "/var/log/guix")
2058 (change-ownership "/var/log/guix" uid gid)
2059
2060 ;; Change the store last so that, if this service is interrupted,
2061 ;; ownership appears as having yet to be changed.
2062 (change-ownership #$(%store-prefix) uid gid))
2063
2064 (match (command-line)
2065 ((_ (= string->number (? integer? uid))
2066 (= string->number (? integer? gid)))
2067 (setlocale LC_ALL "C.UTF-8") ;for file name decoding
2068 (setvbuf (current-output-port) 'line)
2069 (claim-data-ownership uid gid)))))))
2070
2071(define-record-type* <guix-configuration>
2072 guix-configuration make-guix-configuration
2073 guix-configuration?
2074 (guix guix-configuration-guix ;file-like
2075 (default guix))
2076 (build-group guix-configuration-build-group ;string
2077 (default "guixbuild"))
2078 (build-accounts guix-configuration-build-accounts ;integer
2079 (default 10))
2080 (chroot? guix-configuration-chroot? ;Boolean | 'default
2081 (default 'default))
2082 (authorize-key? guix-configuration-authorize-key? ;Boolean
2083 (default #t))
2084 (authorized-keys guix-configuration-authorized-keys ;list of gexps
2085 (default %default-authorized-guix-keys))
2086 (use-substitutes? guix-configuration-use-substitutes? ;Boolean
2087 (default #t))
2088 (substitute-urls guix-configuration-substitute-urls ;list of strings
2089 (default %default-substitute-urls))
2090 (generate-substitute-key? guix-configuration-generate-substitute-key?
2091 (default #t)) ;Boolean
2092 (channels guix-configuration-channels ;file-like
2093 (default #f))
2094 (chroot-directories guix-configuration-chroot-directories ;list of file-like/strings
2095 (default '()))
2096 (max-silent-time guix-configuration-max-silent-time ;integer
2097 (default 3600))
2098 (timeout guix-configuration-timeout ;integer
2099 (default (* 3600 24)))
2100 (log-compression guix-configuration-log-compression
2101 (default 'gzip))
2102 (discover? guix-configuration-discover?
2103 (default #f))
2104 (extra-options guix-configuration-extra-options ;list of strings
2105 (default '()))
2106 (log-file guix-configuration-log-file ;string
2107 (default "/var/log/guix-daemon.log"))
2108 (http-proxy guix-http-proxy ;string | #f
2109 (default #f))
2110 (tmpdir guix-tmpdir ;string | #f
2111 (default #f))
2112 (privileged? guix-configuration-privileged?
2113 (default #t))
2114 (build-machines guix-configuration-build-machines ;list of gexps | '()
2115 (default '()))
2116 (environment guix-configuration-environment ;list of strings
2117 (default '()))
2118 (socket-directory-permissions
2119 guix-configuration-socket-directory-permissions
2120 (default #o755))
2121 (socket-directory-group guix-configuration-socket-directory-group
2122 (default #f))
2123 (socket-directory-user guix-configuration-socket-directory-user
2124 (default #f)))
2125
2126(define %default-guix-configuration
2127 (guix-configuration))
2128
2129(define shepherd-set-http-proxy-action
2130 ;; Shepherd action to change the HTTP(S) proxy.
2131 (shepherd-action
2132 (name 'set-http-proxy)
2133 (documentation
2134 "Change the HTTP(S) proxy used by 'guix-daemon' and restart it.")
2135 (procedure #~(lambda* (_ #:optional proxy)
2136 (let ((environment (environ)))
2137 ;; A bit of a hack: communicate PROXY to the 'start'
2138 ;; method via environment variables.
2139 (if proxy
2140 (begin
2141 (format #t "changing HTTP/HTTPS \
2142proxy of 'guix-daemon' to ~s...~%"
2143 proxy)
2144 (setenv "http_proxy" proxy))
2145 (begin
2146 (format #t "clearing HTTP/HTTPS \
2147proxy of 'guix-daemon'...~%")
2148 (unsetenv "http_proxy")))
2149 (perform-service-action (lookup-service 'guix-daemon)
2150 'restart)
2151 (environ environment)
2152 #t)))))
2153
2154(define shepherd-discover-action
2155 ;; Shepherd action to enable or disable substitute servers discovery.
2156 (shepherd-action
2157 (name 'discover)
2158 (documentation
2159 "Enable or disable substitute servers discovery and restart the
2160'guix-daemon'.")
2161 (procedure #~(lambda* (_ status)
2162 (let ((environment (environ)))
2163 (if (and status
2164 (string=? status "on"))
2165 (begin
2166 (format #t "enable substitute servers discovery~%")
2167 (setenv "discover" "on"))
2168 (begin
2169 (format #t "disable substitute servers discovery~%")
2170 (unsetenv "discover")))
2171 (perform-service-action (lookup-service 'guix-daemon)
2172 'restart)
2173 (environ environment)
2174 #t)))))
2175
2176(define (guix-shepherd-services config)
2177 "Return a <shepherd-service> for the Guix daemon service with CONFIG."
2178 (define locales
2179 (let-system (system target)
2180 (if (target-hurd? (or target system))
2181 (make-glibc-utf8-locales glibc/hurd)
2182 glibc-utf8-locales)))
2183
2184 (match-record config <guix-configuration>
2185 (guix privileged?
2186 build-group build-accounts chroot? authorize-key? authorized-keys
2187 use-substitutes? substitute-urls max-silent-time timeout
2188 log-compression discover? extra-options log-file
2189 http-proxy tmpdir chroot-directories environment
2190 socket-directory-permissions socket-directory-group
2191 socket-directory-user)
2192 (list (shepherd-service
2193 (provision '(guix-ownership))
2194 (requirement '(user-processes user-homes))
2195 (one-shot? #t)
2196 (start #~(lambda ()
2197 (let* ((store #$(%store-prefix))
2198 (stat (lstat store))
2199 (privileged? #$(guix-configuration-privileged?
2200 config))
2201 (change-ownership #$(guix-ownership-change-program))
2202 (with-writable-store #$(run-with-writable-store)))
2203 ;; Check whether we're switching from privileged to
2204 ;; unprivileged guix-daemon, or vice versa, and adjust
2205 ;; file ownership accordingly. Spawn a child process
2206 ;; if and only if something needs to be changed.
2207 ;;
2208 ;; Note: This service remains in 'starting' state for
2209 ;; as long as CHANGE-OWNERSHIP is running. That way,
2210 ;; 'guix-daemon' starts only once we're done.
2211 (cond ((and (not privileged?)
2212 (or (zero? (stat:uid stat))
2213 (zero? (stat:gid stat))))
2214 (let ((user (getpwnam "guix-daemon")))
2215 (format #t "Changing to unprivileged guix-daemon.~%")
2216 (zero?
2217 (system* with-writable-store "0" "0"
2218 change-ownership
2219 (number->string (passwd:uid user))
2220 (number->string (passwd:gid user))))))
2221 ((and privileged?
2222 (and (not (zero? (stat:uid stat)))
2223 (not (zero? (stat:gid stat)))))
2224 (format #t "Changing to privileged guix-daemon.~%")
2225 (zero? (system* with-writable-store "0" "0"
2226 change-ownership "0" "0")))
2227 (else #t)))))
2228 (documentation "Ensure that the store and other data files used by
2229guix-daemon have the right ownership."))
2230
2231 (shepherd-service
2232 (documentation "Run the Guix daemon.")
2233 (provision '(guix-daemon))
2234 (requirement `(user-processes
2235 guix-ownership
2236 ,@(if discover? '(avahi-daemon) '())))
2237 (actions (list shepherd-set-http-proxy-action
2238 shepherd-discover-action))
2239 (modules '((srfi srfi-1)
2240 (ice-9 match)
2241 (gnu build shepherd)
2242 (guix build utils)))
2243 (start
2244 (with-imported-modules `(((guix config) => ,(make-config.scm))
2245 ,@(source-module-closure
2246 '((gnu build shepherd)
2247 (guix build utils))
2248 #:select? not-config?))
2249 #~(lambda args
2250 (define proxy
2251 ;; HTTP/HTTPS proxy. The 'http_proxy' variable is set by
2252 ;; the 'set-http-proxy' action.
2253 (or (getenv "http_proxy") #$http-proxy))
2254
2255 (define discover?
2256 (or (getenv "discover") #$discover?))
2257
2258 (define daemon-command
2259 (cons* #$@(if privileged?
2260 #~()
2261 #~(#$(run-with-writable-store)
2262 "guix-daemon" "guix-daemon"))
2263
2264 #$(file-append guix "/bin/guix-daemon")
2265 #$@(if privileged?
2266 #~("--build-users-group" #$build-group)
2267 #~())
2268 "--max-silent-time"
2269 #$(number->string max-silent-time)
2270 "--timeout" #$(number->string timeout)
2271 "--log-compression"
2272 #$(symbol->string log-compression)
2273 #$@(if use-substitutes?
2274 '()
2275 '("--no-substitutes"))
2276 (string-append "--discover="
2277 (if discover? "yes" "no"))
2278 "--substitute-urls" #$(string-join substitute-urls)
2279 #$@extra-options
2280
2281 #$@(if chroot?
2282 '()
2283 '("--disable-chroot"))
2284 ;; Add CHROOT-DIRECTORIES and all their dependencies
2285 ;; (if these are store items) to the chroot.
2286 (append-map
2287 (lambda (file)
2288 (append-map (lambda (directory)
2289 (list "--chroot-directory"
2290 directory))
2291 (call-with-input-file file
2292 read)))
2293 '#$(map references-file
2294 chroot-directories))))
2295
2296 (define environment-variables
2297 (append (list #$@(if tmpdir
2298 (list (string-append "TMPDIR=" tmpdir))
2299 '())
2300
2301 ;; Make sure we run in a UTF-8 locale so that
2302 ;; 'guix offload' correctly restores nars
2303 ;; that contain UTF-8 file names such as
2304 ;; 'nss-certs'. See
2305 ;; <https://bugs.gnu.org/32942>.
2306 (string-append "GUIX_LOCPATH="
2307 #$locales "/lib/locale")
2308 "LC_ALL=en_US.utf8"
2309 ;; Make 'tar' and 'gzip' available so
2310 ;; that 'guix perform-download' can use
2311 ;; them when downloading from Software
2312 ;; Heritage via '(guix swh)'. Last,
2313 ;; /run/privileged/bin is needed for
2314 ;; 'newgidmap', used by the unprivileged
2315 ;; daemon.
2316 (string-append "PATH="
2317 #$(file-append tar "/bin") ":"
2318 #$(file-append gzip "/bin") ":"
2319 "/run/privileged/bin"))
2320 (if proxy
2321 (list (string-append "http_proxy=" proxy)
2322 (string-append "https_proxy=" proxy))
2323 '())
2324 '#$environment))
2325
2326 ;; Ensure that a fresh directory is used, in case the old
2327 ;; one was more permissive and processes have a file
2328 ;; descriptor referencing it hanging around, ready to use
2329 ;; with openat.
2330 (false-if-exception
2331 (delete-file-recursively "/var/guix/daemon-socket"))
2332
2333 (match args
2334 (((= string->number (? integer? pid)))
2335 ;; Start the guix-daemon in the same mnt namespace as
2336 ;; PID. This is necessary when running the installer.
2337 ;; Assume /var/guix/daemon-socket was created by a
2338 ;; previous 'start' call without arguments.
2339 (fork+exec-command/container
2340 daemon-command
2341 #:pid pid
2342 #:environment-variables environment-variables
2343 #:log-file #$log-file))
2344 (()
2345 ;; Default to socket activation.
2346 (let ((socket (endpoint
2347 (make-socket-address
2348 AF_UNIX
2349 "/var/guix/daemon-socket/socket")
2350 #:name "socket"
2351 #:socket-owner
2352 (or #$socket-directory-user
2353 #$(if privileged? 0 "guix-daemon"))
2354 #:socket-group
2355 (or #$socket-directory-group
2356 #$(if privileged? 0 "guix-daemon"))
2357 #:socket-directory-permissions
2358 #$socket-directory-permissions)))
2359 ((make-systemd-constructor daemon-command
2360 (list socket)
2361 #:environment-variables
2362 environment-variables
2363 #:log-file #$log-file))))))))
2364 (stop #~(lambda (value)
2365 (if (or (process? value) (integer? value))
2366 ((make-kill-destructor) value)
2367 ((make-systemd-destructor) value))))))))
2368
2369(define (guix-accounts config)
2370 "Return the user accounts and user groups for CONFIG."
2371 `(,@(if (guix-configuration-privileged? config)
2372 '()
2373 (list (user-group (name "guix-daemon") (system? #t))
2374 (user-account
2375 (name "guix-daemon")
2376 (group "guix-daemon")
2377 (system? #t)
2378 (supplementary-groups '("kvm"))
2379 (comment "Guix Daemon User")
2380 (home-directory "/var/empty")
2381 (shell (file-append shadow "/sbin/nologin")))))
2382
2383 ;; When reconfiguring from privileged to unprivileged, the running daemon
2384 ;; (privileged) relies on the availability of the build accounts and build
2385 ;; group until 'guix system reconfigure' has completed. The simplest way
2386 ;; to meet this requirement is to create these accounts unconditionally so
2387 ;; they are not removed in the middle of the 'reconfigure' process.
2388 ,(user-group
2389 (name (guix-configuration-build-group config))
2390 (system? #t)
2391
2392 ;; Use a fixed GID so that we can create the store with the right owner.
2393 (id 30000))
2394 ,@(guix-build-accounts (guix-configuration-build-accounts config)
2395 #:group (guix-configuration-build-group config))))
2396
2397(define (guix-activation config)
2398 "Return the activation gexp for CONFIG."
2399 (match-record config <guix-configuration>
2400 (guix generate-substitute-key? authorize-key? authorized-keys channels)
2401 #~(begin
2402 ;; Assume that the store has BUILD-GROUP as its group. We could
2403 ;; otherwise call 'chown' here, but the problem is that on a COW overlayfs,
2404 ;; chown leads to an entire copy of the tree, which is a bad idea.
2405
2406 ;; Generate a key pair and optionally authorize substitute server keys.
2407 (unless (or #$(not generate-substitute-key?)
2408 (file-exists? "/etc/guix/signing-key.pub"))
2409 (system* #$(file-append guix "/bin/guix") "archive"
2410 "--generate-key"))
2411
2412 ;; Optionally install /etc/guix/acl...
2413 #$(if authorize-key?
2414 (substitute-key-authorization authorized-keys guix)
2415 #~#f)
2416
2417 ;; ... and /etc/guix/channels.scm...
2418 #$(and channels (install-channels-file channels))
2419
2420 ;; ... and /etc/guix/machines.scm.
2421 #$(if (null? (guix-configuration-build-machines config))
2422 #~#f
2423 (guix-machines-files-installation
2424 #~(list #$@(guix-configuration-build-machines config))))
2425
2426 #$(and (not (guix-configuration-privileged? config))
2427 ;; Augment /etc/subgid so that the "kvm" group can be mapped in
2428 ;; the build user namespace. If a line is already present,
2429 ;; assume it's correct.
2430 #~(let ((port (open-file "/etc/subgid" "w+"))
2431 (kvm (false-if-exception (getgrnam "kvm"))))
2432 (when kvm
2433 (let loop ()
2434 (let ((line ((@ (ice-9 rdelim) read-line) port)))
2435 (cond ((eof-object? line)
2436 (format port "guix-daemon:~a:1~%"
2437 (group:gid kvm)))
2438 ((string-prefix? "guix-daemon:" line)
2439 #t)
2440 (else (loop))))))
2441 (close-port port))))))
2442
2443(define-record-type* <guix-extension>
2444 guix-extension make-guix-extension
2445 guix-extension?
2446 (authorized-keys guix-extension-authorized-keys ;list of file-like
2447 (default '()))
2448 (substitute-urls guix-extension-substitute-urls ;list of strings
2449 (default '()))
2450 (build-machines guix-extension-build-machines ;list of gexps
2451 (default '()))
2452 (chroot-directories guix-extension-chroot-directories ;list of file-like/strings
2453 (default '())))
2454
2455(define (guix-extension-merge a b)
2456 (guix-extension
2457 (authorized-keys (append (guix-extension-authorized-keys a)
2458 (guix-extension-authorized-keys b)))
2459 (substitute-urls (append (guix-extension-substitute-urls a)
2460 (guix-extension-substitute-urls b)))
2461 (build-machines (append (guix-extension-build-machines a)
2462 (guix-extension-build-machines b)))
2463 (chroot-directories (append (guix-extension-chroot-directories a)
2464 (guix-extension-chroot-directories b)))))
2465
2466(define guix-service-type
2467 (service-type
2468 (name 'guix)
2469 (extensions
2470 (list (service-extension shepherd-root-service-type guix-shepherd-services)
2471 (service-extension account-service-type guix-accounts)
2472 (service-extension activation-service-type guix-activation)
2473 (service-extension profile-service-type
2474 (compose list guix-configuration-guix))))
2475
2476 ;; Extensions can specify extra directories to add to the build chroot,
2477 ;; extra substitute urls and extra authorized keys
2478 (compose (lambda (args) (fold guix-extension-merge (guix-extension) args)))
2479 (extend (lambda (config extension)
2480 (guix-configuration
2481 (inherit config)
2482 (authorized-keys (append (guix-extension-authorized-keys extension)
2483 (guix-configuration-authorized-keys config)))
2484 (substitute-urls (append (guix-extension-substitute-urls extension)
2485 (guix-configuration-substitute-urls config)))
2486 (build-machines
2487 (and (or (guix-configuration-build-machines config)
2488 (pair? (guix-extension-build-machines extension)))
2489 (append (guix-configuration-build-machines config)
2490 (guix-extension-build-machines extension))))
2491 (chroot-directories
2492 (append (guix-extension-chroot-directories extension)
2493 (guix-configuration-chroot-directories config))))))
2494
2495 (default-value (guix-configuration))
2496 (description
2497 "Run the build daemon of GNU@tie{}Guix, aka. @command{guix-daemon}.")))
2498
2499
2500(define-record-type* <guix-publish-configuration>
2501 guix-publish-configuration make-guix-publish-configuration
2502 guix-publish-configuration?
2503 (guix guix-publish-configuration-guix ;file-like
2504 (default guix))
2505 (port guix-publish-configuration-port ;number
2506 (default 80))
2507 (host guix-publish-configuration-host ;string
2508 (default "localhost"))
2509 (advertise? guix-publish-advertise? ;boolean
2510 (default #f))
2511 (compression guix-publish-configuration-compression
2512 (thunked)
2513 (default (default-compression this-record)))
2514 (nar-path guix-publish-configuration-nar-path ;string
2515 (default "nar"))
2516 (cache guix-publish-configuration-cache ;#f | string
2517 (default #f))
2518 (cache-bypass-threshold guix-publish-configuration-cache-bypass-threshold
2519 (default (* 10 (expt 2 20)))) ;integer
2520 (workers guix-publish-configuration-workers ;#f | integer
2521 (default #f))
2522 (ttl guix-publish-configuration-ttl ;#f | integer
2523 (default #f))
2524 (negative-ttl guix-publish-configuration-negative-ttl ;#f | integer
2525 (default #f)))
2526
2527(define (default-compression config)
2528 "Return the default 'guix publish' compression according to CONFIG, and
2529raise a deprecation warning if the 'compression-level' field was used."
2530 ;; Default to low compression levels when there's no cache so that users
2531 ;; get good bandwidth by default.
2532 (if (guix-publish-configuration-cache config)
2533 '(("gzip" 5) ("zstd" 19))
2534 '(("gzip" 3) ("zstd" 3)))) ;zstd compresses faster
2535
2536(define (guix-publish-shepherd-service config)
2537 (define (config->compression-options config)
2538 (match (guix-publish-configuration-compression config)
2539 (() ;empty list means "no compression"
2540 '("-C0"))
2541 (lst
2542 (append-map (match-lambda
2543 ((type level)
2544 `("-C" ,(string-append type ":"
2545 (number->string level)))))
2546 lst))))
2547
2548 (match-record config <guix-publish-configuration>
2549 (guix port host nar-path cache workers ttl negative-ttl
2550 cache-bypass-threshold advertise?)
2551 (let ((command #~(list #$(file-append guix "/bin/guix")
2552 "publish" "-u" "guix-publish"
2553 "-p" #$(number->string port)
2554 #$@(config->compression-options config)
2555 (string-append "--nar-path=" #$nar-path)
2556 (string-append "--listen=" #$host)
2557 #$@(if advertise?
2558 #~("--advertise")
2559 #~())
2560 #$@(if workers
2561 #~((string-append "--workers="
2562 #$(number->string
2563 workers)))
2564 #~())
2565 #$@(if ttl
2566 #~((string-append "--ttl="
2567 #$(number->string ttl)
2568 "s"))
2569 #~())
2570 #$@(if negative-ttl
2571 #~((string-append "--negative-ttl="
2572 #$(number->string negative-ttl)
2573 "s"))
2574 #~())
2575 #$@(if cache
2576 #~((string-append "--cache=" #$cache)
2577 #$(string-append
2578 "--cache-bypass-threshold="
2579 (number->string
2580 cache-bypass-threshold)))
2581 #~())))
2582 (options #~(#:environment-variables
2583 ;; Make sure we run in a UTF-8 locale so we can produce
2584 ;; nars for packages that contain UTF-8 file names such
2585 ;; as 'nss-certs'. See <https://bugs.gnu.org/26948>.
2586 (list (string-append "GUIX_LOCPATH="
2587 #$(libc-utf8-locales-for-target)
2588 "/lib/locale")
2589 "LC_ALL=en_US.utf8")
2590 #:log-file "/var/log/guix-publish.log"))
2591 (endpoints #~(let ((ai (false-if-exception
2592 (getaddrinfo #$host
2593 #$(number->string port)
2594 AI_NUMERICSERV))))
2595 (if (pair? ai)
2596 (list (endpoint (addrinfo:addr (car ai))))
2597 '()))))
2598 (list (shepherd-service
2599 (provision '(guix-publish))
2600 (requirement `(user-processes
2601 guix-daemon
2602 ,@(if advertise? '(avahi-daemon) '())))
2603
2604 ;; Use lazy socket activation unless ADVERTISE? is true: in that
2605 ;; case the process should start right away to advertise itself.
2606 (start #~(make-systemd-constructor
2607 #$command #$endpoints #$@options
2608 #:lazy-start? #$(not advertise?)))
2609 (stop #~(make-systemd-destructor)))))))
2610
2611(define %guix-publish-accounts
2612 (list (user-group (name "guix-publish") (system? #t))
2613 (user-account
2614 (name "guix-publish")
2615 (group "guix-publish")
2616 (system? #t)
2617 (comment "guix publish user")
2618 (home-directory "/var/empty")
2619 (shell (file-append shadow "/sbin/nologin")))))
2620
2621(define (guix-publish-activation config)
2622 (let ((cache (guix-publish-configuration-cache config)))
2623 (if cache
2624 (with-imported-modules '((guix build utils))
2625 #~(begin
2626 (use-modules (guix build utils))
2627
2628 (mkdir-p #$cache)
2629 (let* ((pw (getpw "guix-publish"))
2630 (uid (passwd:uid pw))
2631 (gid (passwd:gid pw)))
2632 (chown #$cache uid gid))))
2633 #t)))
2634
2635(define guix-publish-service-type
2636 (service-type (name 'guix-publish)
2637 (extensions
2638 (list (service-extension shepherd-root-service-type
2639 guix-publish-shepherd-service)
2640 (service-extension account-service-type
2641 (const %guix-publish-accounts))
2642 (service-extension activation-service-type
2643 guix-publish-activation)))
2644 (default-value (guix-publish-configuration))
2645 (description
2646 "Add a Shepherd service running @command{guix publish}, a
2647command that allows you to share pre-built binaries with others over HTTP.")))
2648
2649
2650;;;
2651;;; Udev.
2652;;;
2653
2654(define-record-type* <udev-configuration>
2655 udev-configuration make-udev-configuration
2656 udev-configuration?
2657 (udev udev-configuration-udev ;file-like
2658 (default eudev))
2659 (debug? udev-configuration-debug? ;boolean
2660 (default #f))
2661 (rules udev-configuration-rules ;list of file-like
2662 (default '()))
2663 (hardware udev-configuration-hardware ;list of file-like
2664 (default '())))
2665
2666(define (udev-configurations-union subdirectory packages)
2667 "Return the union of the lib/udev/SUBDIRECTORY directories found in each
2668item of PACKAGES."
2669 (define build
2670 (with-imported-modules '((guix build union)
2671 (guix build utils))
2672 #~(begin
2673 (use-modules (guix build union)
2674 (guix build utils)
2675 (srfi srfi-1)
2676 (srfi srfi-26))
2677
2678 (define %standard-locations
2679 '(#$(string-append "/lib/udev/" subdirectory)
2680 #$(string-append "/libexec/udev/" subdirectory)))
2681
2682 (define (configuration-sub-directory directory)
2683 ;; Return the sub-directory of DIRECTORY containing udev
2684 ;; configurations, or #f if none was found.
2685 (find directory-exists?
2686 (map (cut string-append directory <>) %standard-locations)))
2687
2688 (union-build #$output
2689 (filter-map configuration-sub-directory '#$packages)))))
2690
2691 (computed-file (string-append "udev-" subdirectory) build))
2692
2693(define (udev-rules-union packages)
2694 "Return the union of the lib/udev/rules.d directories found in each
2695item of PACKAGES."
2696 (udev-configurations-union "rules.d" packages))
2697
2698(define (udev-configuration-file subdirectory file-name contents)
2699 "Return a directory with a udev configuration file FILE-NAME containing CONTENTS."
2700 (file->udev-configuration-file subdirectory file-name (plain-file file-name contents)))
2701
2702(define (udev-rule file-name contents)
2703 "Return a directory with a udev rule file FILE-NAME containing CONTENTS."
2704 (udev-configuration-file "rules.d" file-name contents))
2705
2706(define (udev-hardware file-name contents)
2707 "Return a directory with a udev hardware file FILE-NAME containing CONTENTS."
2708 (udev-configuration-file "hwdb.d" file-name contents))
2709
2710(define (file->udev-configuration-file subdirectory file-name file)
2711 "Return a directory with a udev configuration file FILE-NAME which is a copy
2712 of FILE."
2713 (computed-file file-name
2714 (with-imported-modules '((guix build utils))
2715 #~(begin
2716 (use-modules (guix build utils))
2717
2718 (define configuration-directory
2719 (string-append #$output
2720 "/lib/udev/"
2721 #$subdirectory))
2722
2723 (define file-copy-dest
2724 (string-append configuration-directory "/" #$file-name))
2725
2726 (mkdir-p configuration-directory)
2727 (copy-file #$file file-copy-dest)))))
2728
2729(define (file->udev-rule file-name file)
2730 "Return a directory with a udev rule file FILE-NAME which is a copy of FILE."
2731 (file->udev-configuration-file "rules.d" file-name file))
2732
2733(define (file->udev-hardware file-name file)
2734 "Return a directory with a udev hardware file FILE-NAME which is a copy of FILE."
2735 (file->udev-configuration-file "hwdb.d" file-name file))
2736
2737(define kvm-udev-rule
2738 ;; Return a directory with a udev rule that changes the group of /dev/kvm to
2739 ;; "kvm" and makes it #o660. Apparently QEMU-KVM used to ship this rule,
2740 ;; but now we have to add it by ourselves.
2741
2742 ;; Build users are part of the "kvm" group, so we can fearlessly make
2743 ;; /dev/kvm 660 (see <http://bugs.gnu.org/18994>, for background.)
2744 (udev-rule "90-kvm.rules"
2745 "KERNEL==\"kvm\", GROUP=\"kvm\", MODE=\"0660\"\n"))
2746
2747(define (udev-shepherd-service config)
2748 ;; Return a <shepherd-service> for UDEV with RULES.
2749 (let ((udev (udev-configuration-udev config)))
2750 (list
2751 (shepherd-service
2752 (provision '(udev))
2753
2754 ;; Udev needs /dev to be a 'devtmpfs' mount so that new device nodes can
2755 ;; be added: see
2756 ;; <http://www.linuxfromscratch.org/lfs/view/development/chapter07/udev.html>.
2757 (requirement '(root-file-system))
2758
2759 (documentation "Populate the /dev directory, dynamically.")
2760 (start
2761 (with-imported-modules (source-module-closure
2762 '((gnu build linux-boot)))
2763 #~(lambda ()
2764 (define udevd
2765 ;; 'udevd' from eudev.
2766 #$(file-append udev "/sbin/udevd"))
2767
2768 (define (wait-for-udevd)
2769 ;; Wait until someone's listening on udevd's control
2770 ;; socket.
2771 (let ((sock (socket AF_UNIX SOCK_SEQPACKET 0)))
2772 (let try ()
2773 (catch 'system-error
2774 (lambda ()
2775 (connect sock PF_UNIX "/run/udev/control")
2776 (close-port sock))
2777 (lambda args
2778 (format #t "waiting for udevd...~%")
2779 (usleep 500000)
2780 (try))))))
2781
2782 ;; Allow udev to find the modules.
2783 (setenv "LINUX_MODULE_DIRECTORY"
2784 "/run/booted-system/kernel/lib/modules")
2785
2786 (let* ((kernel-release
2787 (utsname:release (uname)))
2788 (linux-module-directory
2789 (getenv "LINUX_MODULE_DIRECTORY"))
2790 (directory
2791 (string-append linux-module-directory "/"
2792 kernel-release))
2793 (old-umask (umask #o022)))
2794 ;; If we're in a container, DIRECTORY might not exist,
2795 ;; for instance because the host runs a different
2796 ;; kernel. In that case, skip it; we'll just miss a few
2797 ;; nodes like /dev/fuse.
2798 (when (file-exists? directory)
2799 (make-static-device-nodes directory))
2800 (umask old-umask))
2801
2802 (let ((pid (fork+exec-command
2803 (list udevd
2804 #$@(if (udev-configuration-debug? config)
2805 '("--debug")
2806 '()))
2807 #:environment-variables
2808 (cons*
2809 (string-append "LINUX_MODULE_DIRECTORY="
2810 (getenv "LINUX_MODULE_DIRECTORY"))
2811 (default-environment-variables))))
2812 (udevadm #$(file-append udev "/bin/udevadm")))
2813 ;; Wait until udevd is up and running. This appears to
2814 ;; be needed so that the events triggered below are
2815 ;; actually handled.
2816 (wait-for-udevd)
2817
2818 ;; Trigger device and subsystem nodes creation. Note that as
2819 ;; of eudev v3.2.14, it is missing the '--type=all' found in
2820 ;; systemd.
2821 (system* udevadm "trigger" "--action=add" "--type=devices")
2822 (system* udevadm "trigger" "--action=add" "--type=subsystems")
2823
2824 ;; Wait for things to settle down.
2825 (system* udevadm "settle")
2826
2827 pid))))
2828 (stop #~(make-kill-destructor))
2829
2830 ;; When halting the system, 'udev' is actually killed by
2831 ;; 'user-processes', i.e., before its own 'stop' method was called.
2832 ;; Thus, make sure it is not respawned.
2833 (respawn? #f)
2834 ;; We need additional modules.
2835 (modules `((gnu build linux-boot) ;'make-static-device-nodes'
2836 ,@%default-modules))))))
2837
2838(define udev.conf
2839 (computed-file "udev.conf"
2840 #~(call-with-output-file #$output
2841 (lambda (port)
2842 (format port "udev_rules=\"/etc/udev/rules.d\"~%")))))
2843
2844(define (udev-etc config)
2845 (match-record config <udev-configuration>
2846 (udev rules hardware)
2847 (let* ((hardware
2848 (udev-configurations-union "hwdb.d" (cons* udev hardware)))
2849 (hwdb.bin
2850 (computed-file
2851 "hwdb.bin"
2852 (with-imported-modules '((guix build utils))
2853 #~(begin
2854 (use-modules (guix build utils))
2855 (setenv "UDEV_HWDB_PATH" #$hardware)
2856 (invoke #+(file-append udev "/bin/udevadm")
2857 "hwdb"
2858 "--update"
2859 "-o" #$output))))))
2860 `(("udev"
2861 ,(file-union "udev"
2862 `(("udev.conf" ,udev.conf)
2863 ("rules.d"
2864 ,(udev-rules-union (cons* udev kvm-udev-rule
2865 rules)))
2866 ("hwdb.bin" ,hwdb.bin))))))))
2867
2868(define udev-service-type
2869 (service-type (name 'udev)
2870 (extensions
2871 (list (service-extension shepherd-root-service-type
2872 udev-shepherd-service)
2873 (service-extension etc-service-type udev-etc)))
2874 (compose concatenate) ;concatenate the list of rules
2875 (extend (lambda (config extensions)
2876 (let ((initial-rules
2877 (udev-configuration-rules config))
2878 (initial-hardware
2879 (udev-configuration-hardware config)))
2880 (udev-configuration
2881 (inherit config)
2882 (rules (append initial-rules extensions))
2883 (hardware (append initial-hardware extensions))))))
2884 (default-value (udev-configuration))
2885 (description
2886 "Run @command{udev}, which populates the @file{/dev}
2887directory dynamically. Get extra rules from the packages listed in the
2888@code{rules} field of its value, @code{udev-configuration} object.")))
2889
2890(define-deprecated (udev-service #:key (udev eudev) (rules '()))
2891 udev-service-type
2892 "Run @var{udev}, which populates the @file{/dev} directory dynamically. Get
2893extra rules from the packages listed in @var{rules}."
2894 (service udev-service-type
2895 (udev-configuration (udev udev) (rules rules))))
2896
2897(define* (udev-rules-service name rules #:key (groups '()))
2898 "Return a service that extends udev-service-type with RULES and
2899account-service-type with GROUPS as system groups. This works by creating a
2900singleton service type NAME-udev-rules, of which the returned service is an
2901instance."
2902 (let* ((name (symbol-append name '-udev-rules))
2903 (account-extension
2904 (const (map (lambda (group)
2905 (user-group (name group) (system? #t)))
2906 groups)))
2907 (udev-extension (const (list rules)))
2908 (type (service-type
2909 (name name)
2910 (extensions (list
2911 (service-extension
2912 account-service-type account-extension)
2913 (service-extension
2914 udev-service-type udev-extension)))
2915 (description "This service adds udev rules."))))
2916 (service type #f)))
2917
2918(define (udev-hardware-service name hardware-files)
2919 "Return a service that extends udev-service-type with HARDWARE-FILES, named
2920NAME-udev-hardware."
2921 (let* ((name (symbol-append name '-udev-hardware))
2922 (udev-extension (const (list hardware-files)))
2923 (type (service-type
2924 (name name)
2925 (extensions (list
2926 (service-extension
2927 udev-service-type udev-extension)))
2928 (description "This service adds udev hardware files."))))
2929 (service type #f)))
2930
2931(define (swap-space->shepherd-service-name space)
2932 (let ((target (swap-space-target space)))
2933 (symbol-append 'swap-
2934 (string->symbol
2935 (cond ((uuid? target)
2936 (uuid->string target))
2937 ((file-system-label? target)
2938 (file-system-label->string target))
2939 (else
2940 target))))))
2941
2942; TODO Remove after deprecation
2943(define (swap-deprecated->shepherd-service-name sdep)
2944 (symbol-append 'swap-
2945 (string->symbol
2946 (cond ((uuid? sdep)
2947 (string-take (uuid->string sdep) 6))
2948 ((file-system-label? sdep)
2949 (file-system-label->string sdep))
2950 (else
2951 sdep)))))
2952
2953(define swap->shepherd-service-name
2954 (match-lambda ((? swap-space? space)
2955 (swap-space->shepherd-service-name space))
2956 (sdep
2957 (swap-deprecated->shepherd-service-name sdep))))
2958
2959(define swap-service-type
2960 (shepherd-service-type
2961 'swap
2962 (lambda (swap)
2963 (define requirements
2964 (cond ((swap-space? swap)
2965 (map dependency->shepherd-service-name
2966 (swap-space-dependencies swap)))
2967 ; TODO Remove after deprecation
2968 ((and (string? swap) (string-prefix? "/dev/mapper/" swap))
2969 (list (symbol-append 'device-mapping-
2970 (string->symbol (basename swap)))))
2971 (else
2972 '())))
2973
2974 (define device-lookup
2975 ;; The generic 'find-partition' procedures could return a partition
2976 ;; that's not swap space, but that's unlikely.
2977 (cond ((swap-space? swap)
2978 (let ((target (swap-space-target swap)))
2979 (cond ((uuid? target)
2980 #~(find-partition-by-uuid #$(uuid-bytevector target)))
2981 ((file-system-label? target)
2982 #~(find-partition-by-label
2983 #$(file-system-label->string target)))
2984 (else
2985 target))))
2986 ; TODO Remove after deprecation
2987 ((uuid? swap)
2988 #~(find-partition-by-uuid #$(uuid-bytevector swap)))
2989 ((file-system-label? swap)
2990 #~(find-partition-by-label
2991 #$(file-system-label->string swap)))
2992 (else
2993 swap)))
2994
2995 (with-imported-modules (source-module-closure '((gnu build file-systems)))
2996 (shepherd-service
2997 (provision (list (swap->shepherd-service-name swap)))
2998 (requirement `(,@(if (target-hurd?) '() '(udev)) ,@requirements))
2999 (documentation "Enable the given swap space.")
3000 (modules `((gnu build file-systems)
3001 ,@%default-modules))
3002 (start #~(lambda ()
3003 (let ((device #$device-lookup))
3004 (and device
3005 (begin
3006 #$(if (target-hurd?)
3007 #~(system* "swapon" device)
3008 #~(restart-on-EINTR
3009 (swapon device
3010 #$(if (swap-space? swap)
3011 (swap-space->flags-bit-mask
3012 swap)
3013 0))))
3014 #t)))))
3015 (stop #~(lambda _
3016 (let ((device #$device-lookup))
3017 (when device
3018 #$(if (target-hurd?)
3019 #~(system* "swapoff" device)
3020 #~(restart-on-EINTR (swapoff device))))
3021 #f)))
3022 (respawn? #f))))
3023 (description "Turn on the virtual memory swap area.")))
3024
3025(define (swap-service swap)
3026 "Return a service that uses @var{swap} as a swap space."
3027 (service swap-service-type swap))
3028
3029(define %default-gpm-options
3030 ;; Default options for GPM.
3031 '("-m" "/dev/input/mice" "-t" "ps2"))
3032
3033(define-record-type* <gpm-configuration>
3034 gpm-configuration make-gpm-configuration gpm-configuration?
3035 (gpm gpm-configuration-gpm ;file-like
3036 (default gpm))
3037 (options gpm-configuration-options ;list of strings
3038 (default %default-gpm-options)))
3039
3040(define (gpm-shepherd-service config)
3041 (match-record config <gpm-configuration>
3042 (gpm options)
3043 (list (shepherd-service
3044 (requirement '(user-processes udev))
3045 (provision '(gpm))
3046 ;; 'gpm' runs in the background and sets a PID file.
3047 ;; Note that it requires running as "root".
3048 (start #~(make-forkexec-constructor
3049 (list #$(file-append gpm "/sbin/gpm")
3050 #$@options)
3051 #:pid-file "/var/run/gpm.pid"
3052 #:pid-file-timeout 3))
3053 (stop #~(lambda (_)
3054 ;; Return #f if successfully stopped.
3055 (not (zero? (system* #$(file-append gpm "/sbin/gpm")
3056 "-k")))))))))
3057
3058(define gpm-service-type
3059 (service-type (name 'gpm)
3060 (extensions
3061 (list (service-extension shepherd-root-service-type
3062 gpm-shepherd-service)))
3063 (default-value (gpm-configuration))
3064 (description
3065 "Run GPM, the general-purpose mouse daemon, with the given
3066command-line options. GPM allows users to use the mouse in the console,
3067notably to select, copy, and paste text. The default options use the
3068@code{ps2} protocol, which works for both USB and PS/2 mice.")))
3069
3070
3071(define-record-type* <kmscon-configuration>
3072 kmscon-configuration make-kmscon-configuration
3073 kmscon-configuration?
3074 (kmscon kmscon-configuration-kmscon
3075 (default kmscon))
3076 (virtual-terminal kmscon-configuration-virtual-terminal)
3077 (login-program kmscon-configuration-login-program
3078 (default (file-append shadow "/bin/login")))
3079 (login-arguments kmscon-configuration-login-arguments
3080 (default '("-p")))
3081 (auto-login kmscon-configuration-auto-login
3082 (default #f))
3083 (hardware-acceleration? kmscon-configuration-hardware-acceleration?
3084 (default #f)) ; #t causes failure
3085 (font-engine kmscon-configuration-font-engine
3086 (default "pango"))
3087 (font-size kmscon-configuration-font-size
3088 (default 12))
3089 (keyboard-layout kmscon-configuration-keyboard-layout
3090 (default #f))) ; #f | <keyboard-layout>
3091
3092(define kmscon-service-type
3093 (shepherd-service-type
3094 'kmscon
3095 (lambda (config)
3096 (let ((kmscon (kmscon-configuration-kmscon config))
3097 (virtual-terminal (kmscon-configuration-virtual-terminal config))
3098 (login-program (kmscon-configuration-login-program config))
3099 (login-arguments (kmscon-configuration-login-arguments config))
3100 (auto-login (kmscon-configuration-auto-login config))
3101 (hardware-acceleration? (kmscon-configuration-hardware-acceleration? config))
3102 (font-engine (kmscon-configuration-font-engine config))
3103 (font-size (kmscon-configuration-font-size config))
3104 (keyboard-layout (kmscon-configuration-keyboard-layout config)))
3105
3106 (define kmscon-command
3107 #~(list
3108 #$(file-append kmscon "/bin/kmscon") "--login"
3109 "--vt" #$virtual-terminal
3110 "--no-switchvt" ;Prevent a switch to the virtual terminal.
3111 "--font-engine" #$font-engine
3112 "--font-size" #$(number->string font-size)
3113 #$@(if keyboard-layout
3114 (let* ((layout (keyboard-layout-name keyboard-layout))
3115 (variant (keyboard-layout-variant keyboard-layout))
3116 (model (keyboard-layout-model keyboard-layout))
3117 (options (keyboard-layout-options keyboard-layout)))
3118 `("--xkb-layout" ,layout
3119 ,@(if variant `("--xkb-variant" ,variant) '())
3120 ,@(if model `("--xkb-model" ,model) '())
3121 ,@(if (null? options)
3122 '()
3123 `("--xkb-options" ,(string-join options ",")))))
3124 '())
3125 #$@(if hardware-acceleration? '("--hwaccel") '())
3126 "--login" "--"
3127 #$login-program #$@login-arguments
3128 #$@(if auto-login
3129 #~(#$auto-login)
3130 #~())))
3131
3132 (shepherd-service
3133 (documentation "kmscon virtual terminal")
3134 (requirement '(user-processes udev dbus-system))
3135 (provision (list (symbol-append 'term- (string->symbol virtual-terminal))))
3136 (start #~(make-forkexec-constructor
3137 #$kmscon-command
3138
3139 ;; The installer needs to be able to display glyphs from
3140 ;; various scripts, so give it access to unifont.
3141 ;; TODO: Make this configurable.
3142 #:environment-variables
3143 (list (string-append "XDG_DATA_DIRS="
3144 #+font-gnu-unifont "/share"))))
3145 (stop #~(make-kill-destructor)))))
3146 (description "Start the @command{kmscon} virtual terminal emulator for the
3147Linux @dfn{kernel mode setting} (KMS).")))
3148
3149
3150;;;
3151;;; Static networking.
3152;;;
3153
3154(define (ipv6-address? str)
3155 "Return true if STR denotes an IPv6 address."
3156 (false-if-exception (->bool (inet-pton AF_INET6 str))))
3157
3158(define-compile-time-procedure (assert-valid-address (address string?))
3159 "Ensure ADDRESS has a valid netmask."
3160 (unless (cidr->netmask address)
3161 (raise
3162 (make-compound-condition
3163 (formatted-message (G_ "address '~a' lacks a network mask")
3164 address)
3165 (condition (&error-location
3166 (location
3167 (source-properties->location procedure-call-location))))
3168 (condition (&fix-hint
3169 (hint (format #f (G_ "\
3170Write, say, @samp{\"~a/24\"} for a 24-bit network mask.")
3171 address)))))))
3172 address)
3173
3174(define (mac-address? str)
3175 "Return true if STR is a valid MAC address."
3176 (let ((pattern (make-regexp "^([0-9A-Fa-f]{2}:?){6}$")))
3177 (false-if-exception (vector? (regexp-exec pattern str)))))
3178
3179(define-compile-time-procedure (assert-network-link-mac-address (value identity))
3180 (cond
3181 ((eq? value #f) value)
3182 ((and (string? value) (mac-address? value)) value)
3183 (else (raise
3184 (make-compound-condition
3185 (formatted-message (G_ "~s: invalid MAC address")
3186 value)
3187 (condition (&error-location
3188 (location (source-properties->location procedure-call-location)))))))))
3189
3190(define-with-syntax-properties (assert-network-link-type (value properties))
3191 (match value
3192 (#f value)
3193 ((? symbol?) value)
3194 (_
3195 (raise
3196 (make-compound-condition
3197 (formatted-message (G_ "~s: invalid link type") value)
3198 (condition (&error-location
3199 (location (source-properties->location properties)))))))))
3200
3201(define-with-syntax-properties (assert-network-route-scope (value properties))
3202 (if (memq value '(universe site link host nowhere))
3203 value
3204 (raise
3205 (make-compound-condition
3206 (formatted-message (G_ "~s: invalid network scope") value)
3207 (condition (&error-location
3208 (location (source-properties->location properties))))))))
3209
3210(define-record-type* <static-networking>
3211 static-networking make-static-networking
3212 static-networking?
3213 (addresses static-networking-addresses) ;list of <network-address>
3214 (links static-networking-links (default '())) ;list of <network-link>
3215 (routes static-networking-routes (default '())) ;list of <network-routes>
3216 (provision static-networking-provision
3217 (default '(networking)))
3218 (requirement static-networking-requirement
3219 (default '(udev)))
3220 (name-servers static-networking-name-servers ;FIXME: doesn't belong here
3221 (default '())))
3222
3223(define-record-type* <network-address>
3224 network-address make-network-address
3225 network-address?
3226 (device network-address-device) ;string--e.g., "en01"
3227 (value network-address-value ;string--CIDR notation
3228 (sanitize assert-valid-address))
3229 (ipv6? network-address-ipv6? ;Boolean
3230 (thunked)
3231 (default
3232 (ipv6-address? (cidr->ip (network-address-value this-record))))))
3233
3234(define-record-type* <network-link>
3235 network-link make-network-link
3236 network-link?
3237 (name network-link-name
3238 (default #f)) ;string or #f --e.g, "v0p0"
3239 (type network-link-type
3240 (sanitize assert-network-link-type)
3241 (default #f)) ;symbol or #f--e.g.,'veth, 'bond
3242 (mac-address network-link-mac-address
3243 (sanitize assert-network-link-mac-address)
3244 (default #f))
3245 (arguments network-link-arguments)) ;list
3246
3247(define-record-type* <network-route>
3248 network-route make-network-route
3249 network-route?
3250 (destination network-route-destination)
3251 (source network-route-source (default #f))
3252 (device network-route-device (default #f))
3253 (ipv6? network-route-ipv6? (thunked)
3254 (default
3255 (or (ipv6-address? (network-route-destination this-record))
3256 (and=> (network-route-gateway this-record)
3257 ipv6-address?))))
3258 (gateway network-route-gateway (default #f))
3259 (scope network-route-scope
3260 (default 'universe)
3261 (sanitize assert-network-route-scope)))
3262
3263(eval-when (expand load eval)
3264 (define* (cidr->netmask str #:optional (family AF_INET))
3265 "Given @var{str}, a string in CIDR notation (e.g., \"1.2.3.4/24\"), return
3266the netmask as a string like \"255.255.255.0\"."
3267 (match (string-split str #\/)
3268 ((ip (= string->number bits))
3269 (let ((mask (ash (- (expt 2 bits) 1)
3270 (- (if (= family AF_INET6) 128 32)
3271 bits))))
3272 (inet-ntop family mask)))
3273 (_ #f))))
3274
3275(define (cidr->ip str)
3276 "Strip the netmask bit of @var{str}, a CIDR-notation IP/netmask address."
3277 (match (string-split str #\/)
3278 ((or (ip _) (ip))
3279 ip)))
3280
3281(define* (ip+netmask->cidr ip netmask #:optional (family AF_INET))
3282 "Return the CIDR notation (a string) for @var{ip} and @var{netmask}, two
3283@var{family} address strings, where @var{family} is @code{AF_INET} or
3284@code{AF_INET6}."
3285 (let* ((netmask (inet-pton family netmask))
3286 (bits (logcount netmask)))
3287 (string-append ip "/" (number->string bits))))
3288
3289(define (static-networking->hurd-pfinet-options config)
3290 "Return command-line options for the Hurd's pfinet translator corresponding
3291to CONFIG."
3292 (unless (null? (static-networking-links config))
3293 ;; XXX: Presumably this is not supported, or perhaps could be approximated
3294 ;; by running separate pfinet instances in some cases?
3295 (warning (G_ "network links are currently ignored on GNU/Hurd~%")))
3296
3297 (match (static-networking-addresses config)
3298 ((and addresses (first _ ...))
3299 `("--ipv6" "/servers/socket/26"
3300 "--interface" ,(string-append "/dev/" (network-address-device first))
3301 ,@(append-map (lambda (address)
3302 `(,(if (network-address-ipv6? address)
3303 "--address6"
3304 "--address")
3305 ,(cidr->ip (network-address-value address))
3306 ,@(match (cidr->netmask (network-address-value address)
3307 (if (network-address-ipv6? address)
3308 AF_INET6
3309 AF_INET))
3310 (#f '())
3311 (mask (list "--netmask" mask)))))
3312 addresses)
3313 ,@(append-map (lambda (route)
3314 (match route
3315 (($ <network-route> "default" #f device _ gateway)
3316 (if (network-route-ipv6? route)
3317 `("--gateway6" ,gateway)
3318 `("--gateway" ,gateway)))
3319 (($ <network-route> destination)
3320 (warning (G_ "ignoring network route for '~a'~%")
3321 destination)
3322 '())))
3323 (static-networking-routes config))))))
3324
3325(define (network-set-up/hurd config)
3326 "Set up networking for the Hurd."
3327 ;; The Hurd implements SIOCGIFADDR and other old-style ioctls, but the only
3328 ;; way to set up IPv6 is by starting pfinet with the right options.
3329 (if (equal? (static-networking-provision config) '(loopback))
3330 (program-file "set-up-pflocal" #~(begin 'nothing-to-do! #t))
3331 (program-file "set-up-pfinet"
3332 (with-imported-modules '((guix build utils))
3333 #~(begin
3334 (use-modules (guix build utils)
3335 (ice-9 format))
3336
3337 ;; TODO: Do that without forking.
3338 (let ((options '#$(static-networking->hurd-pfinet-options
3339 config)))
3340 (format #t "starting '~a~{ ~s~}'~%"
3341 #$(file-append hurd "/hurd/pfinet")
3342 options)
3343 (apply invoke #$(file-append hurd "/bin/settrans")
3344 "--active"
3345 "--create"
3346 "--keep-active"
3347 "/servers/socket/2"
3348 #$(file-append hurd "/hurd/pfinet")
3349 options)))))))
3350
3351(define (network-tear-down/hurd config)
3352 (program-file "tear-down-pfinet"
3353 (with-imported-modules '((guix build utils))
3354 #~(begin
3355 (use-modules (guix build utils))
3356
3357 ;; Forcefully terminate pfinet. XXX: In theory this
3358 ;; should just undo the addresses and routes of CONFIG;
3359 ;; this could be done using ioctls like SIOCDELRT, but
3360 ;; these are IPv4-only; another option would be to use
3361 ;; fsysopts but that seems to crash pfinet.
3362 (invoke #$(file-append hurd "/bin/settrans") "-fg"
3363 "/servers/socket/2")
3364 #f))))
3365
3366(define (network-set-up/linux config)
3367 (define max-set-up-duration
3368 ;; Maximum waiting time in seconds for devices to be up.
3369 60)
3370
3371 (define (route-scope->constant scope)
3372 (match scope
3373 ('universe #~RT_SCOPE_UNIVERSE)
3374 ('site #~RT_SCOPE_SITE)
3375 ('link #~RT_SCOPE_LINK)
3376 ('host #~RT_SCOPE_HOST)
3377 ('nowhere #~RT_SCOPE_NOWHERE)))
3378
3379 (match-record config <static-networking>
3380 (addresses links routes)
3381 (program-file "set-up-network"
3382 (with-extensions (list guile-netlink)
3383 #~(begin
3384 (use-modules (ip addr) (ip link) (ip route)
3385 ((netlink constant)
3386 #:select (RT_SCOPE_UNIVERSE
3387 RT_SCOPE_LINK))
3388 (srfi srfi-1)
3389 (ice-9 format)
3390 (ice-9 match))
3391
3392 (define (match-link-by field-accessor value)
3393 (fold (lambda (link result)
3394 (if (equal? (field-accessor link) value)
3395 link
3396 result))
3397 #f
3398 (get-links)))
3399
3400 (define (alist->keyword+value alist)
3401 (fold (match-lambda*
3402 (((k . v) r)
3403 (cons* (symbol->keyword k) v r))) '() alist))
3404
3405 ;; FIXME: It is interesting that "modprobe bonding" creates an
3406 ;; interface bond0 straigt away. If we won't have bonding
3407 ;; module, and execute `ip link add name bond0 type bond' we
3408 ;; will get
3409 ;;
3410 ;; RTNETLINK answers: File exists
3411 ;;
3412 ;; This breaks our configuration if we want to
3413 ;; use `bond0' name. Create (force modprobe
3414 ;; bonding) and delete the interface to free up
3415 ;; bond0 name.
3416 #$(let lp ((links links))
3417 (cond
3418 ((null? links) #f)
3419 ((and (network-link? (car links))
3420 ;; Type is not mandatory
3421 (false-if-exception
3422 (eq? (network-link-type (car links)) 'bond)))
3423 #~(begin
3424 (false-if-exception (link-add "bond0" "bond"))
3425 (link-del "bond0")))
3426 (else (lp (cdr links)))))
3427
3428 #$@(map (match-lambda
3429 (($ <network-link> name type mac-address arguments)
3430 (cond
3431 ;; Create a new interface
3432 ((and (string? name) (symbol? type))
3433 #~(begin
3434 (link-add #$name (symbol->string '#$type) #:type-args '#$arguments)
3435 ;; XXX: If we add routes, addresses must be
3436 ;; already assigned, and interfaces must be
3437 ;; up. It doesn't matter if they won't have
3438 ;; carrier or anything.
3439 (link-set #$name #:up #t)))
3440
3441 ;; Amend an existing interface
3442 ((and (string? name)
3443 (eq? type #f))
3444 #~(let ((link (match-link-by link-name #$name)))
3445 (if link
3446 (apply link-set
3447 (link-id link)
3448 (alist->keyword+value '#$arguments))
3449 (format #t "Interface with name '~a' not found~%"
3450 #$name))))
3451 ((string? mac-address)
3452 #~(let ((link (match-link-by link-addr #$mac-address)))
3453 (if link
3454 (apply link-set
3455 (link-id link)
3456 (alist->keyword+value '#$arguments))
3457 (format #t "Interface with mac-address '~a' not found~%"
3458 #$mac-address)))))))
3459 links)
3460
3461 ;; 'wait-for-link' below could wait forever when
3462 ;; passed a non-existent device. To ensure timely
3463 ;; completion, install an alarm.
3464 (alarm #$max-set-up-duration)
3465
3466 #$@(map (lambda (address)
3467 #~(let ((device
3468 #$(network-address-device address)))
3469 ;; Before going any further, wait for the
3470 ;; device to show up.
3471 (format #t "Waiting for network device '~a'...~%"
3472 device)
3473 (wait-for-link device)
3474
3475 (addr-add #$(network-address-device address)
3476 #$(network-address-value address)
3477 #:ipv6?
3478 #$(network-address-ipv6? address))
3479 ;; FIXME: loopback?
3480 (link-set #$(network-address-device address)
3481 #:multicast-on #t
3482 #:up #t)))
3483 addresses)
3484
3485 #$@(map (lambda (route)
3486 #~(route-add #$(network-route-destination route)
3487 #:device
3488 #$(network-route-device route)
3489 #:ipv6?
3490 #$(network-route-ipv6? route)
3491 #:via
3492 #$(network-route-gateway route)
3493 #:src
3494 #$(network-route-source route)
3495 #:scope
3496 #$(route-scope->constant
3497 (network-route-scope
3498 route))))
3499 routes)
3500 #t)))))
3501
3502(define (network-tear-down/linux config)
3503 (match-record config <static-networking>
3504 (addresses links routes)
3505 (program-file "tear-down-network"
3506 (with-extensions (list guile-netlink)
3507 #~(begin
3508 (use-modules (ip addr) (ip link) (ip route)
3509 (netlink error)
3510 (srfi srfi-34))
3511
3512 (define-syntax-rule (false-if-netlink-error exp)
3513 (guard (c ((netlink-error? c) #f))
3514 exp))
3515
3516 ;; Wrap calls in 'false-if-netlink-error' so this
3517 ;; script goes as far as possible undoing the effects
3518 ;; of "set-up-network".
3519
3520 #$@(map (lambda (route)
3521 #~(false-if-netlink-error
3522 (route-del #$(network-route-destination route)
3523 #:device
3524 #$(network-route-device route)
3525 #:ipv6?
3526 #$(network-route-ipv6? route)
3527 #:via
3528 #$(network-route-gateway route)
3529 #:src
3530 #$(network-route-source route))))
3531 routes)
3532
3533 ;; Cleanup addresses first, they might be assigned to
3534 ;; created bonds, vlans or bridges.
3535 #$@(map (lambda (address)
3536 #~(false-if-netlink-error
3537 (addr-del #$(network-address-device
3538 address)
3539 #$(network-address-value address)
3540 #:ipv6?
3541 #$(network-address-ipv6? address))))
3542 addresses)
3543
3544 ;; It is now safe to delete some links
3545 #$@(map (match-lambda
3546 (($ <network-link> name type mac-address arguments)
3547 (cond
3548 ;; We delete interfaces that were created
3549 ((and (string? name) (symbol? type))
3550 #~(false-if-netlink-error
3551 (link-del #$name)))
3552 (else #t))))
3553 links)
3554 #f)))))
3555
3556(define (static-networking-shepherd-service config)
3557 (match-record config <static-networking>
3558 (addresses links routes provision requirement name-servers)
3559 (let ((loopback? (and provision (memq 'loopback provision))))
3560 (shepherd-service
3561
3562 (documentation
3563 "Bring up the networking interface using a static IP address.")
3564 (requirement requirement)
3565 (provision provision)
3566
3567 (start #~(lambda _
3568 ;; Return #t if successfully started.
3569 (zero? (system*
3570 #$(let-system (system target)
3571 (if (string-contains (or target system) "-linux")
3572 (network-set-up/linux config)
3573 (network-set-up/hurd config)))))))
3574 (stop #~(lambda _
3575 ;; Return #f is successfully stopped.
3576 (zero? (system*
3577 #$(let-system (system target)
3578 (if (string-contains (or target system) "-linux")
3579 (network-tear-down/linux config)
3580 (network-tear-down/hurd config)))))))
3581 (respawn? #f)))))
3582
3583(define (static-networking-shepherd-services networks)
3584 (map static-networking-shepherd-service networks))
3585
3586(define (static-networking-etc-files interfaces)
3587 "Return a /etc/resolv.conf entry for INTERFACES or the empty list."
3588 (match (delete-duplicates
3589 (append-map static-networking-name-servers
3590 interfaces))
3591 (()
3592 '())
3593 ((name-servers ...)
3594 (let ((content (string-join
3595 (map (cut string-append "nameserver " <>)
3596 name-servers)
3597 "\n" 'suffix)))
3598 `(("resolv.conf"
3599 ,(plain-file "resolv.conf"
3600 (string-append "\
3601# Generated by 'static-networking-service'.\n"
3602 content))))))))
3603
3604(define static-networking-service-type
3605 ;; The service type for statically-defined network interfaces.
3606 (service-type (name 'static-networking)
3607 (extensions
3608 (list
3609 (service-extension shepherd-root-service-type
3610 static-networking-shepherd-services)
3611 (service-extension etc-service-type
3612 static-networking-etc-files)))
3613 (compose concatenate)
3614 (extend append)
3615 (description
3616 "Turn up the specified network interfaces upon startup,
3617with the given IP address, gateway, netmask, and so on. The value for
3618services of this type is a list of @code{static-networking} objects, one per
3619network interface.")))
3620
3621(define-deprecated (static-networking-service interface ip
3622 #:key
3623 netmask gateway provision
3624 ;; Most interfaces require udev to be usable.
3625 (requirement '(udev))
3626 (name-servers '()))
3627 static-networking-service-type
3628 "Return a service that starts @var{interface} with address @var{ip}. If
3629@var{netmask} is true, use it as the network mask. If @var{gateway} is true,
3630it must be a string specifying the default network gateway.
3631
3632This procedure can be called several times, one for each network
3633interface of interest. Behind the scenes what it does is extend
3634@code{static-networking-service-type} with additional network interfaces
3635to handle."
3636 (simple-service 'static-network-interface
3637 static-networking-service-type
3638 (list (static-networking
3639 (addresses
3640 (list (network-address
3641 (device interface)
3642 (value (if netmask
3643 (ip+netmask->cidr ip netmask)
3644 ip))
3645 (ipv6? #f))))
3646 (routes
3647 (if gateway
3648 (list (network-route
3649 (destination "default")
3650 (gateway gateway)
3651 (ipv6? #f)))
3652 '()))
3653 (requirement requirement)
3654 (provision (or provision '(networking)))
3655 (name-servers name-servers)))))
3656
3657(define %loopback-static-networking
3658 ;; The loopback device.
3659 (static-networking
3660 (addresses (list (network-address
3661 (device "lo")
3662 (value "127.0.0.1/8"))))
3663 (requirement '())
3664 (provision '(loopback))))
3665
3666(define %qemu-static-networking
3667 ;; Networking configuration for QEMU's user-mode network stack (info "(QEMU)
3668 ;; Using the user mode network stack").
3669 (static-networking
3670 (addresses (list (network-address
3671 (device "eth0")
3672 (value "10.0.2.15/24"))))
3673 (routes (list (network-route
3674 (destination "default")
3675 (gateway "10.0.2.2"))))
3676 (requirement '())
3677 (provision '(networking))
3678 (name-servers '("10.0.2.3"))))
3679
3680
3681;;;
3682;;; greetd-service-type -- minimal and flexible login manager daemon
3683;;;
3684
3685(define-record-type* <greetd-user-session>
3686 greetd-user-session make-greetd-user-session greetd-user-session?
3687 (command greetd-user-session-command (default (file-append bash "/bin/bash")))
3688 (command-args greetd-user-session-command-args (default '("-l")))
3689 (extra-env greetd-user-session-extra-env (default '()))
3690 (xdg-session-type greetd-user-session-xdg-session-type (default "tty"))
3691 (xdg-env? greetd-user-session-xdg-env? (default #t)))
3692
3693(define (make-greetd-user-session-command config)
3694 (match-record config <greetd-user-session>
3695 (command command-args extra-env)
3696 (program-file
3697 "greetd-user-session-command"
3698 #~(begin
3699 (use-modules (ice-9 match))
3700 (for-each (match-lambda ((var . val) (setenv var val)))
3701 (quote (#$@extra-env)))
3702 (apply execl #$command #$command
3703 (list #$@command-args))))))
3704
3705(define (make-greetd-xdg-user-session-command config)
3706 (match-record config <greetd-user-session>
3707 (command command-args extra-env xdg-session-type)
3708 (program-file
3709 "greetd-xdg-user-session-command"
3710 #~(begin
3711 (use-modules (ice-9 match))
3712 (let* ((username (getenv "USER"))
3713 (useruid (passwd:uid (getpwuid username)))
3714 (useruid (number->string useruid)))
3715 (setenv "XDG_SESSION_TYPE" #$xdg-session-type)
3716 (setenv "XDG_RUNTIME_DIR"
3717 (string-append "/run/user/" useruid)))
3718 (for-each (match-lambda ((var . val) (setenv var val)))
3719 (quote (#$@extra-env)))
3720 (apply execl #$command #$command
3721 (list #$@command-args))))))
3722
3723(define-gexp-compiler (greetd-user-session-compiler
3724 (session <greetd-user-session>)
3725 system target)
3726 (lower-object
3727 ((if (greetd-user-session-xdg-env? session)
3728 make-greetd-xdg-user-session-command
3729 make-greetd-user-session-command) session)))
3730
3731(define-record-type* <greetd-agreety-session>
3732 greetd-agreety-session make-greetd-agreety-session greetd-agreety-session?
3733 (agreety greetd-agreety-session-agreety (default greetd))
3734 (command greetd-agreety-session-command
3735 (default (greetd-user-session))
3736 (sanitize warn-greetd-agreety-session-command-type))
3737 (command-args greetd-agreety-command-args
3738 (default #nil)
3739 (sanitize warn-deprecated-greetd-agreety-command-args))
3740 (extra-env greetd-agreety-extra-env
3741 (default #nil)
3742 (sanitize warn-deprecated-greetd-agreety-extra-env))
3743 (xdg-env? greetd-agreety-xdg-env?
3744 (default #nil)
3745 (sanitize warn-deprecated-greetd-agreety-xdg-env?)))
3746
3747(define (warn-deprecated-greetd-agreety-command-args value)
3748 (unless (nil? value)
3749 (warn-about-deprecation
3750 'command-args #f
3751 #:replacement '<greetd-user-seesion>))
3752 value)
3753
3754(define (warn-deprecated-greetd-agreety-extra-env value)
3755 (unless (nil? value)
3756 (warn-about-deprecation
3757 'extra-env #f
3758 #:replacement '<greetd-user-seesion>))
3759 value)
3760
3761(define (warn-deprecated-greetd-agreety-xdg-env? value)
3762 (unless (nil? value)
3763 (warn-about-deprecation
3764 'xdg-env? #f
3765 #:replacement '<greetd-user-seesion>))
3766 value)
3767
3768(define-deprecated/alias greetd-agreety greetd-agreety-session-agreety)
3769(define-deprecated/alias greetd-agreety-command greetd-agreety-session-command)
3770
3771(define (warn-greetd-agreety-session-command-type value)
3772 (unless (greetd-user-session? value)
3773 (warn-about-deprecation
3774 "arbitrary command" #f
3775 #:replacement '<greetd-user-session>))
3776 value)
3777
3778(define (greetd-agreety-session-to-user-session session default-command)
3779 (let ((command (greetd-agreety-session-command session))
3780 (command-args (or (greetd-agreety-command-args session)
3781 (greetd-user-session-command-args default-command)))
3782 (extra-env (or (greetd-agreety-extra-env session)
3783 (greetd-user-session-extra-env default-command)))
3784 (xdg-env? (or (greetd-agreety-xdg-env? session)
3785 (greetd-user-session-xdg-env? default-command))))
3786 (greetd-user-session
3787 (command command)
3788 (command-args command-args)
3789 (extra-env extra-env)
3790 (xdg-env? xdg-env?))))
3791
3792(define-gexp-compiler (greetd-agreety-session-compiler
3793 (session <greetd-agreety-session>)
3794 system target)
3795 (let* ((agreety
3796 (file-append (greetd-agreety-session-agreety session) "/bin/agreety"))
3797 (command
3798 (greetd-agreety-session-command session))
3799 (command
3800 (if (greetd-user-session? command)
3801 command
3802 (greetd-agreety-session-to-user-session
3803 session
3804 (greetd-user-session)))))
3805 (lower-object
3806 (program-file
3807 "agreety-wrapper"
3808 #~(execl #$agreety #$agreety "-c" #$command)))))
3809
3810(define (make-greetd-sway-greeter-command sway sway-config)
3811 (let ((sway-bin (file-append sway "/bin/sway")))
3812 (program-file
3813 "greeter-sway-command"
3814 (with-imported-modules '((guix build utils))
3815 #~(begin
3816 (use-modules (guix build utils))
3817
3818 (let* ((username (getenv "USER"))
3819 (user (getpwnam username))
3820 (useruid (passwd:uid user))
3821 (usergid (passwd:gid user))
3822 (useruid-s (number->string useruid))
3823 ;; /run/user/<greeter-user-uid> won't exist yet
3824 ;; this will contain WAYLAND_DISPLAY socket file
3825 ;; and log-file below
3826 (user-home-dir "/tmp/.greeter-home")
3827 (user-xdg-runtime-dir (string-append user-home-dir "/run"))
3828 (user-xdg-cache-dir (string-append user-home-dir "/cache"))
3829 (log-file (string-append (number->string (getpid)) ".log"))
3830 (log-file (string-append user-home-dir "/" log-file)))
3831 (for-each (lambda (d)
3832 (mkdir-p d)
3833 (chown d useruid usergid) (chmod d #o700))
3834 (list user-home-dir
3835 user-xdg-runtime-dir
3836 user-xdg-cache-dir))
3837 (setenv "HOME" user-home-dir)
3838 (setenv "XDG_CACHE_DIR" user-xdg-cache-dir)
3839 (setenv "XDG_RUNTIME_DIR" user-xdg-runtime-dir)
3840 (dup2 (open-fdes log-file
3841 (logior O_CREAT O_WRONLY O_APPEND) #o640) 1)
3842 (dup2 1 2)
3843 (execl #$sway-bin #$sway-bin "-d" "-c" #$sway-config)))))))
3844
3845(define-record-type* <greetd-wlgreet-configuration>
3846 greetd-wlgreet-configuration make-greetd-wlgreet-configuration
3847 greetd-wlgreet-configuration?
3848 (output-mode greetd-wlgreet-configuration-output-mode (default "all"))
3849 (scale greetd-wlgreet-configuration-scale (default 1))
3850 (background greetd-wlgreet-configuration-background (default '(0 0 0 0.9)))
3851 (headline greetd-wlgreet-configuration-headline (default '(1 1 1 1)))
3852 (prompt greetd-wlgreet-configuration-prompt (default '(1 1 1 1)))
3853 (prompt-error greetd-wlgreet-configuration-prompt-error (default '(1 1 1 1)))
3854 (border greetd-wlgreet-configuration-border (default '(1 1 1 1)))
3855 (wlgreet greetd-wlgreet
3856 (default #nil)
3857 (sanitize warn-deprecated-greetd-wlgreet))
3858 (command greetd-wlgreet-command
3859 (default #nil)
3860 (sanitize warn-deprecated-greetd-wlgreet-command))
3861 (command-args greetd-wlgreet-command-args
3862 (default #nil)
3863 (sanitize warn-deprecated-greetd-wlgreet-command-args))
3864 (extra-env greetd-wlgreet-extra-env
3865 (default #nil)
3866 (sanitize warn-deprecated-greetd-wlgreet-extra-env)))
3867
3868(define-deprecated/alias greetd-wlgreet-session greetd-wlgreet-configuration)
3869
3870(define (warn-deprecated-greetd-wlgreet value)
3871 (unless (nil? value)
3872 (warn-about-deprecation
3873 'wlgreet #f
3874 #:replacement '<greetd-wlgreet-sway-session>))
3875 value)
3876
3877(define (warn-deprecated-greetd-wlgreet-command value)
3878 (unless (nil? value)
3879 (warn-about-deprecation
3880 'command #f
3881 #:replacement '<greetd-wlgreet-sway-session>))
3882 value)
3883
3884(define (warn-deprecated-greetd-wlgreet-command-args value)
3885 (unless (nil? value)
3886 (warn-about-deprecation
3887 'command-args #f
3888 #:replacement '<greetd-wlgreet-sway-session>))
3889 value)
3890
3891(define (warn-deprecated-greetd-wlgreet-extra-env value)
3892 (unless (nil? value)
3893 (warn-about-deprecation
3894 'extra-env #f
3895 #:replacement '<greetd-wlgreet-sway-session>))
3896 value)
3897
3898(define (make-greetd-wlgreet-config-color section-name color)
3899 (match color
3900 ((red green blue opacity)
3901 (string-append
3902 "[" section-name "]\n"
3903 "red = " (number->string red) "\n"
3904 "green = " (number->string green) "\n"
3905 "blue = " (number->string blue) "\n"
3906 "opacity = " (number->string opacity) "\n"))))
3907
3908(define (make-greetd-wlgreet-config command color)
3909 (match-record color <greetd-wlgreet-configuration>
3910 (output-mode scale background headline prompt prompt-error border)
3911 (mixed-text-file
3912 "wlgreet.toml"
3913 "command = \"" command "\"\n"
3914 "outputMode = \"" output-mode "\"\n"
3915 "scale = " (number->string scale) "\n"
3916 (apply string-append
3917 (map (match-lambda
3918 ((section-name . color)
3919 (make-greetd-wlgreet-config-color section-name color)))
3920 `(("background" . ,background)
3921 ("headline" . ,headline)
3922 ("prompt" . ,prompt)
3923 ("prompt-error" . ,prompt-error)
3924 ("border" . ,border)))))))
3925
3926(define-record-type* <greetd-wlgreet-sway-session>
3927 greetd-wlgreet-sway-session make-greetd-wlgreet-sway-session
3928 greetd-wlgreet-sway-session?
3929 (sway greetd-wlgreet-sway-session-sway (default sway))
3930 (sway-configuration greetd-wlgreet-sway-session-sway-configuration
3931 (default #f))
3932 (wlgreet greetd-wlgreet-sway-session-wlgreet (default wlgreet))
3933 (wlgreet-configuration greetd-wlgreet-sway-session-wlgreet-configuration
3934 (default (greetd-wlgreet-configuration)))
3935 (command greetd-wlgreet-sway-session-command (default (greetd-user-session)))
3936 (wlgreet-session
3937 greetd-wlgreet-sway-session-wlgreet-session
3938 (default #nil)
3939 (sanitize warn-deprecated-greetd-wlgreet-sway-session-wlgreet-session)))
3940
3941(define (warn-deprecated-greetd-wlgreet-sway-session-wlgreet-session value)
3942 (unless (nil? value)
3943 (warn-about-deprecation
3944 'wlgreet-session #f
3945 #:replacement 'wlgreet-configuration))
3946 value)
3947
3948(define (make-greetd-wlgreet-sway-session-sway-config session)
3949 (match-record session <greetd-wlgreet-sway-session>
3950 (sway sway-configuration wlgreet wlgreet-configuration command)
3951 (let ((wlgreet-bin (file-append wlgreet "/bin/wlgreet"))
3952 (wlgreet-config-file
3953 (make-greetd-wlgreet-config command wlgreet-configuration))
3954 (swaymsg-bin (file-append sway "/bin/swaymsg")))
3955 (mixed-text-file
3956 "wlgreet-sway-config"
3957 (if sway-configuration
3958 #~(string-append "include " #$sway-configuration "\n")
3959 "")
3960 "xwayland disable\n"
3961 "exec \"" wlgreet-bin " --config " wlgreet-config-file
3962 "; " swaymsg-bin " exit\"\n"))))
3963
3964(define (greetd-wlgreet-session-to-config session config)
3965 (let* ((wlgreet (or (greetd-wlgreet config)
3966 (greetd-wlgreet-sway-session-wlgreet session)))
3967 (default-command (greetd-wlgreet-sway-session-command session))
3968 (command (or (greetd-wlgreet-command config)
3969 (greetd-user-session-command default-command)))
3970 (command-args (or (greetd-wlgreet-command-args config)
3971 (greetd-user-session-command-args default-command)))
3972 (extra-env (or (greetd-wlgreet-extra-env config)
3973 (greetd-user-session-extra-env default-command))))
3974 (greetd-wlgreet-sway-session
3975 (sway (greetd-wlgreet-sway-session-sway session))
3976 (sway-configuration
3977 (greetd-wlgreet-sway-session-sway-configuration session))
3978 (wlgreet wlgreet)
3979 (wlgreet-configuration config)
3980 (command
3981 (greetd-user-session
3982 (command command)
3983 (command-args command-args)
3984 (extra-env extra-env))))))
3985
3986(define-gexp-compiler (greetd-wlgreet-sway-session-compiler
3987 (session <greetd-wlgreet-sway-session>)
3988 system target)
3989 (let ((s (if (nil? (greetd-wlgreet-sway-session-wlgreet-session session))
3990 session
3991 (greetd-wlgreet-session-to-config
3992 session
3993 (greetd-wlgreet-sway-session-wlgreet-session session)))))
3994 (match-record s <greetd-wlgreet-sway-session> (sway)
3995 (lower-object
3996 (make-greetd-sway-greeter-command
3997 sway
3998 (make-greetd-wlgreet-sway-session-sway-config s))))))
3999
4000(define-record-type* <greetd-gtkgreet-sway-session>
4001 greetd-gtkgreet-sway-session make-greetd-gtkgreet-sway-session
4002 greetd-gtkgreet-sway-session?
4003 (sway greetd-gtkgreet-sway-session-sway (default sway))
4004 (sway-configuration greetd-gtkgreet-sway-session-sway-configuration
4005 (default #f))
4006 (gtkgreet greetd-gtkgreet-sway-session-gtkgreet (default gtkgreet))
4007 (gtkgreet-style greetd-gtkgreet-sway-session-gtkgreet-style (default #f))
4008 (command greetd-gtkgreet-sway-session-command
4009 (default (greetd-user-session))))
4010
4011(define (make-greetd-gtkgreet-sway-session-sway-config session)
4012 (match-record session <greetd-gtkgreet-sway-session>
4013 (sway sway-configuration gtkgreet gtkgreet-style command)
4014 (let ((gtkgreet-bin (file-append gtkgreet "/bin/gtkgreet"))
4015 (swaymsg-bin (file-append sway "/bin/swaymsg")))
4016 (mixed-text-file
4017 "gtkgreet-sway-config"
4018 (if sway-configuration
4019 #~(string-append "include " #$sway-configuration "\n")
4020 "")
4021 "xwayland disable\n"
4022 "exec \"" gtkgreet-bin " -l"
4023 (if gtkgreet-style #~(string-append " -s " #$gtkgreet-style) "")
4024 " -c " command "; " swaymsg-bin " exit\"\n"))))
4025
4026(define-gexp-compiler (greetd-gtkgreet-sway-session-compiler
4027 (session <greetd-gtkgreet-sway-session>)
4028 system target)
4029 (match-record session <greetd-gtkgreet-sway-session> (sway)
4030 (lower-object
4031 (make-greetd-sway-greeter-command
4032 sway
4033 (make-greetd-gtkgreet-sway-session-sway-config session)))))
4034
4035(define (alist-of pred?)
4036 "Return a procedure that takes an association list and check if all the
4037elements of the list result in @code{#t} when applying PRED? on them."
4038 (lambda (x)
4039 (if (alist? x)
4040 (every pred? x)
4041 #f)))
4042
4043(define alist-of-strings-to-greetd-user-sessions?
4044 (alist-of (match-lambda
4045 ((key . value)
4046 (if (and (string? key)
4047 (greetd-user-session? value))
4048 #t
4049 #f)))))
4050
4051(define alist-of-strings-to-strings?
4052 (alist-of (match-lambda
4053 ((key . value)
4054 (if (and (string? key)
4055 (string? value))
4056 #t
4057 #f)))))
4058
4059(define-maybe/no-serialization alist-of-strings-to-strings)
4060
4061(define-configuration/no-serialization nwg-hello-configuration
4062 (session-dirs
4063 (list-of-strings
4064 '("/run/current-system/profile/share/wayland-sessions"
4065 "/run/current-system/profile/share/xsessions"))
4066 "List of directories containing Wayland or X session desktop files.")
4067 (custom-sessions
4068 (alist-of-strings-to-greetd-user-sessions
4069 `(("Shell" . ,(greetd-user-session))))
4070 "Session names and the commands.")
4071 (environment-variables
4072 (alist-of-strings-to-strings '())
4073 "Environment variables associated to their values to pass to user sessions.")
4074 (halt-command
4075 (string "loginctl suspend")
4076 "Command to run when halting the device.")
4077 (reboot-command
4078 (string "loginctl reboot")
4079 "Command to run when rebooting the device.")
4080 (shutdown-command
4081 (string "loginctl poweroff")
4082 "Command to run when shutting down the device.")
4083 (gtk-theme
4084 (string "Adwaita")
4085 "GTK theme to use.")
4086 (icon-theme
4087 (string "Adwaita")
4088 "Icon theme to use.")
4089 (cursor-theme
4090 (string "Adwaita")
4091 "Cursor theme to use.")
4092 (prefer-dark-theme?
4093 (boolean #t)
4094 "Flag to prefer dark mode for the theme.")
4095 (extra-config
4096 (maybe-alist-of-strings-to-strings)
4097 "Extra configuration of keys and values."))
4098
4099(define nwg-hello-configuration-file
4100 (match-record-lambda <nwg-hello-configuration>
4101 (session-dirs custom-sessions environment-variables halt-command
4102 reboot-command shutdown-command gtk-theme icon-theme cursor-theme
4103 prefer-dark-theme? extra-config)
4104 (apply mixed-text-file "nwg-hello.json"
4105 (append '("{")
4106
4107 `("\n \"session_dirs\": [\n "
4108 ,(string-join (map (lambda (dir)
4109 (string-append "\"" dir "\""))
4110 session-dirs)
4111 ",\n ")
4112 "\n ]")
4113 `(",\n \"custom_sessions\": [\n "
4114 ,@(append-map (lambda (custom-session)
4115 `("{\n "
4116 "\"name\": \"" ,(car custom-session)
4117 "\",\n "
4118 "\"exec\": \"" ,(cdr custom-session)
4119 "\"\n }"
4120 ,(if (eq? custom-session
4121 (list-ref custom-sessions
4122 (- (length
4123 custom-sessions)
4124 1)))
4125 ""
4126 ",\"\n ")))
4127 custom-sessions)
4128 "\n ]")
4129 `(",\n \"cmd-sleep\": \"" ,halt-command "\"")
4130 `(",\n \"cmd-reboot\": \"" ,reboot-command "\"")
4131 `(",\n \"cmd-poweroff\": \"" ,shutdown-command "\"")
4132 `(",\n \"gtk-theme\": \"" ,gtk-theme "\"")
4133 `(",\n \"gtk-icon-theme\": \"" ,icon-theme "\"")
4134 `(",\n \"gtk-cursor-theme\": \"" ,cursor-theme "\"")
4135 `(",\n \"prefer-dark-theme\": "
4136 ,(if prefer-dark-theme? "true" "false"))
4137 `(",\n \"env-vars\": [\n "
4138 ,(string-join (map (match-lambda
4139 ((key . value)
4140 (string-append "\"" key "="
4141 value "\"")))
4142 environment-variables)
4143 ",\n ")
4144 "\n ]")
4145 (if (maybe-value-set? extra-config)
4146 (map (match-lambda
4147 ((key . value)
4148 (string-append ",\n \"" key "\": " value)))
4149 extra-config)
4150 '())
4151 '("\n}\n")))))
4152
4153(define (file-like-or-#f? value)
4154 (or (file-like? value)
4155 (not value)))
4156
4157(define alist-of-strings-to-alists-of-strings-to-strings?
4158 (alist-of (match-lambda
4159 ((key . value)
4160 (if (and (string? key)
4161 (alist-of-strings-to-strings? value))
4162 #t
4163 #f)))))
4164
4165(define-maybe/no-serialization alist-of-strings-to-alists-of-strings-to-strings)
4166
4167(define-configuration/no-serialization nwg-hello-style
4168 (background-image
4169 (file-like-or-#f (file-append nwg-hello "/share/nwg-hello/nwg.jpg"))
4170 "Image file to be set as the background. Setting this to @code{#f} respects
4171the background color.")
4172 (background-size
4173 (string "auto 100%")
4174 "Size of the background image. It can be @code{\"auto\"} (for preserving the
4175original size), @code{\"cover\"} (for resizing to fill while allowing to cut or
4176to stretch), @code{\"contain\"} (for resizing to fit assuring the full
4177visibility of the image), or a string of a number suffixed with with @code{px}
4178(to represent in pixels) or @code{%} (to represent in percentage). It can also
4179be a string of two such values separated by a whitespace, representing width and
4180height respectively.")
4181 (extra-style
4182 (maybe-alist-of-strings-to-alists-of-strings-to-strings)
4183 "List of CSS selectors associated to their lists of CSS properties
4184associated to their values."))
4185
4186(define nwg-hello-stylesheet
4187 (match-record-lambda <nwg-hello-style>
4188 (background-image background-size extra-style)
4189 (apply mixed-text-file "nwg-hello.css"
4190 "window {\n\tbackground-image: "
4191 #~(if #$background-image
4192 (string-append "url(\"" #$background-image "\")")
4193 "none")
4194 "; background-size: " background-size ";\n}"
4195 (append-map (match-lambda
4196 ((selector . declaration)
4197 `(,(string-append "\n" selector " {")
4198 ,@(map (match-lambda
4199 ((property . value)
4200 (string-append "\n\t" property ": " value
4201 ";")))
4202 declaration)
4203 "\n}")))
4204 (if (maybe-value-set? extra-style) extra-style '())))))
4205
4206(define-maybe/no-serialization file-like)
4207
4208(define-configuration/no-serialization greetd-nwg-hello-sway-session
4209 (sway
4210 (package sway)
4211 "Package providing the @command{sway} and @command{swaymsg} commands.")
4212 (sway-configuration
4213 (maybe-file-like)
4214 "Extra configuration for @command{sway} to be included before executing the
4215greeter.")
4216 (nwg-hello
4217 (package nwg-hello)
4218 "Package providing the @command{nwg-hello} command.")
4219 (nwg-hello-config
4220 (nwg-hello-configuration (nwg-hello-configuration))
4221 "Configuration of @command{nwg-hello}.")
4222 (nwg-hello-style
4223 (nwg-hello-style (nwg-hello-style))
4224 "CSS style rules for @command{nwg-hello}."))
4225
4226(define make-greetd-nwg-hello-sway-session-sway-config
4227 (match-record-lambda <greetd-nwg-hello-sway-session>
4228 (sway sway-configuration nwg-hello nwg-hello-config nwg-hello-style)
4229 (let ((nwg-hello-bin (file-append nwg-hello "/bin/nwg-hello"))
4230 (nwg-hello-configuration-file
4231 (nwg-hello-configuration-file nwg-hello-config))
4232 (nwg-hello-stylesheet (nwg-hello-stylesheet nwg-hello-style))
4233 (swaymsg-bin (file-append sway "/bin/swaymsg")))
4234 (mixed-text-file "nwg-hello-sway-config"
4235 (if (maybe-value-set? sway-configuration)
4236 #~(string-append "include " #$sway-configuration "\n")
4237 "")
4238 "xwayland disable\n"
4239 "exec \"" nwg-hello-bin " -l"
4240 " -c " nwg-hello-configuration-file " -s " nwg-hello-stylesheet
4241 "\""))))
4242
4243(define-gexp-compiler (greetd-nwg-hello-sway-session-compiler
4244 (session <greetd-nwg-hello-sway-session>)
4245 system target)
4246 (match-record session <greetd-nwg-hello-sway-session> (sway)
4247 (lower-object
4248 (make-greetd-sway-greeter-command
4249 sway
4250 (make-greetd-nwg-hello-sway-session-sway-config session)))))
4251
4252(define-record-type* <greetd-terminal-configuration>
4253 greetd-terminal-configuration make-greetd-terminal-configuration
4254 greetd-terminal-configuration?
4255 (greetd greetd-package (default greetd))
4256 (extra-shepherd-requirement greetd-extra-shepherd-requirement (default '()))
4257 (config-file-name greetd-config-file-name (thunked)
4258 (default (default-config-file-name this-record)))
4259 (log-file-name greetd-log-file-name (thunked)
4260 (default (default-log-file-name this-record)))
4261 (terminal-vt greetd-terminal-vt (default "7"))
4262 (terminal-switch greetd-terminal-switch (default #f))
4263 (source-profile? greetd-source-profile? (default #t))
4264 (default-session-user greetd-default-session-user (default "greeter"))
4265 (default-session-command greetd-default-session-command
4266 (default (greetd-agreety-session)))
4267 (initial-session-user greetd-initial-session-user (default #f))
4268 ;; Note: This field is ignored (not written out) if greetd-initial-session-user is unset.
4269 (initial-session-command greetd-initial-session-command
4270 (default (greetd-user-session))))
4271
4272(define (default-config-file-name config)
4273 (string-join (list "config-" (greetd-terminal-vt config) ".toml") ""))
4274
4275(define (default-log-file-name config)
4276 (string-join (list "/var/log/greetd-" (greetd-terminal-vt config) ".log") ""))
4277
4278(define (make-greetd-terminal-configuration-file config)
4279 (let*
4280 ((config-file-name (greetd-config-file-name config))
4281 (source-profile? (greetd-source-profile? config))
4282 (terminal-vt (greetd-terminal-vt config))
4283 (terminal-switch (greetd-terminal-switch config))
4284 (default-session-user (greetd-default-session-user config))
4285 (default-session-command (greetd-default-session-command config))
4286 (initial-session-user (greetd-initial-session-user config))
4287 (initial-session-command (greetd-initial-session-command config)))
4288 (mixed-text-file
4289 config-file-name
4290 "[general]\n"
4291 "source_profile = " (if source-profile? "true" "false") "\n"
4292 "runfile = /run/greetd/runfiles/greetd-" terminal-vt ".run\n"
4293 "[terminal]\n"
4294 "vt = " terminal-vt "\n"
4295 "switch = " (if terminal-switch "true" "false") "\n"
4296 "[default_session]\n"
4297 "user = " default-session-user "\n"
4298 "command = " default-session-command "\n"
4299 (if (and initial-session-user initial-session-command)
4300 #~(string-append
4301 "[initial_session]\n"
4302 "user = " #$initial-session-user "\n"
4303 "command = " #$initial-session-command "\n")
4304 ""))))
4305
4306(define %greetd-file-systems
4307 (list (file-system
4308 (device "none")
4309 (mount-point "/run/greetd/pam_mount")
4310 (type "tmpfs")
4311 (check? #f)
4312 (flags '(no-suid no-dev no-exec))
4313 (options "mode=0755")
4314 (create-mount-point? #t))
4315 (file-system
4316 (device "none")
4317 (mount-point "/run/greetd/runfiles")
4318 (type "tmpfs")
4319 (check? #f)
4320 (flags '(no-suid no-dev no-exec))
4321 (options "mode=0755")
4322 (create-mount-point? #t))))
4323
4324(define %greetd-pam-mount-rules
4325 `((debug (@ (enable "0")))
4326 (volume (@ (sgrp "users")
4327 (fstype "tmpfs")
4328 (mountpoint "/run/user/%(USERUID)")
4329 (options "nosuid,nodev,size=1g,mode=0700,uid=%(USERUID),gid=%(USERGID)")))
4330 (logout (@ (wait "0")
4331 (hup "0")
4332 (term "yes")
4333 (kill "no")))
4334 (mkmountpoint (@ (enable "1") (remove "true")))))
4335
4336(define-record-type* <greetd-configuration>
4337 greetd-configuration make-greetd-configuration
4338 greetd-configuration?
4339 (motd greetd-motd (default %default-motd))
4340 (allow-empty-passwords? greetd-allow-empty-passwords? (default #t))
4341 (terminals greetd-terminals (default '()))
4342 (greeter-supplementary-groups greetd-greeter-supplementary-groups (default '())))
4343
4344(define (greetd-accounts config)
4345 (list (user-group (name "greeter") (system? #t))
4346 (user-account
4347 (name "greeter")
4348 (group "greeter")
4349 (supplementary-groups (greetd-greeter-supplementary-groups config))
4350 (system? #t)
4351 (home-directory "/var/empty")
4352 (shell (file-append shadow "/sbin/nologin"))
4353 (create-home-directory? #f))))
4354
4355(define (make-greetd-pam-mount-conf-file config)
4356 (computed-file
4357 "greetd_pam_mount.conf.xml"
4358 #~(begin
4359 (use-modules (sxml simple))
4360 (call-with-output-file #$output
4361 (lambda (port)
4362 (sxml->xml
4363 '(*TOP*
4364 (*PI* xml "version='1.0' encoding='utf-8'")
4365 (pam_mount
4366 #$@%greetd-pam-mount-rules
4367 (pmvarrun
4368 #$(file-append greetd-pam-mount
4369 "/sbin/pmvarrun -u '%(USER)' -o '%(OPERATION)'"))))
4370 port))))))
4371
4372(define (greetd-etc-service config)
4373 `(("security/greetd_pam_mount.conf.xml"
4374 ,(make-greetd-pam-mount-conf-file config))))
4375
4376(define (greetd-pam-service config)
4377 (define optional-pam-mount
4378 (pam-entry
4379 (control "optional")
4380 (module (file-append greetd-pam-mount "/lib/security/pam_mount.so"))
4381 (arguments '("disable_interactive"))))
4382
4383 (list
4384 (unix-pam-service "greetd"
4385 #:login-uid? #t
4386 #:allow-empty-passwords?
4387 (greetd-allow-empty-passwords? config)
4388 #:motd
4389 (greetd-motd config))
4390 (pam-extension
4391 (transformer
4392 (lambda (pam)
4393 (if (member (pam-service-name pam)
4394 '("login" "greetd" "su" "slim" "gdm-password"))
4395 (pam-service
4396 (inherit pam)
4397 (auth (append (pam-service-auth pam)
4398 (list optional-pam-mount)))
4399 (session (append (pam-service-session pam)
4400 (list optional-pam-mount))))
4401 pam))))))
4402
4403(define (greetd-run-user-activation config)
4404 #~(begin
4405 (use-modules (guix build utils))
4406 (let ((d "/run/user"))
4407 (mkdir-p d)
4408 (chmod d #o755))))
4409
4410(define (greetd-shepherd-services config)
4411 (map
4412 (lambda (tc)
4413 (let*
4414 ((greetd-bin (file-append (greetd-package tc) "/sbin/greetd"))
4415 (greetd-conf (make-greetd-terminal-configuration-file tc))
4416 (greetd-log (greetd-log-file-name tc))
4417 (greetd-vt (greetd-terminal-vt tc))
4418 (greetd-requirement (greetd-extra-shepherd-requirement tc)))
4419 (shepherd-service
4420 (documentation "Minimal and flexible login manager daemon")
4421 (requirement `(pam user-processes host-name udev virtual-terminal
4422 ,@greetd-requirement))
4423 (provision (list (symbol-append
4424 'term-tty
4425 (string->symbol (greetd-terminal-vt tc)))))
4426 (start #~(make-forkexec-constructor
4427 (list #$greetd-bin "-c" #$greetd-conf)
4428 #:log-file #$greetd-log))
4429 (stop #~(make-kill-destructor)))))
4430 (greetd-terminals config)))
4431
4432(define greetd-service-type
4433 (service-type
4434 (name 'greetd)
4435 (description "Provides necessary infrastructure for logging into the
4436system including @code{greetd} PAM service, @code{pam-mount} module to
4437mount/unmount /run/user/<uid> directory for user and @code{greetd}
4438login manager daemon.")
4439 (extensions
4440 (list
4441 (service-extension account-service-type greetd-accounts)
4442 (service-extension file-system-service-type (const %greetd-file-systems))
4443 (service-extension activation-service-type greetd-run-user-activation)
4444 (service-extension etc-service-type greetd-etc-service)
4445 (service-extension pam-root-service-type greetd-pam-service)
4446 (service-extension shepherd-root-service-type greetd-shepherd-services)))
4447 (default-value (greetd-configuration))))
4448
4449
4450(define %base-services
4451 ;; Convenience variable holding the basic services.
4452 (list (service login-service-type)
4453
4454 (service virtual-terminal-service-type)
4455 (service console-font-service-type
4456 (map (lambda (tty)
4457 (cons tty %default-console-font))
4458 '("tty1" "tty2" "tty3" "tty4" "tty5" "tty6")))
4459
4460 (service shepherd-system-log-service-type)
4461 (service agetty-service-type (agetty-configuration
4462 (extra-options '("-L")) ; no carrier detect
4463 (term "vt100")
4464 (tty #f) ; automatic
4465 (shepherd-requirement '(syslogd))))
4466
4467 (service mingetty-service-type (mingetty-configuration
4468 (tty "tty1")))
4469 (service mingetty-service-type (mingetty-configuration
4470 (tty "tty2")))
4471 (service mingetty-service-type (mingetty-configuration
4472 (tty "tty3")))
4473 (service mingetty-service-type (mingetty-configuration
4474 (tty "tty4")))
4475 (service mingetty-service-type (mingetty-configuration
4476 (tty "tty5")))
4477 (service mingetty-service-type (mingetty-configuration
4478 (tty "tty6")))
4479
4480 ;; Extra Bash configuration including Bash completion and aliases.
4481 (service etc-bashrc-d-service-type)
4482
4483 (service static-networking-service-type
4484 (list %loopback-static-networking))
4485 (service urandom-seed-service-type)
4486 (service guix-service-type)
4487 (service nscd-service-type)
4488
4489 (service log-rotation-service-type)
4490
4491 ;; Convenient services brought by the Shepherd.
4492 (service shepherd-timer-service-type)
4493 (service shepherd-transient-service-type)
4494
4495 ;; Periodically delete old build logs.
4496 (service log-cleanup-service-type
4497 (log-cleanup-configuration
4498 (directory "/var/log/guix/drvs")))
4499
4500 ;; The LVM2 rules are needed as soon as LVM2 or the device-mapper is
4501 ;; used, so enable them by default. The FUSE and ALSA rules are
4502 ;; less critical, but handy.
4503 (service udev-service-type
4504 (udev-configuration
4505 (rules (list lvm2 fuse alsa-utils crda))))
4506
4507 (service sysctl-service-type)
4508
4509 (service special-files-service-type
4510 `(("/bin/sh" ,(file-append bash "/bin/sh"))
4511 ("/usr/bin/env" ,(file-append coreutils "/bin/env"))))))
4512
4513;;; base.scm ends here