projects/guix·blob next-master · refs

1684 lines · 68.8 KiB

1;;; GNU Guix --- Functional package management for GNU
2;;; Copyright © 2013-2022, 2024-2025 Ludovic Courtès <[email protected]>
3;;; Copyright © 2015 Mark H Weaver <[email protected]>
4;;; Copyright © 2015, 2016 Alex Kost <[email protected]>
5;;; Copyright © 2016 Chris Marusich <[email protected]>
6;;; Copyright © 2017 Mathieu Othacehe <[email protected]>
7;;; Copyright © 2019 Meiyo Peng <[email protected]>
8;;; Copyright © 2019, 2020 Miguel Ángel Arruga Vivas <[email protected]>
9;;; Copyright © 2020 Danny Milosavljevic <[email protected]>
10;;; Copyright © 2020, 2021 Brice Waegeneire <[email protected]>
11;;; Copyright © 2020 Florian Pelz <[email protected]>
12;;; Copyright © 2020, 2022, 2025 Maxim Cournoyer <[email protected]>
13;;; Copyright © 2020, 2023 Janneke Nieuwenhuizen <[email protected]>
14;;; Copyright © 2020, 2022, 2025 Efraim Flashner <[email protected]>
15;;; Copyright © 2021 Maxime Devos <[email protected]>
16;;; Copyright © 2021 raid5atemyhomework <[email protected]>
17;;; Copyright © 2023 Bruno Victal <[email protected]>
18;;; Copyright © 2024 Nicolas Graves <[email protected]>
19;;;
20;;; This file is part of GNU Guix.
21;;;
22;;; GNU Guix is free software; you can redistribute it and/or modify it
23;;; under the terms of the GNU General Public License as published by
24;;; the Free Software Foundation; either version 3 of the License, or (at
25;;; your option) any later version.
26;;;
27;;; GNU Guix is distributed in the hope that it will be useful, but
28;;; WITHOUT ANY WARRANTY; without even the implied warranty of
29;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
30;;; GNU General Public License for more details.
31;;;
32;;; You should have received a copy of the GNU General Public License
33;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
34
35(define-module (gnu system)
36 #:use-module (guix inferior)
37 #:use-module (guix store)
38 #:use-module (guix memoization)
39 #:use-module (guix monads)
40 #:use-module (guix gexp)
41 #:use-module (guix records)
42 #:use-module (guix packages)
43 #:use-module (guix deprecation)
44 #:use-module (guix derivations)
45 #:use-module (guix profiles)
46 #:use-module ((guix utils) #:select (substitute-keyword-arguments
47 version>?))
48 #:use-module (guix i18n)
49 #:use-module (guix diagnostics)
50 #:use-module (guix ui)
51 #:use-module (gnu packages admin)
52 #:use-module (gnu packages base)
53 #:use-module (gnu packages bash)
54 #:use-module ((gnu packages nss) #:select (nss-certs))
55 #:use-module (gnu packages compression)
56 #:use-module (gnu packages cross-base)
57 #:use-module (gnu packages firmware)
58 #:use-module (gnu packages gawk)
59 #:use-module (gnu packages guile)
60 #:use-module (gnu packages guile-xyz)
61 #:use-module (gnu packages hurd)
62 #:use-module (gnu packages less)
63 #:use-module (gnu packages linux)
64 #:use-module (gnu packages man)
65 #:use-module (gnu packages nvi)
66 #:use-module (gnu packages package-management)
67 #:use-module (gnu packages pciutils)
68 #:use-module (gnu packages texinfo)
69 #:use-module (gnu packages text-editors)
70 #:use-module (gnu packages wget)
71 #:use-module (gnu services)
72 #:use-module (gnu services shepherd)
73 #:use-module (gnu services base)
74 #:use-module (gnu bootloader)
75 #:use-module (gnu system shadow)
76 #:use-module (gnu system nss)
77 #:use-module (gnu system locale)
78 #:use-module (gnu system pam)
79 #:use-module (gnu system linux-initrd)
80 #:use-module (gnu system privilege)
81 #:use-module (gnu system setuid)
82 #:use-module (gnu system uuid)
83 #:use-module (gnu system file-systems)
84 #:use-module (gnu system mapped-devices)
85 #:use-module (ice-9 format)
86 #:use-module (ice-9 match)
87 #:use-module (srfi srfi-1)
88 #:use-module (srfi srfi-26)
89 #:use-module (srfi srfi-34)
90 #:use-module (srfi srfi-35)
91 #:use-module (srfi srfi-71)
92 #:use-module (rnrs bytevectors)
93 #:export (operating-system
94 operating-system?
95 this-operating-system
96
97 operating-system-bootloader
98 operating-system-services
99 operating-system-essential-services
100 operating-system-default-essential-services
101 operating-system-user-services
102 operating-system-packages
103 operating-system-host-name
104 operating-system-hosts-file ;deprecated
105 operating-system-hurd
106 operating-system-kernel
107 operating-system-kernel-file
108 operating-system-kernel-arguments
109 operating-system-label
110 operating-system-default-label
111 operating-system-initrd-modules
112 operating-system-initrd
113 operating-system-initrd-file
114 operating-system-users
115 operating-system-groups
116 operating-system-issue
117 operating-system-timezone
118 operating-system-locale
119 operating-system-locale-definitions
120 operating-system-locale-libcs
121 operating-system-mapped-devices
122 operating-system-file-systems
123 operating-system-root-file-system
124 operating-system-store-file-system
125 operating-system-user-mapped-devices
126 operating-system-boot-mapped-devices
127 operating-system-bootloader-crypto-devices
128 operating-system-activation-script
129 operating-system-user-accounts
130 operating-system-shepherd-service-names
131 operating-system-user-kernel-arguments
132 operating-system-firmware
133 operating-system-keyboard-layout
134 operating-system-name-service-switch
135 operating-system-pam-services
136 operating-system-privileged-programs
137 operating-system-setuid-programs
138 operating-system-skeletons
139 operating-system-sudoers-file
140 operating-system-swap-devices
141 operating-system-kernel-loadable-modules
142 operating-system-location
143
144 operating-system-derivation
145 operating-system-profile
146 operating-system-bootcfg
147 operating-system-etc-directory
148 operating-system-locale-directory
149 operating-system-boot-script
150 operating-system-uuid
151
152 system-linux-image-file-name
153 operating-system-with-gc-roots
154 operating-system-with-provenance
155
156 hurd-default-essential-services
157
158 boot-parameters
159 boot-parameters?
160 boot-parameters-label
161 boot-parameters-root-device
162 boot-parameters-bootloader-name
163 boot-parameters-bootloader-menu-entries
164 boot-parameters-store-crypto-devices
165 boot-parameters-store-device
166 boot-parameters-store-directory-prefix
167 boot-parameters-store-mount-point
168 boot-parameters-locale
169 boot-parameters-kernel
170 boot-parameters-kernel-arguments
171 boot-parameters-initrd
172 boot-parameters-multiboot-modules
173 boot-parameters-version
174 %boot-parameters-version
175 read-boot-parameters
176 read-boot-parameters-file
177 boot-parameters->menu-entry
178
179 local-host-aliases ;deprecated
180 %root-account
181 %default-privileged-programs
182 %setuid-programs
183 %sudoers-specification
184 %base-packages
185 %base-packages-artwork
186 %base-packages-interactive
187 %base-packages-linux
188 %base-packages-networking
189 %base-packages-disk-utilities
190 %base-packages-utils
191 %base-firmware
192 %default-kernel-arguments))
193
194;;; Commentary:
195;;;
196;;; This module supports whole-system configuration.
197;;;
198;;; Code:
199
200(define* (bootable-kernel-arguments system root-device version)
201 "Return a list of kernel arguments (gexps) to boot SYSTEM from ROOT-DEVICE.
202VERSION is the target version of the boot-parameters record."
203 ;; If the version is newer than 0, we use the new style initrd parameter
204 ;; names, otherwise we use the legacy ones. This is to maintain backward
205 ;; compatibility when producing bootloader configurations for older
206 ;; generations.
207 (define version>0? (> version 0))
208 (let ((root (file-system-device->string root-device
209 #:uuid-type 'dce)))
210 (append
211 (cond
212 ((string=? root "tmpfs")
213 ;; Required when using tmpfs as root file system.
214 ;; TODO: Include file system information in boot parameters, so that we
215 ;; can detect tmpfs by file system type instead of device name here.
216 '("rootfstype=tmpfs"))
217 ((string=? root "none")
218 ;; Ignore unhandled cases where the root is "none". This requires the
219 ;; user to set correct arguments.
220 '())
221 (else
222 ;; Note: Always use the DCE format because that's what
223 ;; (gnu build linux-boot) expects for the 'root'
224 ;; kernel command-line option.
225 (list (string-append (if version>0? "root=" "--root=") root))))
226 (list #~(string-append (if #$version>0? "gnu.system=" "--system=") #$system)
227 #~(string-append (if #$version>0? "gnu.load=" "--load=")
228 #$system "/boot")))))
229
230;; System-wide configuration.
231
232(define-with-syntax-properties (warn-hosts-file-field-deprecation
233 (value properties))
234 (when value
235 (warning (source-properties->location properties)
236 (G_ "the 'hosts-file' field is deprecated, please use \
237'hosts-service-type' instead~%")))
238 value)
239
240;; TODO: Add per-field docstrings/stexi.
241(define-record-type* <operating-system> operating-system
242 make-operating-system
243 operating-system?
244 this-operating-system
245
246 (kernel operating-system-kernel ; package
247 (default linux-libre))
248 (kernel-loadable-modules operating-system-kernel-loadable-modules
249 (default '())) ; list of packages
250 (kernel-arguments operating-system-user-kernel-arguments
251 (default %default-kernel-arguments)) ; list of gexps/strings
252 (hurd operating-system-hurd
253 (default #f)) ; package
254 (bootloader operating-system-bootloader) ; <bootloader-configuration>
255 (label operating-system-label ; string
256 (thunked)
257 (default (operating-system-default-label this-operating-system)))
258
259 (keyboard-layout operating-system-keyboard-layout ;#f | <keyboard-layout>
260 (default #f))
261 (initrd operating-system-initrd ; (list fs) -> file-like
262 (default base-initrd))
263 (initrd-modules operating-system-initrd-modules ; list of strings
264 (thunked) ; it's system-dependent
265 (default %base-initrd-modules))
266
267 (firmware operating-system-firmware ; list of packages
268 (default %base-firmware))
269
270 (host-name operating-system-host-name) ; string
271 (hosts-file %operating-system-hosts-file ; deprecated
272 (default #f)
273 (sanitize warn-hosts-file-field-deprecation))
274
275 (mapped-devices operating-system-mapped-devices ; list of <mapped-device>
276 (default '()))
277 (file-systems operating-system-file-systems) ; list of fs
278 (swap-devices operating-system-swap-devices ; list of string | <swap-space>
279 (default '())
280 (delayed)
281 (sanitize warn-swap-devices-change))
282
283 (users operating-system-users ; list of user accounts
284 (default %base-user-accounts))
285 (groups operating-system-groups ; list of user groups
286 (default %base-groups))
287
288 (skeletons operating-system-skeletons ; list of name/file-like value
289 (default (default-skeletons)))
290 (issue operating-system-issue ; string
291 (default %default-issue))
292
293 (packages %operating-system-packages ; list of (PACKAGE OUTPUT...)
294 (default %base-packages)) ; or just PACKAGE
295
296 (timezone operating-system-timezone
297 (default "Etc/UTC")) ; string
298 (locale operating-system-locale ; string
299 (default "en_US.utf8"))
300 (locale-definitions operating-system-locale-definitions ; list of <locale-definition>
301 (default %default-locale-definitions))
302 (locale-libcs operating-system-locale-libcs ; list of <packages>
303 (default %default-locale-libcs))
304 (name-service-switch operating-system-name-service-switch ; <name-service-switch>
305 (default %default-nss))
306
307 (essential-services operating-system-essential-services ; list of services
308 (thunked)
309 (default (operating-system-default-essential-services
310 this-operating-system)))
311 (services operating-system-user-services ; list of services
312 (thunked) ;allow for system-dependent services
313 (default %base-services)
314 (sanitize validate-service-list))
315
316 (pam-services operating-system-pam-services ; list of PAM services
317 (default (base-pam-services)))
318 (privileged-programs operating-system-privileged-programs ; list of <privileged-program>
319 (default %default-privileged-programs))
320 (setuid-programs operating-system-setuid-programs
321 ;; For backwards compatibility; will be removed.
322 (default %setuid-programs)) ; list of <setuid-program>
323
324 (sudoers-file operating-system-sudoers-file ; file-like
325 (default %sudoers-specification))
326
327 (location operating-system-location ; <location>
328 (default (and=> (current-source-location)
329 source-properties->location))
330 (innate)))
331
332(define-deprecated (operating-system-hosts-file os)
333 hosts-service-type
334 (%operating-system-hosts-file os))
335
336;;; XXX: Remove after a new release of Guix no longer suggests to install
337;;; nss-certs.
338(define (operating-system-packages os)
339 "Return the packages of the OS <operating-system> record object."
340 ;; This wrapper is used to warn users that their operating system packages
341 ;; field contains a duplicated nss-certs packages.
342 (let* ((packages (%operating-system-packages os))
343 (nss-certs-packages (sort (filter (lambda (p)
344 (and (package? p)
345 (string=? "nss-certs"
346 (package-name p))))
347 packages)
348 (lambda (x y)
349 ;; Sort from newer to older versions.
350 (version>? (package-version x)
351 (package-version y))))))
352 (if (> (length nss-certs-packages) 1)
353 (begin
354 (warning #f
355 (G_ "multiple 'nss-certs' packages found; 'nss-certs' \
356is now included by default in '%base-packages'; ensure it is not explicitly \
357listed in the operating system 'packages' field~%"))
358 (let ((nss-certs-packages (delete-duplicates nss-certs-packages eq?)))
359 (if (> (length nss-certs-packages) 1)
360 ;; Only mismatched nss-certs packages need to be handled to
361 ;; avoid profile collisions; same objects are later
362 ;; deduplicated in `packages->profile-entry'.
363 (fold delete packages (drop nss-certs-packages 1))
364 packages))) ;no-op
365 packages)))
366
367(define* (operating-system-kernel-arguments
368 os root-device #:key (version %boot-parameters-version))
369 "Return all the kernel arguments, including the ones not specified directly
370by the user. VERSION should match that of the target <boot-parameters> record
371object that will contain the kernel parameters."
372 (append (bootable-kernel-arguments os root-device version)
373 (operating-system-user-kernel-arguments os)))
374
375
376;;;
377;;; Boot parameters
378;;;
379
380;;; Version 1 was introduced early 2022 to mark the departure from long option
381;;; names such as '--load' to the more conventional initrd option names like
382;;; 'gnu.load'.
383;;;
384;;; When bumping the boot-parameters version, increment it by one (1).
385(define %boot-parameters-version 1)
386
387(define-record-type* <boot-parameters>
388 boot-parameters make-boot-parameters boot-parameters?
389 (label boot-parameters-label)
390 ;; Because we will use the 'store-device' to create the GRUB search command,
391 ;; the 'store-device' has slightly different semantics than 'root-device'.
392 ;; The 'store-device' can be a file system uuid, a file system label, or #f,
393 ;; but it cannot be a device file name such as "/dev/sda3", since GRUB would
394 ;; not understand that. The 'root-device', on the other hand, corresponds
395 ;; exactly to the device field of the <file-system> object representing the
396 ;; OS's root file system, so it might be a device file name like
397 ;; "/dev/sda3". The 'store-directory-prefix' field contains #f or the store
398 ;; file name inside the 'store-device' as it is seen by GRUB, e.g. it would
399 ;; contain "/storefs" if the store is located in that subvolume of a btrfs
400 ;; partition.
401 (root-device boot-parameters-root-device)
402 (bootloader-name boot-parameters-bootloader-name)
403 (bootloader-menu-entries ;list of <menu-entry>
404 boot-parameters-bootloader-menu-entries)
405 (store-device boot-parameters-store-device)
406 (store-mount-point boot-parameters-store-mount-point)
407 (store-directory-prefix boot-parameters-store-directory-prefix)
408 (store-crypto-devices boot-parameters-store-crypto-devices
409 (default '()))
410 (locale boot-parameters-locale)
411 (kernel boot-parameters-kernel)
412 (kernel-arguments boot-parameters-kernel-arguments)
413 (initrd boot-parameters-initrd)
414 (multiboot-modules boot-parameters-multiboot-modules)
415 (version boot-parameters-version ;positive integer
416 (default %boot-parameters-version)))
417
418(define (ensure-not-/dev device)
419 "If DEVICE starts with a slash, return #f. This is meant to filter out
420Linux device names such as /dev/sda, and to preserve GRUB device names and
421file system labels."
422 (if (and (string? device) (string-prefix? "/" device))
423 #f
424 device))
425
426(define (read-boot-parameters port)
427 "Read boot parameters from PORT and return the corresponding
428<boot-parameters> object. Raise an error if the format is unrecognized."
429 (define device-sexp->device
430 (match-lambda
431 (('uuid (? symbol? type) (? bytevector? bv))
432 (bytevector->uuid bv type))
433 (('file-system-label (? string? label))
434 (file-system-label label))
435 ((? bytevector? bv) ;old format
436 (bytevector->uuid bv 'dce))
437 ((? string? device)
438 (if (string-contains device ":/")
439 device ; nfs-root
440 ;; It used to be that we would not distinguish between labels and
441 ;; device names. Try to infer the right thing here.
442 (if (string-prefix? "/" device)
443 device
444 (file-system-label device))))))
445 (define uuid-sexp->uuid
446 (match-lambda
447 (('uuid (? symbol? type) (? bytevector? bv))
448 (bytevector->uuid bv type))
449 (x
450 (warning (G_ "unrecognized uuid ~a at '~a'~%") x (port-filename port))
451 #f)))
452
453 ;; New versions are not backward-compatible, so only accept past and current
454 ;; versions, not future ones.
455 (define (version? n)
456 (member n (iota (1+ %boot-parameters-version))))
457
458 (match (read port)
459 (('boot-parameters ('version (? version? version))
460 ('label label) ('root-device root)
461 ('kernel kernel)
462 rest ...)
463 (boot-parameters
464 (version version)
465 (label label)
466 (root-device (device-sexp->device root))
467
468 (bootloader-name
469 (match (assq 'bootloader-name rest)
470 ((_ args) args)
471 (#f 'grub))) ; for compatibility reasons.
472
473 (bootloader-menu-entries
474 (match (assq 'bootloader-menu-entries rest)
475 ((_ entries) (map sexp->menu-entry entries))
476 (#f '())))
477
478 ;; In the past, we would store the directory name of linux instead of
479 ;; the absolute file name of its image. Detect that and correct it.
480 (kernel (if (string=? kernel (direct-store-path kernel))
481 (string-append kernel "/"
482 (system-linux-image-file-name))
483 kernel))
484
485 (kernel-arguments
486 (match (assq 'kernel-arguments rest)
487 ((_ args) args)
488 (#f '()))) ;the old format
489
490 (initrd
491 (match (assq 'initrd rest)
492 (('initrd ('string-append directory file)) ;the old format
493 (string-append directory file))
494 (('initrd (? string? file))
495 file)
496 (#f #f)))
497
498 (multiboot-modules
499 (match (assq 'multiboot-modules rest)
500 ((_ args) args)
501 (#f '())))
502
503 (locale
504 (match (assq 'locale rest)
505 ((_ locale) locale)
506 (#f #f)))
507
508 (store-device
509 ;; Linux device names like "/dev/sda1" are not suitable GRUB device
510 ;; identifiers, so we just filter them out.
511 (ensure-not-/dev
512 (match (assq 'store rest)
513 (('store ('device #f) _ ...)
514 root-device)
515 (('store ('device device) _ ...)
516 (device-sexp->device device))
517 (_ ;the old format
518 root-device))))
519
520 (store-directory-prefix
521 (match (assq 'store rest)
522 (('store . store-data)
523 (match (assq 'directory-prefix store-data)
524 (('directory-prefix prefix) prefix)
525 ;; No directory-prefix found.
526 (_ #f)))
527 (_
528 ;; No store found, old format.
529 #f)))
530
531 (store-crypto-devices
532 (match (assq 'store rest)
533 (('store . store-data)
534 (match (assq 'crypto-devices store-data)
535 (('crypto-devices (devices ...))
536 (map uuid-sexp->uuid devices))
537 (('crypto-devices dev)
538 (warning (G_ "unrecognized crypto-devices ~S at '~a'~%")
539 dev (port-filename port))
540 '())
541 (_
542 ;; No crypto-devices found.
543 '())))
544 (_
545 ;; No store found, old format.
546 '())))
547
548 (store-mount-point
549 (match (assq 'store rest)
550 (('store ('device _) ('mount-point mount-point) _ ...)
551 mount-point)
552 (_ ;the old format
553 "/")))))
554 (x ;unsupported format
555 (raise
556 (make-compound-condition
557 (formatted-message
558 (G_ "unrecognized boot parameters at '~a'~%")
559 (port-filename port))
560 (condition
561 (&fix-hint (hint (format #f (G_ "This probably means that this version
562of Guix is older than the one that created @file{~a}. To address this, you
563need to update Guix:
564
565@example
566guix pull
567@end example")
568 (port-filename port))))))))))
569
570(define (read-boot-parameters-file system)
571 "Read boot parameters from SYSTEM's (system or generation) \"parameters\"
572file and returns the corresponding <boot-parameters> object or #f if the
573format is unrecognized.
574The object has its kernel-arguments extended in order to make it bootable."
575 (let* ((file (string-append system "/parameters"))
576 (params (call-with-input-file file read-boot-parameters))
577 (root (boot-parameters-root-device params))
578 (version (boot-parameters-version params)))
579 (boot-parameters
580 (inherit params)
581 (kernel-arguments (append (bootable-kernel-arguments system root version)
582 (boot-parameters-kernel-arguments params))))))
583
584(define (boot-parameters->menu-entry conf)
585 "Return a <menu-entry> instance given CONF, a <boot-parameters> instance."
586 (let* ((kernel (boot-parameters-kernel conf))
587 (multiboot-modules (boot-parameters-multiboot-modules conf))
588 (multiboot? (pair? multiboot-modules)))
589 (menu-entry
590 (label (boot-parameters-label conf))
591 (device (boot-parameters-store-device conf))
592 (device-mount-point (boot-parameters-store-mount-point conf))
593 (linux (and (not multiboot?) kernel))
594 (linux-arguments (if (not multiboot?)
595 (boot-parameters-kernel-arguments conf)
596 '()))
597 (initrd (boot-parameters-initrd conf))
598 (multiboot-kernel (and multiboot? kernel))
599 (multiboot-arguments (if multiboot?
600 (boot-parameters-kernel-arguments conf)
601 '()))
602 (multiboot-modules (if multiboot?
603 (boot-parameters-multiboot-modules conf)
604 '())))))
605
606
607;;;
608;;; Services.
609;;;
610
611(define (non-boot-file-system-service os)
612 "Return the file system service for the file systems of OS that are not
613marked as 'needed-for-boot'."
614 (define file-systems
615 (remove file-system-needed-for-boot?
616 (operating-system-file-systems os)))
617
618 (define mapped-devices-for-boot
619 (operating-system-boot-mapped-devices os))
620
621 (define (device-mappings fs)
622 (let ((device (file-system-device fs)))
623 (if (string? device) ;title is 'device
624 (filter (lambda (md)
625 (any (cut string=? device <>)
626 (map (cut string-append "/dev/mapper" <>)
627 (mapped-device-targets md))))
628 (operating-system-mapped-devices os))
629 '())))
630
631 (define (add-dependencies fs)
632 ;; Add the dependencies due to device mappings to FS.
633 (file-system
634 (inherit fs)
635 (dependencies
636 (delete-duplicates
637 (remove (cut member <> mapped-devices-for-boot)
638 (append (device-mappings fs)
639 (file-system-dependencies fs)))
640 eq?))))
641
642 (service file-system-service-type
643 (map add-dependencies file-systems)))
644
645(define (boot-file-system-service os)
646 "Return a service which adds, to the system profile, packages providing the
647utilities for the file systems marked as 'needed-for-boot' in OS."
648 (let ((file-systems (filter file-system-needed-for-boot?
649 (operating-system-file-systems os))))
650 (simple-service 'boot-file-system-utilities profile-service-type
651 (file-system-utilities file-systems))))
652
653(define (mapped-device-users device file-systems)
654 "Return the subset of FILE-SYSTEMS that use DEVICE."
655 (let ((targets (map (cut string-append "/dev/mapper/" <>)
656 (mapped-device-targets device))))
657 (filter (lambda (fs)
658 (or (member device (file-system-dependencies fs))
659 (and (string? (file-system-device fs))
660 (any (cut string=? (file-system-device fs) <>) targets))))
661 file-systems)))
662
663(define (operating-system-user-mapped-devices os)
664 "Return the subset of mapped devices that can be installed in
665user-land--i.e., those not needed during boot."
666 (let ((devices (operating-system-mapped-devices os))
667 (file-systems (operating-system-file-systems os)))
668 (filter (lambda (md)
669 (let ((users (mapped-device-users md file-systems)))
670 (not (any file-system-needed-for-boot? users))))
671 devices)))
672
673(define (operating-system-boot-mapped-devices os)
674 "Return the subset of mapped devices that must be installed during boot,
675from the initrd."
676 (let ((devices (operating-system-mapped-devices os))
677 (file-systems (operating-system-file-systems os)))
678 (filter (lambda (md)
679 (let ((users (mapped-device-users md file-systems)))
680 (any file-system-needed-for-boot? users)))
681 devices)))
682
683(define operating-system-bootloader-crypto-devices
684 (mlambdaq (os) ;to avoid duplicated output
685 "Return the sources of the LUKS mapped devices specified by UUID."
686 ;; XXX: Device ordering is important, we trust the returned one.
687 (let* ((luks-devices (filter (lambda (m)
688 (eq? luks-device-mapping
689 (mapped-device-type m)))
690 (operating-system-boot-mapped-devices os)))
691 (uuid-crypto-devices non-uuid-crypto-devices
692 (partition (compose uuid? mapped-device-source)
693 luks-devices)))
694 (when (not (null? non-uuid-crypto-devices))
695 (for-each (lambda (dev)
696 (warning
697 (source-properties->location (mapped-device-location dev))
698 (G_ "mapped device '~a' may be ignored by bootloader~%")
699 (mapped-device-source dev)))
700 non-uuid-crypto-devices)
701 (display-hint "Specify mapped device sources via their LUKS UUID."))
702 (map mapped-device-source uuid-crypto-devices))))
703
704(define (device-mapping-services os)
705 "Return the list of device-mapping services for OS as a list."
706 (map device-mapping-service
707 (operating-system-user-mapped-devices os)))
708
709(define-syntax-rule (warn-swap-devices-change value)
710 (%warn-swap-devices-change value (current-source-location)))
711
712(define (%warn-swap-devices-change value location)
713 (map (lambda (x)
714 (unless (swap-space? x)
715 (warning
716 (source-properties->location
717 location)
718 (G_ "List elements of the field 'swap-devices' should \
719now use the <swap-space> record, as the old method is deprecated. \
720See \"(guix) operating-system Reference\" for more details.~%")))
721 x) value))
722
723(define (swap-services os)
724 "Return the list of swap services for OS."
725 (define early-userspace-file-systems
726 (filter file-system-needed-for-boot?
727 (operating-system-file-systems os)))
728
729 (define early-userspace-mapped-devices
730 (operating-system-boot-mapped-devices os))
731
732 (define (filter-deps swap)
733 (if (swap-space? swap)
734 (swap-space
735 (inherit swap)
736 (dependencies (remove (lambda (dep)
737 (or (member dep early-userspace-mapped-devices)
738 (member dep early-userspace-file-systems)))
739 (swap-space-dependencies swap))))
740 swap))
741
742 (map (compose swap-service filter-deps)
743 (operating-system-swap-devices os)))
744
745(define* (system-linux-image-file-name #:optional
746 (target (or (%current-target-system)
747 (%current-system))))
748 "Return the basename of the kernel image file for TARGET."
749 (cond
750 ((string-prefix? "arm" target) "zImage")
751 ((string-prefix? "mips" target) "vmlinuz")
752 ((string-prefix? "aarch64" target) "Image")
753 ((string-prefix? "riscv64" target) "Image")
754 (else "bzImage")))
755
756(define (operating-system-kernel-file os)
757 "Return an object representing the absolute file name of the kernel image of
758OS."
759 (if (operating-system-hurd os)
760 (file-append (operating-system-kernel os) "/boot/gnumach")
761 (file-append (operating-system-kernel os)
762 "/" (system-linux-image-file-name))))
763
764(define %default-modprobe-blacklist
765 ;; List of kernel modules to blacklist by default.
766 '("usbmouse" ;races with bcm5974, see <https://bugs.gnu.org/35574>
767 "usbkbd")) ;races with usbhid, see <https://issues.guix.gnu.org/35574#18>
768
769(define %default-kernel-arguments
770 ;; Default arguments passed to the kernel.
771 (list (string-append "modprobe.blacklist="
772 (string-join %default-modprobe-blacklist ","))
773 "quiet"))
774
775(define* (operating-system-directory-base-entries os)
776 "Return the basic entries of the 'system' directory of OS for use as the
777value of the SYSTEM-SERVICE-TYPE service."
778 (let* ((locale (operating-system-locale-directory os))
779 (kernel (operating-system-kernel os))
780 (hurd (operating-system-hurd os))
781 (initrd (and (not hurd) (operating-system-initrd-file os)))
782 (params (operating-system-boot-parameters-file os)))
783 `(,@(if hurd
784 `(("hurd" ,hurd)
785 ("kernel" ,kernel))
786 '())
787 ("parameters" ,params)
788 ,@(if initrd `(("initrd" ,initrd)) '())
789 ("locale" ,locale)))) ;used by libc
790
791(define (operating-system-default-essential-services os)
792 "Return the list of essential services for OS. These are special services
793that implement part of what's declared in OS are responsible for low-level
794bookkeeping."
795 (define known-fs
796 (map file-system-mount-point (operating-system-file-systems os)))
797
798 (let* ((mappings (device-mapping-services os))
799 (root-fs (root-file-system-service))
800 (boot-fs (boot-file-system-service os))
801 (non-boot-fs (non-boot-file-system-service os))
802 (swaps (swap-services os))
803 (procs (service user-processes-service-type))
804 (host-name (operating-system-host-name os))
805 (hosts-file (%operating-system-hosts-file os))
806 (entries (operating-system-directory-base-entries os)))
807 (cons* (service system-service-type entries)
808 (service linux-builder-service-type
809 (linux-builder-configuration
810 (kernel (operating-system-kernel os))
811 (modules (operating-system-kernel-loadable-modules os))))
812 %boot-service
813
814 ;; %SHEPHERD-ROOT-SERVICE must come last so that the gexp that
815 ;; execs shepherd comes last in the boot script (XXX). Likewise,
816 ;; the cleanup service must come first so that its gexp runs before
817 ;; activation code.
818 (service cleanup-service-type #f)
819 %activation-service
820 %shepherd-root-service
821
822 (pam-root-service (operating-system-pam-services os))
823 ;; Make sure that privileged-programs activation script
824 ;; runs after accounts are created
825 (service privileged-program-service-type
826 (append (operating-system-privileged-programs os)
827 (operating-system-setuid-programs os)))
828 (account-service (append (operating-system-accounts os)
829 (operating-system-groups os))
830 (operating-system-skeletons os))
831 (operating-system-etc-service os)
832 ;; XXX: hosts-file is deprecated
833 (if hosts-file
834 (simple-service 'deprecated-hosts-file etc-service-type
835 (list `("hosts" ,hosts-file)))
836 (service hosts-service-type
837 (local-host-entries host-name)))
838 (service fstab-service-type
839 (filter file-system-needed-for-boot?
840 (operating-system-file-systems os)))
841 (session-environment-service
842 (operating-system-environment-variables os))
843 (service host-name-service-type host-name)
844 procs root-fs
845 (service profile-service-type
846 (operating-system-packages os))
847 boot-fs non-boot-fs
848 (append mappings swaps
849
850 ;; Add the firmware service.
851 (list %linux-bare-metal-service
852 (service firmware-service-type
853 (operating-system-firmware os)))))))
854
855(define (hurd-default-essential-services os)
856 (let ((host-name (operating-system-host-name os))
857 (hosts-file (%operating-system-hosts-file os))
858 (entries (operating-system-directory-base-entries os)))
859 (cons* (service system-service-type entries)
860 %boot-service
861 %hurd-startup-service
862 %activation-service
863 (service shepherd-root-service-type)
864
865 (service user-processes-service-type)
866 ;; Make sure that privileged-programs activation script
867 ;; runs after accounts are created
868 (service privileged-program-service-type
869 (append (operating-system-privileged-programs os)
870 (operating-system-setuid-programs os)))
871 (account-service (append (operating-system-accounts os)
872 (operating-system-groups os))
873 (operating-system-skeletons os))
874 (root-file-system-service)
875 (service file-system-service-type '())
876 (service fstab-service-type
877 (filter file-system-needed-for-boot?
878 (operating-system-file-systems os)))
879 (pam-root-service (operating-system-pam-services os))
880 (operating-system-etc-service os)
881 ;; XXX: hosts-file is deprecated
882 (if hosts-file
883 (simple-service 'deprecated-hosts-file etc-service-type
884 (list `("hosts" ,hosts-file)))
885 (service hosts-service-type
886 (local-host-entries host-name)))
887 (service profile-service-type (operating-system-packages os))
888 (swap-services os))))
889
890(define* (operating-system-services os)
891 "Return all the services of OS, including \"essential\" services."
892 (instantiate-missing-services
893 (append (operating-system-user-services os)
894 (operating-system-essential-services os))))
895
896(define (operating-system-with-gc-roots os roots)
897 "Return a variant of OS where ROOTS are registered as GC roots."
898 (operating-system
899 (inherit os)
900
901 ;; We use this procedure for the installation OS, which already defines GC
902 ;; roots. Add ROOTS to those.
903 (services (cons (simple-service 'extra-root
904 gc-root-service-type roots)
905 (operating-system-user-services os)))))
906
907(define (operating-system-configuration-file os)
908 "Return the configuration file of OS, based on its 'location' field, or #f
909if it could not be determined."
910 (let ((file (and=> (operating-system-location os)
911 location-file)))
912 (and file
913 (or (and (string-prefix? "/" file) file)
914 (search-path %load-path file)))))
915
916(define* (operating-system-with-provenance os
917 #:optional
918 (config-file
919 (operating-system-configuration-file
920 os)))
921 "Return a variant of OS that stores its own provenance information,
922including CONFIG-FILE, if available. This is achieved by adding an instance
923of PROVENANCE-SERVICE-TYPE to its services."
924 (operating-system
925 (inherit os)
926 (services (cons (service provenance-service-type config-file)
927 (operating-system-user-services os)))))
928
929
930;;;
931;;; /etc.
932;;;
933
934(define %base-firmware
935 ;; Firmware usable by default.
936 (list ath9k-htc-ar7010-firmware
937 ath9k-htc-ar9271-firmware
938 openfwwf-firmware))
939
940(define %base-packages-artwork
941 ;; Default set of artwork packages.
942 (list guix-backgrounds
943 guix-icons))
944
945(define %base-packages-utils
946 ;; Default set of utilities packages.
947 (cons* procps psmisc which
948 shadow ;for 'passwd'
949
950 e2fsprogs ;for lsattr, chattr, etc.
951
952 guile-3.0-latest
953
954 (list bash coreutils findutils grep sed
955 diffutils patch gawk tar
956 gzip bzip2 lzip xz zstd)))
957
958(define %base-packages-linux
959 ;; Default set of linux specific packages.
960 (list pciutils usbutils
961 util-linux+udev
962 ;; Get 'insmod' & co. from kmod, not module-init-tools, since udev
963 ;; already depends on it anyway.
964 kmod eudev))
965
966(define %base-packages-interactive
967 ;; Default set of common interactive packages.
968 (list less mg nano
969 nvi
970 man-db
971 info-reader ;the standalone Info reader (no Perl)
972 kbd
973 ;; The 'sudo' command is already in %SETUID-PROGRAMS, but we also
974 ;; want the other commands and the man pages (notably because
975 ;; auto-completion in Emacs shell relies on man pages.)
976 sudo
977 guile-readline guile-colorized))
978
979(define %base-packages-networking
980 ;; Default set of networking packages.
981 (list inetutils isc-dhcp
982 iproute
983 wget
984 nss-certs
985 ;; wireless-tools is deprecated in favor of iw, but it's still what
986 ;; many people are familiar with, so keep it around.
987 iw wireless-tools))
988
989(define-deprecated %base-packages-disk-utilities #f '())
990
991(define %base-packages
992 ;; Default set of packages globally visible. It should include anything
993 ;; required for basic administrator tasks.
994 (append %base-packages-interactive
995 %base-packages-linux
996 %base-packages-networking
997 %base-packages-utils))
998
999(define %default-issue
1000 ;; Default contents for /etc/issue.
1001 "
1002This is the GNU system. Welcome.\n")
1003
1004(define-deprecated (local-host-aliases host-name)
1005 local-host-entries
1006 "Return aliases for HOST-NAME, to be used in /etc/hosts."
1007 (string-append "127.0.0.1 localhost " host-name "\n"
1008 "::1 localhost " host-name "\n"))
1009
1010(define (local-host-entries host-name)
1011 "Return <host> records for @var{host-name}."
1012 (map (lambda (address)
1013 (host address "localhost" (list host-name)))
1014 '("127.0.0.1" "::1")))
1015
1016(define (validated-sudoers-file file)
1017 "Return a copy of FILE, a sudoers file, after checking that it is
1018syntactically correct."
1019 (computed-file "sudoers"
1020 (with-imported-modules '((guix build utils))
1021 #~(begin
1022 (use-modules (guix build utils))
1023
1024 (invoke #+(file-append sudo "/sbin/visudo")
1025 "--check" "--file" #$file)
1026 (copy-file #$file #$output)))))
1027
1028(define os-release
1029 (plain-file "os-release" "\
1030NAME=\"Guix System\"
1031ID=guix
1032PRETTY_NAME=\"Guix System\"
1033LOGO=guix-icon
1034HOME_URL=\"https://guix.gnu.org\"
1035DOCUMENTATION_URL=\"https://guix.gnu.org/en/manual\"
1036SUPPORT_URL=\"https://guix.gnu.org/en/help\"
1037BUG_REPORT_URL=\"https://lists.gnu.org/mailman/listinfo/bug-guix\"
1038"))
1039
1040(define* (operating-system-etc-service os)
1041 "Return a <service> that builds a directory containing the static part of
1042the /etc directory."
1043 (let* ((login.defs
1044 (plain-file "login.defs"
1045 (string-append
1046 "# Default paths for non-login shells started by su(1).\n"
1047 "ENV_PATH /run/privileged/bin:"
1048 "/run/current-system/profile/bin:"
1049 "/run/current-system/profile/sbin\n"
1050 "ENV_SUPATH /run/privileged/bin:"
1051 "/run/current-system/profile/bin:"
1052 "/run/current-system/profile/sbin\n"
1053
1054 "\n"
1055 "# Allow 'chfn' to change the full name,\n"
1056 "# room number, and so on.\n"
1057 "CHFN_RESTRICT frwh\n")))
1058
1059 (hurd (operating-system-hurd os))
1060 (issue (plain-file "issue" (operating-system-issue os)))
1061 (nsswitch (and=> (operating-system-name-service-switch os)
1062 (compose (cut plain-file "nsswitch.conf" <>)
1063 name-service-switch->string)))
1064 (sudoers (operating-system-sudoers-file os))
1065
1066 ;; Startup file for POSIX-compliant login shells, which set system-wide
1067 ;; environment variables.
1068 (profile (mixed-text-file "profile" "\
1069# Crucial variables that could be missing in the profiles' 'etc/profile'
1070# because they would require combining both profiles.
1071# FIXME: See <http://bugs.gnu.org/20255>.
1072export MANPATH=$HOME/.guix-profile/share/man:/run/current-system/profile/share/man
1073export INFOPATH=$HOME/.guix-profile/share/info:/run/current-system/profile/share/info
1074export XDG_DATA_DIRS=$HOME/.guix-profile/share:/run/current-system/profile/share
1075export XDG_CONFIG_DIRS=$HOME/.guix-profile/etc/xdg:/run/current-system/profile/etc/xdg
1076
1077# Make sure libXcursor finds cursors installed into user or system profiles. See <http://bugs.gnu.org/24445>
1078export XCURSOR_PATH=$HOME/.icons:$HOME/.guix-profile/share/icons:/run/current-system/profile/share/icons
1079
1080# Ignore the default value of 'PATH'.
1081unset PATH
1082
1083# Load the system profile's settings.
1084GUIX_PROFILE=/run/current-system/profile ; \\
1085. /run/current-system/profile/etc/profile
1086
1087# Since 'lshd' does not use pam_env, /etc/environment must be explicitly
1088# loaded when someone logs in via SSH. See <http://bugs.gnu.org/22175>.
1089# We need 'PATH' to be defined here, for 'cat' and 'cut'. Do this before
1090# reading the user's 'etc/profile' to allow variables to be overridden.
1091if [ -f /etc/environment -a -n \"$SSH_CLIENT\" \\
1092 -a -z \"$LINUX_MODULE_DIRECTORY\" ]
1093then
1094 . /etc/environment
1095 export `cat /etc/environment | cut -d= -f1`
1096fi
1097
1098# Arrange so that ~/.config/guix/current comes first,
1099# and guix-home comes before guix-profile.
1100for profile in \"$HOME/.guix-profile\" \\
1101 \"$HOME/.guix-home/profile\" \\
1102 \"$HOME/.config/guix/current\"
1103do
1104 if [ -f \"$profile/etc/profile\" ]
1105 then
1106 # Load the user profile's settings.
1107 GUIX_PROFILE=\"$profile\" ; \\
1108 . \"$profile/etc/profile\"
1109 else
1110 # At least define this one so that basic things just work
1111 # when the user installs their first package.
1112 export PATH=\"$profile/bin:$PATH\"
1113 fi
1114done
1115
1116# Clean up after ourselves.
1117unset GUIX_PROFILE
1118
1119# Prepend privileged programs.
1120export PATH=/run/privileged/bin:$PATH
1121
1122# Arrange so that ~/.config/guix/current/share/info comes first.
1123export INFOPATH=\"$HOME/.config/guix/current/share/info:$INFOPATH\"
1124
1125# Set the umask, notably for users logging in via 'lsh'.
1126# See <http://bugs.gnu.org/22650>.
1127umask 022
1128
1129# Allow Hunspell-based applications (IceCat, LibreOffice, etc.) to
1130# find dictionaries.
1131export DICPATH=\"$HOME/.guix-profile/share/hunspell:/run/current-system/profile/share/hunspell\"
1132
1133# Allow GStreamer-based applications to find plugins.
1134export GST_PLUGIN_PATH=\"$HOME/.guix-profile/lib/gstreamer-1.0\"
1135
1136for i in /etc/profile.d/*.sh; do
1137 if [ -r \"$i\" ]; then
1138 if [ \"${-#*i}\" != \"$-\" ]; then
1139 . \"$i\"
1140 else
1141 . \"$i\" >/dev/null
1142 fi
1143 fi
1144done
1145unset i
1146
1147if [ -n \"$BASH_VERSION\" -a -f /etc/bashrc ]; then
1148 # Load Bash-specific initialization code, taking care to not source
1149 # /etc/bashrc when invoked from a non-interactive SSH shell,
1150 # to avoid recursion (/etc/bashrc also sources /etc/profile
1151 # in the non-login, non-interactive SSH case).
1152 [[ $- != *i* && -n $SSH_CLIENT ]] || source /etc/bashrc
1153fi
1154")))
1155 (service etc-service-type
1156 `(("os-release" ,os-release)
1157 ("services" ,(file-append net-base "/etc/services"))
1158 ("protocols" ,(file-append net-base "/etc/protocols"))
1159 ("rpc" ,(file-append net-base "/etc/rpc"))
1160 ("login.defs" ,login.defs)
1161 ("issue" ,issue)
1162 ,@(if nsswitch `(("nsswitch.conf" ,nsswitch)) '())
1163 ("profile" ,profile)
1164 ("bashrc" ,%default-bashrc)
1165 ;; Write the operating-system-host-name to /etc/hostname to prevent
1166 ;; NetworkManager from changing the system's hostname when connecting
1167 ;; to certain networks. Some discussion at
1168 ;; https://lists.gnu.org/archive/html/help-guix/2017-09/msg00037.html
1169 ("hostname" ,(plain-file "hostname" (operating-system-host-name os)))
1170 ;; Some programs (e.g., GLib) look at /etc/timezone to find the
1171 ;; name of the current timezone. For details, see
1172 ;; https://lists.gnu.org/archive/html/guix-devel/2019-07/msg00166.html
1173 ;; Some programs expect a terminating newline.
1174 ("timezone" ,(plain-file "timezone"
1175 (string-append
1176 (string-trim-both
1177 (operating-system-timezone os))
1178 "\n")))
1179 ("localtime" ,(file-append tzdata "/share/zoneinfo/"
1180 (operating-system-timezone os)))
1181 ,@(if sudoers
1182 `(("sudoers" ,(validated-sudoers-file sudoers)))
1183 '())
1184 ,@(if hurd
1185 `(("login" ,(file-append hurd "/etc/login"))
1186 ("motd" ,(file-append hurd "/etc/motd"))
1187 ("ttys" ,(file-append hurd "/etc/ttys")))
1188 '())))))
1189
1190(define %root-account
1191 ;; Default root account.
1192 (user-account
1193 (name "root")
1194 (password "")
1195 (uid 0) (group "root")
1196 (comment "System administrator")
1197 (home-directory "/root")))
1198
1199(define (operating-system-accounts os)
1200 "Return the user accounts for OS, including an obligatory 'root' account,
1201and excluding accounts requested by services."
1202 ;; Make sure there's a root account.
1203 (if (find (lambda (user)
1204 (and=> (user-account-uid user) zero?))
1205 (operating-system-users os))
1206 (operating-system-users os)
1207 (cons %root-account (operating-system-users os))))
1208
1209(define (maybe-string->file file-name thing)
1210 "If THING is a string, return a <plain-file> with THING as its content.
1211Otherwise just return THING.
1212
1213This is for backward-compatibility of fields that used to be strings and are
1214now file-like objects.."
1215 (match thing
1216 ((? string?)
1217 (warning (G_ "using a string for file '~a' is deprecated; \
1218use 'plain-file' instead~%")
1219 file-name)
1220 (plain-file file-name thing))
1221 (x
1222 x)))
1223
1224(define (maybe-file->monadic file-name thing)
1225 "If THING is a value in %STORE-MONAD, return it as is; otherwise return
1226THING in the %STORE-MONAD.
1227
1228This is for backward-compatibility of fields that used to be monadic values
1229and are now file-like objects."
1230 (with-monad %store-monad
1231 (match thing
1232 ((? procedure?)
1233 (warning (G_ "using a monadic value for '~a' is deprecated; \
1234use 'plain-file' instead~%")
1235 file-name)
1236 thing)
1237 (x
1238 (return x)))))
1239
1240(define (operating-system-etc-directory os)
1241 "Return that static part of the /etc directory of OS."
1242 (etc-directory
1243 (fold-services (operating-system-services os)
1244 #:target-type etc-service-type)))
1245
1246(define (operating-system-environment-variables os)
1247 "Return the environment variables of OS for
1248@var{session-environment-service-type}, to be used in @file{/etc/environment}."
1249 `(("LANG" . ,(operating-system-locale os))
1250 ;; Note: No need to set 'TZ' since (1) we provide /etc/localtime, and (2)
1251 ;; it doesn't work for setuid binaries. See <https://bugs.gnu.org/29212>.
1252 ("TZDIR" . ,(file-append tzdata "/share/zoneinfo"))
1253 ;; Tell 'modprobe' & co. where to look for modules.
1254 ("LINUX_MODULE_DIRECTORY" . "/run/booted-system/kernel/lib/modules")
1255 ;; These variables are honored by OpenSSL (libssl) and Git.
1256 ("SSL_CERT_DIR" . "/etc/ssl/certs")
1257 ("SSL_CERT_FILE" . "/etc/ssl/certs/ca-certificates.crt")
1258 ("GIT_SSL_CAINFO" . "/etc/ssl/certs/ca-certificates.crt")
1259
1260 ;; 'GTK_DATA_PREFIX' must name one directory where GTK+ themes are
1261 ;; searched for.
1262 ("GTK_DATA_PREFIX" . "/run/current-system/profile")
1263
1264 ;; By default, applications that use D-Bus, such as Emacs, abort at startup
1265 ;; when /etc/machine-id is missing. Make sure these warnings are non-fatal.
1266 ("DBUS_FATAL_WARNINGS" . "0")))
1267
1268(define %default-privileged-programs
1269 (let ((shadow (@ (gnu packages admin) shadow)))
1270 (cons*
1271 (privileged-program
1272 (program (file-append inetutils "/bin/ping"))
1273 (capabilities "cap_net_raw=ep"))
1274 (privileged-program
1275 (program (file-append inetutils "/bin/ping6"))
1276 (capabilities "cap_net_raw=ep"))
1277 (map file-like->setuid-program
1278 (list (file-append shadow "/bin/passwd")
1279 (file-append shadow "/bin/chfn")
1280 (file-append shadow "/bin/sg")
1281 (file-append shadow "/bin/su")
1282 (file-append shadow "/bin/newgrp")
1283 (file-append shadow "/bin/newuidmap")
1284 (file-append shadow "/bin/newgidmap")
1285 (file-append sudo "/bin/sudo")
1286 (file-append sudo "/bin/sudoedit")
1287 (file-append fuse-2 "/bin/fusermount")
1288 (file-append fuse "/bin/fusermount3")
1289
1290 ;; To allow mounts with the "user" option, "mount" and "umount" must
1291 ;; be setuid-root.
1292 (file-append util-linux "/bin/mount")
1293 (file-append util-linux "/bin/umount"))))))
1294
1295(define %setuid-programs
1296 ;; Do not add to this list or use it in new code! It's defined only to ease
1297 ;; transition to %default-privileged-programs and will be removed. Some rare
1298 ;; use cases already break, such as the obvious (remove … %setuid-programs).
1299 '())
1300
1301(define %sudoers-specification
1302 ;; Default /etc/sudoers contents: 'root' and all members of the 'wheel'
1303 ;; group can do anything. See
1304 ;; <http://www.sudo.ws/sudo/man/1.8.10/sudoers.man.html>.
1305 ;; TODO: Add a declarative API.
1306 (plain-file "sudoers" "\
1307root ALL=(ALL) ALL
1308%wheel ALL=(ALL) ALL\n"))
1309
1310(define* (operating-system-activation-script os)
1311 "Return the activation script for OS---i.e., the code that \"activates\" the
1312stateful part of OS, including user accounts and groups, special directories,
1313etc."
1314 (let* ((services (operating-system-services os))
1315 (activation (fold-services services
1316 #:target-type activation-service-type)))
1317 (activation-service->script activation)))
1318
1319(define* (operating-system-boot-script os)
1320 "Return the boot script for OS---i.e., the code started by the initrd once
1321we're running in the final root."
1322 (let* ((services (operating-system-services os))
1323 (boot (fold-services services #:target-type boot-service-type)))
1324 (service-value boot)))
1325
1326(define (operating-system-user-accounts os)
1327 "Return the list of user accounts of OS."
1328 (let* ((services (operating-system-services os))
1329 (account (fold-services services
1330 #:target-type account-service-type)))
1331 (filter user-account?
1332 (service-value account))))
1333
1334(define (operating-system-shepherd-service-names os)
1335 "Return the list of Shepherd service names for OS."
1336 (append-map shepherd-service-provision
1337 (shepherd-configuration-services
1338 (service-value
1339 (fold-services (operating-system-services os)
1340 #:target-type
1341 shepherd-root-service-type)))))
1342
1343(define* (operating-system-derivation os)
1344 "Return a derivation that builds OS."
1345 (let* ((services (operating-system-services os))
1346 (system (fold-services services)))
1347 ;; SYSTEM contains the derivation as a monadic value.
1348 (service-value system)))
1349
1350(define* (operating-system-profile os)
1351 "Return a derivation that builds the system profile of OS."
1352 (mlet* %store-monad
1353 ((services -> (operating-system-services os))
1354 (profile (fold-services services
1355 #:target-type profile-service-type)))
1356 (match profile
1357 (("profile" profile)
1358 (return profile)))))
1359
1360(define (operating-system-root-file-system os)
1361 "Return the root file system of OS."
1362 (or (find (lambda (fs)
1363 (string=? "/" (file-system-mount-point fs)))
1364 (operating-system-file-systems os))
1365 (raise (condition
1366 (&message (message "missing root file system"))
1367 (&error-location
1368 (location (operating-system-location os)))))))
1369
1370(define (operating-system-initrd-file os)
1371 "Return a file-like object for the initrd file of OS."
1372 (define boot-file-systems
1373 (filter file-system-needed-for-boot?
1374 (operating-system-file-systems os)))
1375
1376 (define mapped-devices
1377 (operating-system-boot-mapped-devices os))
1378
1379 (define make-initrd
1380 (operating-system-initrd os))
1381
1382 (make-initrd boot-file-systems
1383 #:linux (operating-system-kernel os)
1384 #:linux-modules
1385 (operating-system-initrd-modules os)
1386 #:mapped-devices mapped-devices
1387 #:keyboard-layout (operating-system-keyboard-layout os)))
1388
1389(define* (operating-system-uuid os #:optional (type 'dce))
1390 "Compute UUID object with a deterministic \"UUID\" for OS, of the given
1391TYPE (one of 'iso9660 or 'dce). Return a UUID object."
1392 ;; Note: For this to be deterministic, we must not hash things that contains
1393 ;; (directly or indirectly) procedures, for example. That rules out
1394 ;; anything that contains gexps, thunk or delayed record fields, etc.
1395
1396 (define service-name
1397 (compose service-type-name service-kind))
1398
1399 (define (file-system-digest fs)
1400 ;; Return a hashable digest that does not contain 'dependencies' since
1401 ;; this field can contain procedures.
1402 (let ((device (file-system-device fs)))
1403 (list (file-system-mount-point fs)
1404 (file-system-type fs)
1405 (file-system-device->string device)
1406 (file-system-options fs))))
1407
1408 (if (eq? type 'iso9660)
1409 (let ((pad (compose (cut string-pad <> 2 #\0)
1410 number->string))
1411 (h (hash (map service-name (operating-system-services os))
1412 3600)))
1413 (bytevector->uuid
1414 (string->iso9660-uuid
1415 (string-append "1970-01-01-"
1416 (pad (hash (operating-system-host-name os) 24)) "-"
1417 (pad (quotient h 60)) "-"
1418 (pad (modulo h 60)) "-"
1419 (pad (hash (map file-system-digest
1420 (operating-system-file-systems os))
1421 100))))
1422 'iso9660))
1423 (bytevector->uuid
1424 (uint-list->bytevector
1425 (list (hash (map file-system-digest
1426 (operating-system-file-systems os))
1427 (- (expt 2 32) 1))
1428 (hash (operating-system-host-name os)
1429 (- (expt 2 32) 1))
1430 (hash (map service-name (operating-system-services os))
1431 (- (expt 2 32) 1))
1432 (hash (map file-system-digest (operating-system-file-systems os))
1433 (- (expt 2 32) 1)))
1434 (endianness little)
1435 4)
1436 type)))
1437
1438(define (locale-name->definition* name)
1439 "Variant of 'locale-name->definition' that raises an error upon failure."
1440 (match (locale-name->definition name)
1441 (#f
1442 (raise (formatted-message (G_ "~a: invalid locale name") name)))
1443 (def def)))
1444
1445(define (operating-system-locale-directory os)
1446 "Return the directory containing the locales compiled for the definitions
1447listed in OS. The C library expects to find it under
1448/run/current-system/locale."
1449 (define name
1450 (operating-system-locale os))
1451
1452 (define definitions
1453 ;; While we're at it, check whether NAME is defined and add it if needed.
1454 (if (member name (map locale-definition-name
1455 (operating-system-locale-definitions os)))
1456 (operating-system-locale-definitions os)
1457 (cons (locale-name->definition* name)
1458 (operating-system-locale-definitions os))))
1459
1460 (locale-directory definitions
1461 #:libcs (operating-system-locale-libcs os)))
1462
1463(define* (kernel->boot-label kernel #:key hurd)
1464 "Return a label for the bootloader menu entry that boots KERNEL."
1465 (cond ((package? hurd)
1466 (string-append "GNU with the "
1467 (string-titlecase (package-name hurd)) " "
1468 (package-version hurd)))
1469 ((package? kernel)
1470 (string-append "GNU with "
1471 (string-titlecase (package-name kernel)) " "
1472 (package-version kernel)))
1473 ((inferior-package? kernel)
1474 (string-append "GNU with "
1475 (string-titlecase (inferior-package-name kernel)) " "
1476 (inferior-package-version kernel)))
1477 (else "GNU")))
1478
1479(define (operating-system-default-label os)
1480 "Return the default label for OS, as it will appear in the bootloader menu
1481entry."
1482 (kernel->boot-label (operating-system-kernel os)
1483 #:hurd (operating-system-hurd os)))
1484
1485(define (store-file-system file-systems)
1486 "Return the file system object among FILE-SYSTEMS that contains the store."
1487 (match (filter (lambda (fs)
1488 (and (file-system-mount? fs)
1489 (not (memq 'bind-mount (file-system-flags fs)))
1490 (string-prefix? (file-system-mount-point fs)
1491 (%store-prefix))))
1492 file-systems)
1493 ((and candidates (head . tail))
1494 (reduce (lambda (fs1 fs2)
1495 (if (> (string-length (file-system-mount-point fs1))
1496 (string-length (file-system-mount-point fs2)))
1497 fs1
1498 fs2))
1499 head
1500 candidates))))
1501
1502(define (operating-system-store-file-system os)
1503 "Return the file system that contains the store of OS."
1504 (store-file-system (operating-system-file-systems os)))
1505
1506(define* (operating-system-bootcfg os #:optional (old-entries '()))
1507 "Return the bootloader configuration file for OS. Use OLD-ENTRIES,
1508a list of <menu-entry>, to populate the \"old entries\" menu."
1509 (let* ((file-systems (operating-system-file-systems os))
1510 (root-fs (operating-system-root-file-system os))
1511 (root-device (file-system-device root-fs))
1512 (locale (operating-system-locale os))
1513 (crypto-devices (operating-system-bootloader-crypto-devices os))
1514 (params (operating-system-boot-parameters
1515 os root-device
1516 #:system-kernel-arguments? #t))
1517 (entry (boot-parameters->menu-entry params))
1518 (bootloader-conf (operating-system-bootloader os)))
1519
1520 (define generate-config-file
1521 (bootloader-configuration-file-generator
1522 (bootloader-configuration-bootloader bootloader-conf)))
1523
1524 (generate-config-file bootloader-conf (list entry)
1525 #:old-entries old-entries
1526 #:locale locale
1527 #:store-crypto-devices crypto-devices
1528 #:store-directory-prefix
1529 (btrfs-store-subvolume-file-name file-systems))))
1530
1531(define (operating-system-multiboot-modules os)
1532 (if (operating-system-hurd os) (hurd-multiboot-modules os) '()))
1533
1534(define (hurd-multiboot-modules os)
1535 (let* ((hurd (operating-system-hurd os))
1536 (pci-arbiter-command
1537 (list (file-append hurd "/hurd/pci-arbiter.static")
1538 "pci-arbiter"
1539 "--host-priv-port='${host-port}'"
1540 "--device-master-port='${device-port}'"
1541 "--next-task='${disk-task}'"
1542 "'$(pci-task=task-create)'"
1543 "'$(task-resume)'"))
1544 (rumpdisk-command
1545 (list (file-append hurd "/hurd/rumpdisk.static")
1546 "rumpdisk"
1547 "--next-task='${fs-task}'"
1548 "'$(disk-task=task-create)'"))
1549 (root-file-system-command
1550 (list (file-append hurd "/hurd/ext2fs.static")
1551 "ext2fs"
1552 "--multiboot-command-line='${kernel-command-line}'"
1553 "--exec-server-task='${exec-task}'"
1554 "--store-type=typed"
1555 "'${root}'"
1556 "'$(fs-task=task-create)'"))
1557 (target (%current-target-system))
1558 (libc (if target
1559 (with-parameters ((%current-target-system #f))
1560 ;; TODO: cross-libc has extra patches for the Hurd;
1561 ;; remove in next rebuild cycle
1562 (cross-libc target))
1563 glibc))
1564 (exec-server-command
1565 ;; XXX: Run the statically-linked 'exec' to work around
1566 ;; <https://issues.guix.gnu.org/58320>, which manifests on some
1567 ;; machines.
1568
1569 ;; (list (file-append libc "/lib/ld.so.1") "exec"
1570 ;; (file-append hurd "/hurd/exec") "'$(exec-task=task-create)'")
1571 (list (file-append hurd "/hurd/exec.static") "exec"
1572 "'$(exec-task=task-create)'")))
1573 (list pci-arbiter-command
1574 rumpdisk-command
1575 root-file-system-command
1576 exec-server-command)))
1577
1578(define* (operating-system-boot-parameters os root-device
1579 #:key system-kernel-arguments?)
1580 "Return a monadic <boot-parameters> record that describes the boot
1581parameters of OS. When SYSTEM-KERNEL-ARGUMENTS? is true, add the kernel
1582arguments 'root', 'gnu.load' and 'gnu.system' to <boot-parameters>. The
1583SYSTEM-KERNEL-ARGUMENTS? should only be used in necessity, as the 'gnu.load'
1584and 'gnu.system' values are self-referential (they refer to the system), thus
1585susceptible to introduce a cyclic dependency."
1586 (let* ((initrd (and (not (operating-system-hurd os))
1587 (operating-system-initrd-file os)))
1588 (store (operating-system-store-file-system os))
1589 (file-systems (operating-system-file-systems os))
1590 (crypto-devices (operating-system-bootloader-crypto-devices os))
1591 (locale (operating-system-locale os))
1592 (bootloader (bootloader-configuration-bootloader
1593 (operating-system-bootloader os)))
1594 (bootloader-name (bootloader-name bootloader))
1595 (label (operating-system-label os))
1596 (multiboot-modules (operating-system-multiboot-modules os)))
1597 (boot-parameters
1598 (label label)
1599 (root-device root-device)
1600 (kernel (operating-system-kernel-file os))
1601 (kernel-arguments
1602 (if system-kernel-arguments?
1603 (operating-system-kernel-arguments os root-device)
1604 (operating-system-user-kernel-arguments os)))
1605 (initrd initrd)
1606 (multiboot-modules multiboot-modules)
1607 (bootloader-name bootloader-name)
1608 (bootloader-menu-entries
1609 (bootloader-configuration-menu-entries (operating-system-bootloader os)))
1610 (locale locale)
1611 (store-device (ensure-not-/dev (file-system-device store)))
1612 (store-directory-prefix (btrfs-store-subvolume-file-name file-systems))
1613 (store-crypto-devices crypto-devices)
1614 (store-mount-point (file-system-mount-point store)))))
1615
1616(define (device->sexp device)
1617 "Serialize DEVICE as an sexp (really, as an object with a read syntax.)"
1618 (match device
1619 ((? uuid? uuid)
1620 `(uuid ,(uuid-type uuid) ,(uuid-bytevector uuid)))
1621 ((? file-system-label? label)
1622 `(file-system-label ,(file-system-label->string label)))
1623 (_
1624 device)))
1625
1626(define* (operating-system-boot-parameters-file os)
1627 "Return a file that describes the boot parameters of OS. The primary use
1628of this file is the reconstruction of GRUB menu entries for old
1629configurations."
1630 (let* ((root (operating-system-root-file-system os))
1631 (device (file-system-device root))
1632 (params (operating-system-boot-parameters os device)))
1633 (scheme-file "parameters"
1634 #~(boot-parameters
1635 (version #$(boot-parameters-version params))
1636 (label #$(boot-parameters-label params))
1637 (root-device
1638 #$(device->sexp
1639 (boot-parameters-root-device params)))
1640 (kernel #$(boot-parameters-kernel params))
1641 (kernel-arguments
1642 #$(boot-parameters-kernel-arguments params))
1643 #$@(if (boot-parameters-initrd params)
1644 #~((initrd #$(boot-parameters-initrd params)))
1645 #~())
1646 #$@(if (pair? (boot-parameters-multiboot-modules params))
1647 #~((multiboot-modules
1648 #$(boot-parameters-multiboot-modules params)))
1649 #~())
1650 (bootloader-name #$(boot-parameters-bootloader-name params))
1651 (bootloader-menu-entries
1652 #$(map menu-entry->sexp
1653 (or (and=> (operating-system-bootloader os)
1654 bootloader-configuration-menu-entries)
1655 '())))
1656 (locale #$(boot-parameters-locale params))
1657 (store
1658 (device
1659 #$(device->sexp (boot-parameters-store-device params)))
1660 (mount-point #$(boot-parameters-store-mount-point
1661 params))
1662 (directory-prefix
1663 #$(boot-parameters-store-directory-prefix params))
1664 (crypto-devices
1665 #$(map device->sexp
1666 (boot-parameters-store-crypto-devices params)))))
1667 #:set-load-path? #f)))
1668
1669(define-gexp-compiler (operating-system-compiler (os <operating-system>)
1670 system target)
1671 ((store-lift
1672 (lambda (store)
1673 ;; XXX: This is not super elegant but we can't pass SYSTEM and TARGET to
1674 ;; 'operating-system-derivation'.
1675 (parameterize ((%current-system system)
1676 (%current-target-system target))
1677 (run-with-store store
1678 (mbegin %store-monad
1679 (set-guile-for-build (default-guile))
1680 (operating-system-derivation os))
1681 #:system system
1682 #:target target))))))
1683
1684;;; system.scm ends here