projects/guix·blob java-team · refs

1694 lines · 69.3 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(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 package-management)
66 #:use-module (gnu packages pciutils)
67 #:use-module (gnu packages texinfo)
68 #:use-module (gnu packages text-editors)
69 #:use-module (gnu packages wget)
70 #:use-module (gnu services)
71 #:use-module (gnu services shepherd)
72 #:use-module (gnu services base)
73 #:use-module (gnu bootloader)
74 #:use-module (gnu system shadow)
75 #:use-module (gnu system nss)
76 #:use-module (gnu system locale)
77 #:use-module (gnu system pam)
78 #:use-module (gnu system linux-initrd)
79 #:use-module (gnu system privilege)
80 #:use-module (gnu system setuid)
81 #:use-module (gnu system uuid)
82 #:use-module (gnu system file-systems)
83 #:use-module (gnu system mapped-devices)
84 #:use-module (ice-9 format)
85 #:use-module (ice-9 match)
86 #:use-module (srfi srfi-1)
87 #:use-module (srfi srfi-26)
88 #:use-module (srfi srfi-34)
89 #:use-module (srfi srfi-35)
90 #:use-module (srfi srfi-71)
91 #:use-module (rnrs bytevectors)
92 #:export (operating-system
93 operating-system?
94 this-operating-system
95
96 operating-system-bootloader
97 operating-system-services
98 operating-system-essential-services
99 operating-system-default-essential-services
100 operating-system-user-services
101 operating-system-packages
102 operating-system-host-name
103 operating-system-hosts-file ;deprecated
104 operating-system-hurd
105 operating-system-kernel
106 operating-system-kernel-file
107 operating-system-kernel-arguments
108 operating-system-label
109 operating-system-default-label
110 operating-system-initrd-modules
111 operating-system-initrd
112 operating-system-initrd-file
113 operating-system-users
114 operating-system-groups
115 operating-system-issue
116 operating-system-timezone
117 operating-system-locale
118 operating-system-locale-definitions
119 operating-system-locale-libcs
120 operating-system-mapped-devices
121 operating-system-file-systems
122 operating-system-root-file-system
123 operating-system-store-file-system
124 operating-system-user-mapped-devices
125 operating-system-boot-mapped-devices
126 operating-system-bootloader-crypto-devices
127 operating-system-activation-script
128 operating-system-user-accounts
129 operating-system-shepherd-service-names
130 operating-system-user-kernel-arguments
131 operating-system-firmware
132 operating-system-keyboard-layout
133 operating-system-name-service-switch
134 operating-system-pam-services
135 operating-system-privileged-programs
136 operating-system-setuid-programs
137 operating-system-skeletons
138 operating-system-sudoers-file
139 operating-system-swap-devices
140 operating-system-kernel-loadable-modules
141 operating-system-location
142
143 operating-system-derivation
144 operating-system-profile
145 operating-system-bootcfg
146 operating-system-etc-directory
147 operating-system-locale-directory
148 operating-system-boot-script
149 operating-system-uuid
150
151 system-linux-image-file-name
152 operating-system-with-gc-roots
153 operating-system-with-provenance
154
155 hurd-default-essential-services
156
157 boot-parameters
158 boot-parameters?
159 boot-parameters-label
160 boot-parameters-root-device
161 boot-parameters-bootloader-name
162 boot-parameters-bootloader-menu-entries
163 boot-parameters-store-crypto-devices
164 boot-parameters-store-device
165 boot-parameters-store-directory-prefix
166 boot-parameters-store-mount-point
167 boot-parameters-locale
168 boot-parameters-kernel
169 boot-parameters-kernel-arguments
170 boot-parameters-initrd
171 boot-parameters-multiboot-modules
172 boot-parameters-version
173 %boot-parameters-version
174 read-boot-parameters
175 read-boot-parameters-file
176 boot-parameters->menu-entry
177
178 local-host-aliases ;deprecated
179 local-host-entries
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 (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,
1102# and guix-home comes before guix-profile.
1103for profile in \"$HOME/.guix-profile\" \\
1104 \"$HOME/.guix-home/profile\" \\
1105 \"$HOME/.config/guix/current\"
1106do
1107 if [ -f \"$profile/etc/profile\" ]
1108 then
1109 # Load the user profile's settings.
1110 GUIX_PROFILE=\"$profile\" ; \\
1111 . \"$profile/etc/profile\"
1112 else
1113 # At least define this one so that basic things just work
1114 # when the user installs their first package.
1115 export PATH=\"$profile/bin:$PATH\"
1116 fi
1117done
1118
1119# Clean up after ourselves.
1120unset GUIX_PROFILE
1121
1122# Prepend privileged programs.
1123export PATH=/run/privileged/bin:$PATH
1124
1125# Arrange so that ~/.config/guix/current/share/info comes first.
1126export INFOPATH=\"$HOME/.config/guix/current/share/info:$INFOPATH\"
1127
1128# Set the umask, notably for users logging in via 'lsh'.
1129# See <http://bugs.gnu.org/22650>.
1130umask 022
1131
1132# Allow Hunspell-based applications (IceCat, LibreOffice, etc.) to
1133# find dictionaries.
1134export DICPATH=\"$HOME/.guix-profile/share/hunspell:/run/current-system/profile/share/hunspell\"
1135
1136# Allow GStreamer-based applications to find plugins.
1137export GST_PLUGIN_PATH=\"$HOME/.guix-profile/lib/gstreamer-1.0\"
1138
1139for i in /etc/profile.d/*.sh; do
1140 if [ -r \"$i\" ]; then
1141 if [ \"${-#*i}\" != \"$-\" ]; then
1142 . \"$i\"
1143 else
1144 . \"$i\" >/dev/null
1145 fi
1146 fi
1147done
1148unset i
1149
1150if [ -n \"$BASH_VERSION\" -a -f /etc/bashrc ]; then
1151 # Load Bash-specific initialization code, taking care to not source
1152 # /etc/bashrc when invoked from a non-interactive SSH shell,
1153 # to avoid recursion (/etc/bashrc also sources /etc/profile
1154 # in the non-login, non-interactive SSH case).
1155 [[ $- != *i* && -n $SSH_CLIENT ]] || source /etc/bashrc
1156fi
1157")))
1158 (service etc-service-type
1159 `(("os-release" ,os-release)
1160 ("services" ,(file-append net-base "/etc/services"))
1161 ("protocols" ,(file-append net-base "/etc/protocols"))
1162 ("rpc" ,(file-append net-base "/etc/rpc"))
1163 ("login.defs" ,login.defs)
1164 ("issue" ,issue)
1165 ,@(if nsswitch `(("nsswitch.conf" ,nsswitch)) '())
1166 ("profile" ,profile)
1167 ("bashrc" ,%default-bashrc)
1168 ;; Write the operating-system-host-name to /etc/hostname to prevent
1169 ;; NetworkManager from changing the system's hostname when connecting
1170 ;; to certain networks. Some discussion at
1171 ;; https://lists.gnu.org/archive/html/help-guix/2017-09/msg00037.html
1172 ("hostname" ,(plain-file "hostname" (operating-system-host-name os)))
1173 ;; Some programs (e.g., GLib) look at /etc/timezone to find the
1174 ;; name of the current timezone. For details, see
1175 ;; https://lists.gnu.org/archive/html/guix-devel/2019-07/msg00166.html
1176 ;; Some programs expect a terminating newline.
1177 ("timezone" ,(plain-file "timezone"
1178 (string-append
1179 (string-trim-both
1180 (operating-system-timezone os))
1181 "\n")))
1182 ("localtime" ,(file-append tzdata "/share/zoneinfo/"
1183 (operating-system-timezone os)))
1184 ,@(if sudoers
1185 `(("sudoers" ,(validated-sudoers-file sudoers)))
1186 '())
1187 ,@(if hurd
1188 `(("login" ,(file-append hurd "/etc/login"))
1189 ("motd" ,(file-append hurd "/etc/motd"))
1190 ("ttys" ,(file-append hurd "/etc/ttys")))
1191 '())))))
1192
1193(define %root-account
1194 ;; Default root account.
1195 (user-account
1196 (name "root")
1197 (password "")
1198 (uid 0) (group "root")
1199 (comment "System administrator")
1200 (home-directory "/root")))
1201
1202(define (operating-system-accounts os)
1203 "Return the user accounts for OS, including an obligatory 'root' account,
1204and excluding accounts requested by services."
1205 ;; Make sure there's a root account.
1206 (if (find (lambda (user)
1207 (and=> (user-account-uid user) zero?))
1208 (operating-system-users os))
1209 (operating-system-users os)
1210 (cons %root-account (operating-system-users os))))
1211
1212(define (maybe-string->file file-name thing)
1213 "If THING is a string, return a <plain-file> with THING as its content.
1214Otherwise just return THING.
1215
1216This is for backward-compatibility of fields that used to be strings and are
1217now file-like objects.."
1218 (match thing
1219 ((? string?)
1220 (warning (G_ "using a string for file '~a' is deprecated; \
1221use 'plain-file' instead~%")
1222 file-name)
1223 (plain-file file-name thing))
1224 (x
1225 x)))
1226
1227(define (maybe-file->monadic file-name thing)
1228 "If THING is a value in %STORE-MONAD, return it as is; otherwise return
1229THING in the %STORE-MONAD.
1230
1231This is for backward-compatibility of fields that used to be monadic values
1232and are now file-like objects."
1233 (with-monad %store-monad
1234 (match thing
1235 ((? procedure?)
1236 (warning (G_ "using a monadic value for '~a' is deprecated; \
1237use 'plain-file' instead~%")
1238 file-name)
1239 thing)
1240 (x
1241 (return x)))))
1242
1243(define (operating-system-etc-directory os)
1244 "Return that static part of the /etc directory of OS."
1245 (etc-directory
1246 (fold-services (operating-system-services os)
1247 #:target-type etc-service-type)))
1248
1249(define (operating-system-environment-variables os)
1250 "Return the environment variables of OS for
1251@var{session-environment-service-type}, to be used in @file{/etc/environment}."
1252 `(("LANG" . ,(operating-system-locale os))
1253 ;; Note: No need to set 'TZ' since (1) we provide /etc/localtime, and (2)
1254 ;; it doesn't work for setuid binaries. See <https://bugs.gnu.org/29212>.
1255 ("TZDIR" . ,(file-append tzdata "/share/zoneinfo"))
1256 ;; Tell 'modprobe' & co. where to look for modules.
1257 ("LINUX_MODULE_DIRECTORY" . "/run/booted-system/kernel/lib/modules")
1258 ;; These variables are honored by OpenSSL (libssl) and Git.
1259 ("SSL_CERT_DIR" . "/etc/ssl/certs")
1260 ("SSL_CERT_FILE" . "/etc/ssl/certs/ca-certificates.crt")
1261 ("GIT_SSL_CAINFO" . "/etc/ssl/certs/ca-certificates.crt")
1262
1263 ;; 'GTK_DATA_PREFIX' must name one directory where GTK+ themes are
1264 ;; searched for.
1265 ("GTK_DATA_PREFIX" . "/run/current-system/profile")
1266
1267 ;; By default, applications that use D-Bus, such as Emacs, abort at startup
1268 ;; when /etc/machine-id is missing. Make sure these warnings are non-fatal.
1269 ("DBUS_FATAL_WARNINGS" . "0")))
1270
1271(define %default-privileged-programs
1272 (let ((shadow (@ (gnu packages admin) shadow)))
1273 (cons*
1274 (privileged-program
1275 (program (file-append inetutils "/bin/ping"))
1276 (capabilities "cap_net_raw=ep"))
1277 (privileged-program
1278 (program (file-append inetutils "/bin/ping6"))
1279 (capabilities "cap_net_raw=ep"))
1280 (map file-like->setuid-program
1281 (list (file-append shadow "/bin/passwd")
1282 (file-append shadow "/bin/chfn")
1283 (file-append shadow "/bin/sg")
1284 (file-append shadow "/bin/su")
1285 (file-append shadow "/bin/newgrp")
1286 (file-append shadow "/bin/newuidmap")
1287 (file-append shadow "/bin/newgidmap")
1288 (file-append sudo "/bin/sudo")
1289 (file-append sudo "/bin/sudoedit")
1290 (file-append fuse-2 "/bin/fusermount")
1291 (file-append fuse "/bin/fusermount3")
1292
1293 ;; To allow mounts with the "user" option, "mount" and "umount" must
1294 ;; be setuid-root.
1295 (file-append util-linux "/bin/mount")
1296 (file-append util-linux "/bin/umount"))))))
1297
1298(define %setuid-programs
1299 ;; Do not add to this list or use it in new code! It's defined only to ease
1300 ;; transition to %default-privileged-programs and will be removed. Some rare
1301 ;; use cases already break, such as the obvious (remove … %setuid-programs).
1302 '())
1303
1304(define %sudoers-specification
1305 ;; Default /etc/sudoers contents: 'root' and all members of the 'wheel'
1306 ;; group can do anything. See
1307 ;; <http://www.sudo.ws/sudo/man/1.8.10/sudoers.man.html>.
1308 ;; TODO: Add a declarative API.
1309 (plain-file "sudoers" "\
1310root ALL=(ALL) ALL
1311%wheel ALL=(ALL) ALL\n"))
1312
1313(define* (operating-system-activation-script os)
1314 "Return the activation script for OS---i.e., the code that \"activates\" the
1315stateful part of OS, including user accounts and groups, special directories,
1316etc."
1317 (let* ((services (operating-system-services os))
1318 (activation (fold-services services
1319 #:target-type activation-service-type)))
1320 (activation-service->script activation)))
1321
1322(define* (operating-system-boot-script os)
1323 "Return the boot script for OS---i.e., the code started by the initrd once
1324we're running in the final root."
1325 (let* ((services (operating-system-services os))
1326 (boot (fold-services services #:target-type boot-service-type)))
1327 (service-value boot)))
1328
1329(define (operating-system-user-accounts os)
1330 "Return the list of user accounts of OS."
1331 (let* ((services (operating-system-services os))
1332 (account (fold-services services
1333 #:target-type account-service-type)))
1334 (filter user-account?
1335 (service-value account))))
1336
1337(define (operating-system-shepherd-service-names os)
1338 "Return the list of Shepherd service names for OS."
1339 (append-map shepherd-service-provision
1340 (shepherd-configuration-services
1341 (service-value
1342 (fold-services (operating-system-services os)
1343 #:target-type
1344 shepherd-root-service-type)))))
1345
1346(define* (operating-system-derivation os)
1347 "Return a derivation that builds OS."
1348 (let* ((services (operating-system-services os))
1349 (system (fold-services services)))
1350 ;; SYSTEM contains the derivation as a monadic value.
1351 (service-value system)))
1352
1353(define* (operating-system-profile os)
1354 "Return a derivation that builds the system profile of OS."
1355 (mlet* %store-monad
1356 ((services -> (operating-system-services os))
1357 (profile (fold-services services
1358 #:target-type profile-service-type)))
1359 (match profile
1360 (("profile" profile)
1361 (return profile)))))
1362
1363(define (operating-system-root-file-system os)
1364 "Return the root file system of OS."
1365 (or (find (lambda (fs)
1366 (string=? "/" (file-system-mount-point fs)))
1367 (operating-system-file-systems os))
1368 (raise (condition
1369 (&message (message "missing root file system"))
1370 (&error-location
1371 (location (operating-system-location os)))))))
1372
1373(define (operating-system-initrd-file os)
1374 "Return a file-like object for the initrd file of OS."
1375 (define boot-file-systems
1376 (filter file-system-needed-for-boot?
1377 (operating-system-file-systems os)))
1378
1379 (define mapped-devices
1380 (operating-system-boot-mapped-devices os))
1381
1382 (define make-initrd
1383 (operating-system-initrd os))
1384
1385 (make-initrd boot-file-systems
1386 #:linux (operating-system-kernel os)
1387 #:linux-modules
1388 (operating-system-initrd-modules os)
1389 #:mapped-devices mapped-devices
1390 #:keyboard-layout (operating-system-keyboard-layout os)))
1391
1392(define* (operating-system-uuid os #:optional (type 'dce))
1393 "Compute UUID object with a deterministic \"UUID\" for OS, of the given
1394TYPE (one of 'iso9660 or 'dce). Return a UUID object."
1395 ;; Note: For this to be deterministic, we must not hash things that contains
1396 ;; (directly or indirectly) procedures, for example. That rules out
1397 ;; anything that contains gexps, thunk or delayed record fields, etc.
1398
1399 (define service-name
1400 (compose service-type-name service-kind))
1401
1402 (define (file-system-digest fs)
1403 ;; Return a hashable digest that does not contain 'dependencies' since
1404 ;; this field can contain procedures.
1405 (let ((device (file-system-device fs)))
1406 (list (file-system-mount-point fs)
1407 (file-system-type fs)
1408 (file-system-device->string device)
1409 (file-system-options fs))))
1410
1411 (if (eq? type 'iso9660)
1412 (let ((pad (compose (cut string-pad <> 2 #\0)
1413 number->string))
1414 (h (hash (map service-name (operating-system-services os))
1415 3600)))
1416 (bytevector->uuid
1417 (string->iso9660-uuid
1418 (string-append "1970-01-01-"
1419 (pad (hash (operating-system-host-name os) 24)) "-"
1420 (pad (quotient h 60)) "-"
1421 (pad (modulo h 60)) "-"
1422 (pad (hash (map file-system-digest
1423 (operating-system-file-systems os))
1424 100))))
1425 'iso9660))
1426 (bytevector->uuid
1427 (uint-list->bytevector
1428 (list (hash (map file-system-digest
1429 (operating-system-file-systems os))
1430 (- (expt 2 32) 1))
1431 (hash (operating-system-host-name os)
1432 (- (expt 2 32) 1))
1433 (hash (map service-name (operating-system-services os))
1434 (- (expt 2 32) 1))
1435 (hash (map file-system-digest (operating-system-file-systems os))
1436 (- (expt 2 32) 1)))
1437 (endianness little)
1438 4)
1439 type)))
1440
1441(define (locale-name->definition* name)
1442 "Variant of 'locale-name->definition' that raises an error upon failure."
1443 (match (locale-name->definition name)
1444 (#f
1445 (raise (formatted-message (G_ "~a: invalid locale name") name)))
1446 (def def)))
1447
1448(define (operating-system-locale-directory os)
1449 "Return the directory containing the locales compiled for the definitions
1450listed in OS. The C library expects to find it under
1451/run/current-system/locale."
1452 (define name
1453 (operating-system-locale os))
1454
1455 (define definitions
1456 ;; While we're at it, check whether NAME is defined and add it if needed.
1457 (if (member name (map locale-definition-name
1458 (operating-system-locale-definitions os)))
1459 (operating-system-locale-definitions os)
1460 (cons (locale-name->definition* name)
1461 (operating-system-locale-definitions os))))
1462
1463 (locale-directory definitions
1464 #:libcs (operating-system-locale-libcs os)))
1465
1466(define* (kernel->boot-label kernel #:key hurd)
1467 "Return a label for the bootloader menu entry that boots KERNEL."
1468 (cond ((package? hurd)
1469 (string-append "GNU with the "
1470 (string-titlecase (package-name hurd)) " "
1471 (package-version hurd)))
1472 ((package? kernel)
1473 (string-append "GNU with "
1474 (string-titlecase (package-name kernel)) " "
1475 (package-version kernel)))
1476 ((inferior-package? kernel)
1477 (string-append "GNU with "
1478 (string-titlecase (inferior-package-name kernel)) " "
1479 (inferior-package-version kernel)))
1480 (else "GNU")))
1481
1482(define (operating-system-default-label os)
1483 "Return the default label for OS, as it will appear in the bootloader menu
1484entry."
1485 (kernel->boot-label (operating-system-kernel os)
1486 #:hurd (operating-system-hurd os)))
1487
1488(define (store-file-system file-systems)
1489 "Return the file system object among FILE-SYSTEMS that contains the store."
1490 (match (filter (lambda (fs)
1491 (and (file-system-mount? fs)
1492 (not (memq 'bind-mount (file-system-flags fs)))
1493 (string-prefix? (file-system-mount-point fs)
1494 (%store-prefix))))
1495 file-systems)
1496 ((and candidates (head . tail))
1497 (reduce (lambda (fs1 fs2)
1498 (if (> (string-length (file-system-mount-point fs1))
1499 (string-length (file-system-mount-point fs2)))
1500 fs1
1501 fs2))
1502 head
1503 candidates))))
1504
1505(define (operating-system-store-file-system os)
1506 "Return the file system that contains the store of OS."
1507 (store-file-system (operating-system-file-systems os)))
1508
1509(define* (operating-system-bootcfg os #:optional (old-entries '()))
1510 "Return the bootloader configuration file for OS. Use OLD-ENTRIES,
1511a list of <menu-entry>, to populate the \"old entries\" menu."
1512 (let* ((file-systems (operating-system-file-systems os))
1513 (root-fs (operating-system-root-file-system os))
1514 (root-device (file-system-device root-fs))
1515 (locale (operating-system-locale os))
1516 (crypto-devices (operating-system-bootloader-crypto-devices os))
1517 (params (operating-system-boot-parameters
1518 os root-device
1519 #:system-kernel-arguments? #t))
1520 (entry (boot-parameters->menu-entry params))
1521 (bootloader-conf (operating-system-bootloader os)))
1522
1523 (define generate-config-file
1524 (bootloader-configuration-file-generator
1525 (bootloader-configuration-bootloader bootloader-conf)))
1526
1527 (generate-config-file bootloader-conf (list entry)
1528 #:old-entries old-entries
1529 #:locale locale
1530 #:store-crypto-devices crypto-devices
1531 #:store-directory-prefix
1532 (btrfs-store-subvolume-file-name file-systems))))
1533
1534(define (operating-system-multiboot-modules os)
1535 (if (operating-system-hurd os) (hurd-multiboot-modules os) '()))
1536
1537(define (hurd-multiboot-modules os)
1538 (let* ((hurd (operating-system-hurd os))
1539 (pci-arbiter-command
1540 (list (file-append hurd "/hurd/pci-arbiter.static")
1541 "pci-arbiter"
1542 "--host-priv-port='${host-port}'"
1543 "--device-master-port='${device-port}'"
1544 "--next-task='${acpi-task}'"
1545 "'$(pci-task=task-create)'"
1546 "'$(task-resume)'"))
1547 (acpi-command
1548 (list (file-append hurd "/hurd/acpi.static")
1549 "acpi"
1550 "--next-task='${disk-task}'"
1551 "'$(acpi-task=task-create)'"))
1552 (rumpdisk-command
1553 (list (file-append hurd "/hurd/rumpdisk.static")
1554 "rumpdisk"
1555 "--next-task='${fs-task}'"
1556 "'$(disk-task=task-create)'"))
1557 (root-file-system-command
1558 (list (file-append hurd "/hurd/ext2fs.static")
1559 "ext2fs"
1560 "--readonly"
1561 "--multiboot-command-line='${kernel-command-line}'"
1562 "--exec-server-task='${exec-task}'"
1563 "--store-type=typed"
1564 "'${root}'"
1565 "'$(fs-task=task-create)'"))
1566 (target (%current-target-system))
1567 (libc (if target
1568 (with-parameters ((%current-target-system #f))
1569 ;; TODO: cross-libc has extra patches for the Hurd;
1570 ;; remove in next rebuild cycle
1571 (cross-libc target))
1572 glibc))
1573 (exec-server-command
1574 ;; XXX: Run the statically-linked 'exec' to work around
1575 ;; <https://issues.guix.gnu.org/58320>, which manifests on some
1576 ;; machines.
1577
1578 ;; (list (file-append libc "/lib/ld.so.1") "exec"
1579 ;; (file-append hurd "/hurd/exec") "'$(exec-task=task-create)'")
1580 (list (file-append hurd "/hurd/exec.static") "exec"
1581 "'$(exec-task=task-create)'")))
1582 (list pci-arbiter-command
1583 acpi-command
1584 rumpdisk-command
1585 root-file-system-command
1586 exec-server-command)))
1587
1588(define* (operating-system-boot-parameters os root-device
1589 #:key system-kernel-arguments?)
1590 "Return a monadic <boot-parameters> record that describes the boot
1591parameters of OS. When SYSTEM-KERNEL-ARGUMENTS? is true, add the kernel
1592arguments 'root', 'gnu.load' and 'gnu.system' to <boot-parameters>. The
1593SYSTEM-KERNEL-ARGUMENTS? should only be used in necessity, as the 'gnu.load'
1594and 'gnu.system' values are self-referential (they refer to the system), thus
1595susceptible to introduce a cyclic dependency."
1596 (let* ((initrd (and (not (operating-system-hurd os))
1597 (operating-system-initrd-file os)))
1598 (store (operating-system-store-file-system os))
1599 (file-systems (operating-system-file-systems os))
1600 (crypto-devices (operating-system-bootloader-crypto-devices os))
1601 (locale (operating-system-locale os))
1602 (bootloader (bootloader-configuration-bootloader
1603 (operating-system-bootloader os)))
1604 (bootloader-name (bootloader-name bootloader))
1605 (label (operating-system-label os))
1606 (multiboot-modules (operating-system-multiboot-modules os)))
1607 (boot-parameters
1608 (label label)
1609 (root-device root-device)
1610 (kernel (operating-system-kernel-file os))
1611 (kernel-arguments
1612 (if system-kernel-arguments?
1613 (operating-system-kernel-arguments os root-device)
1614 (operating-system-user-kernel-arguments os)))
1615 (initrd initrd)
1616 (multiboot-modules multiboot-modules)
1617 (bootloader-name bootloader-name)
1618 (bootloader-menu-entries
1619 (bootloader-configuration-menu-entries (operating-system-bootloader os)))
1620 (locale locale)
1621 (store-device (ensure-not-/dev (file-system-device store)))
1622 (store-directory-prefix (btrfs-store-subvolume-file-name file-systems))
1623 (store-crypto-devices crypto-devices)
1624 (store-mount-point (file-system-mount-point store)))))
1625
1626(define (device->sexp device)
1627 "Serialize DEVICE as an sexp (really, as an object with a read syntax.)"
1628 (match device
1629 ((? uuid? uuid)
1630 `(uuid ,(uuid-type uuid) ,(uuid-bytevector uuid)))
1631 ((? file-system-label? label)
1632 `(file-system-label ,(file-system-label->string label)))
1633 (_
1634 device)))
1635
1636(define* (operating-system-boot-parameters-file os)
1637 "Return a file that describes the boot parameters of OS. The primary use
1638of this file is the reconstruction of GRUB menu entries for old
1639configurations."
1640 (let* ((root (operating-system-root-file-system os))
1641 (device (file-system-device root))
1642 (params (operating-system-boot-parameters os device)))
1643 (scheme-file "parameters"
1644 #~(boot-parameters
1645 (version #$(boot-parameters-version params))
1646 (label #$(boot-parameters-label params))
1647 (root-device
1648 #$(device->sexp
1649 (boot-parameters-root-device params)))
1650 (kernel #$(boot-parameters-kernel params))
1651 (kernel-arguments
1652 #$(boot-parameters-kernel-arguments params))
1653 #$@(if (boot-parameters-initrd params)
1654 #~((initrd #$(boot-parameters-initrd params)))
1655 #~())
1656 #$@(if (pair? (boot-parameters-multiboot-modules params))
1657 #~((multiboot-modules
1658 #$(boot-parameters-multiboot-modules params)))
1659 #~())
1660 (bootloader-name #$(boot-parameters-bootloader-name params))
1661 (bootloader-menu-entries
1662 #$(map menu-entry->sexp
1663 (or (and=> (operating-system-bootloader os)
1664 bootloader-configuration-menu-entries)
1665 '())))
1666 (locale #$(boot-parameters-locale params))
1667 (store
1668 (device
1669 #$(device->sexp (boot-parameters-store-device params)))
1670 (mount-point #$(boot-parameters-store-mount-point
1671 params))
1672 (directory-prefix
1673 #$(boot-parameters-store-directory-prefix params))
1674 (crypto-devices
1675 #$(map device->sexp
1676 (boot-parameters-store-crypto-devices params)))))
1677 #:set-load-path? #f)))
1678
1679(define-gexp-compiler (operating-system-compiler (os <operating-system>)
1680 system target)
1681 ((store-lift
1682 (lambda (store)
1683 ;; XXX: This is not super elegant but we can't pass SYSTEM and TARGET to
1684 ;; 'operating-system-derivation'.
1685 (parameterize ((%current-system system)
1686 (%current-target-system target))
1687 (run-with-store store
1688 (mbegin %store-monad
1689 (set-guile-for-build (default-guile))
1690 (operating-system-derivation os))
1691 #:system system
1692 #:target target))))))
1693
1694;;; system.scm ends here