projects/guix·blob python-team · refs

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