;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2013-2022, 2024 Ludovic Courtès ;;; Copyright © 2015 Mark H Weaver ;;; Copyright © 2015, 2016 Alex Kost ;;; Copyright © 2016 Chris Marusich ;;; Copyright © 2017 Mathieu Othacehe ;;; Copyright © 2019 Meiyo Peng ;;; Copyright © 2019, 2020 Miguel Ángel Arruga Vivas ;;; Copyright © 2020 Danny Milosavljevic ;;; Copyright © 2020, 2021 Brice Waegeneire ;;; Copyright © 2020 Florian Pelz ;;; Copyright © 2020, 2022 Maxim Cournoyer ;;; Copyright © 2020, 2023 Janneke Nieuwenhuizen ;;; Copyright © 2020, 2022 Efraim Flashner ;;; Copyright © 2021 Maxime Devos ;;; Copyright © 2021 raid5atemyhomework ;;; Copyright © 2023
aboutsummaryrefslogtreecommitdiff
blob: 8430a2b7924b05c304c634e5683da1cf553047d5 (about) (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
;; This file, which is best viewed as -*- Scheme -*-, lists the OpenPGP keys
;; currently authorized to sign commits in this repository.

(authorizations
 (version 0)

 (;; primary: "D963 A5A3 8A80 3D52 4461  F914 7483 0A27 6C32 8EC2"
  ("2841 9AC6 5038 7440 C7E9  2FFA 2208 D209 58C1 DEB0"
   (name "abcdw"))
  ("50F3 3E2E 5B0C 3D90 0424  ABE8 9BDC F497 A4BB CC7F"
   (name "ambrevar"))
  ("AD17 A21E F8AE D8F1 CC02  DBD9 F7D5 C9BF 765C 61E3"
   (name "andreas"))
  ("27D5 86A4 F890 0854 329F  F09F 1260 E464 82E6 3562"
   (name "apteryx"))
  ("7F73 0343 F2F0 9F3C 77BF  79D3 2E25 EE8B 6180 2BB3"
   (name "arunisaac"))
  (;; primary: "34FF 38BC D151 25A6 E340  A0B5 3453 2F9F AFCA 8B8E"
   "A3A4 B419 0074 087C A7DE  5698 BC45 CA67 E2F8 D007"
   (name "bavier"))
  (;; primary: "0401 7A2A 6D9A 0CCD C81D  8EC2 96AB 007F 1A7E D999"
   "09CD D25B 5244 A376 78F6  EEA8 0CC5 2153 1979 91A5"
   (name "carl"))
  ("3E89 EEE7 458E 720D 9754  E0B2 5E28 A33B 0B84 F577"
   (name "cbaines"))
  ("3CE4 6455 8A84 FDC6 9DB4  0CFB 090B 1199 3D9A EBB5"
   (name "civodul"))
  ("510A 8628 E2A7 7678 8F8C  709C 4BC0 2592 5FF8 F4D3"
   (name "cwebber"))
  (;; primary: "295A F991 6F46 F8A1 34B0  29DA 8086 3842 F0FE D83B"
   "76CE C6B1 7274 B465 C02D  B3D9 E71A 3554 2C30 BAA5"
   (name "dannym"))
  ("8CCB A7F5 52B9 CBEA E1FB  2915 8328 C747 0FF1 D807"
   (name "dthompson"))
  ("A28B F40C 3E55 1372 662D  14F7 41AA E7DC CA3D 8351"
   (name "efraim"))
  (;; primary: "2453 02B1 BAB1 F867 FDCA  96BC 8F3F 861F 82EB 7A9A"
   "CBC5 9C66 EC27 B971 7940  6B3E 6BE8 208A DF21 FE3F"
   (name "glv"))
  (;; primary: "220F 98D9 5E86 204C 0036  DA7B 6DEC 4360 408B 4185"
   "F4C2 D1DF 3FDE EA63 D1D3  0776 ACC6 6D09 CA52 8292"
   (name "hako"))
  ("B943 509D 633E 80DD 27FC  4EED 634A 8DFF D3F6 31DF"
   (name "htgoebel"))
  (;; primary: "66A5 6D9C 9A98 BE7F 719A  B401 2652 5665 AE72 7D37"
   "0325 78A6 8298 94E7 2AA2  66F5 D415 BF25 3B51 5976"
   (name "iyzsong"))
  ("1A85 8392 E331 EAFD B8C2  7FFB F3C1 A0D9 C1D6 5273"
   (name "janneke"))
  ("3B1D 7F19 E36B B60C 0F5B  2CA9 A52A A2B4 77B6 DD35"
   (name "jgart"))
  (;; primary: "1BA4 08C5 8BF2 0EA7 3179  635A 865D C0A3 DED9 B5D0"
   "E31D 9DDE EBA5 4A14 8A20  4550 DA45 97F9 47B4 1025"
   (name "jlicht"))
  ("8141 6036 E81A 5CF7 8F80  1071 ECFC 8398 8B4E 4B9F"
   (name "jonsger"))
  ("3924 8CD8 41C6 3CC3 36DC  AF2F 505E 40B9 1617 1A8A"
   (name "jpoiret"))
  ("017D 74E2 7F58 5696 3801  781D F663 943E 08D8 092A"
   (name "lbraun"))
  ("ACC2 3BA0 59F7 CCF4 08F0  43AD 442A 84B8 C70E 2F87"
   (name "lilyp"))
  ("6840 722E EEE4 D3A6 4EE5  3EAC 6AAC 1963 757F 47FF"
   (name "lfam"))
  ("BBB0 2DDF 2CEA F6A8 0D1D  E643 A2A0 6DF2 A33A 54FA"
   (name "mbakke"))
  ("D919 0965 CE03 199E AF28  B3BE 7CEF 2984 7562 C516"
   (name "mhw"))
  ("B845 5B7F FAD5 E8E9 5DEF  4296 637B 0B13 8065 B68A"
   (name "monego"))
  ("4008 6A7E 0252 9B60 31FB  8607 8354 7635 3176 9CA6"
   (name "mothacehe"))
  (;; primary: "F5BC 5534 C36F 0087 B39D  36EF 1C9D C4FE B9DB 7C4B"
   "F5DA 2032 4B87 3D0B 7A38  7672 0DB0 FF88 4F55 6D79"
   (name "nckx"))
  ("ED0E F1C8 E126 BA83 1B48  5FE9 DA00 B4F0 48E9 2F2D"
   (name "ngz"))
  ("CEF4 CB91 4856 BA38 0A20  A7E2 3008 88CB 39C6 3817"
   (name "pelzflorian"))
  (;; primary: "41CA 12EA DE0C F33F 6885  A58F 5719 6E37 E00B 77FD"
   "72D5 3D81 8CB6 F4A1 7258  374C A8FC 9E44 7F4F 7D54"
   (name "planglois"))
  (;; primary: "7E9F 5BF6 1680 4367 127B  7A87 F9E6 9FB8 5A75 54F1"
   "A420 7B56 C255 109F 2CB3  157E 4990 97AE 5EA8 15D9"
   (name "podiki"))
  ("BCA6 89B6 3655 3801 C3C6  2150 197A 5888 235F ACAC"
   (name "rekado"))
  (;; From commit cc51c03ff867d4633505354819c6d88af88bf919 (March 2020).
   ;; See <https://lists.gnu.org/archive/html/guix-devel/2020-03/msg00070.html>.
   "F556 FD94 FB8F 8B87 79E3  6832 CBD0 CD51 38C1 9AFC"
   (name "roelj"))
  (;; From commit 2cbede5935eb6a40173bbdf30a9ad22bf7574c22 (Jan. 2020).  See
   ;; <https://lists.gnu.org/archive/html/guix-devel/2020-01/msg00499.html>.
   "1EFB 0909 1F17 D28C CBF9  B13A 53D4 57B2 D636 EE82"
   (name "roptat"))
  (;; primary: "D6B0 C593 DA8C 5EDC A44C  7A58 C336 91F7 1188 B004"
   "A02C 2D82 0EF4 B25B A6B5  1D90 2AC6 A5EC 1C35 7C59"
   (name "samplet"))
  ("9847 81DE 689C 21C2 6418  0867 76D7 27BF F62C D2B5"
   (name "sharlatan"))
  ("F494 72F4 7A59 00D5 C235  F212 89F9 6D48 08F3 59C7"
   (name "snape"))
  ("6580 7361 3BFC C5C7 E2E4  5D45 DC51 8FC8 7F97 16AA"
   (name "vagrantc"))
  (;; primary: "C955 CC5D C048 7FB1 7966  40A9 199A F6A3 67E9 4ABB"
   "7238 7123 8EAC EB63 4548  5857 167F 8EA5 001A FA9C"
   (name "wigust"))
  ("7EBE A494 60CE 5E2C 0875  7FDB 3B5A A993 E1A2 DFF0"
   (name "z572"))
  ("705A 29B7 01EE 410E B6F9  236E 92F1 D22C 608E E7E5"
   (name "zimoun"))))
user groups (default %base-groups)) (skeletons operating-system-skeletons ; list of name/file-like value (default (default-skeletons))) (issue operating-system-issue ; string (default %default-issue)) (packages %operating-system-packages ; list of (PACKAGE OUTPUT...) (default %base-packages)) ; or just PACKAGE (timezone operating-system-timezone (default "Etc/UTC")) ; string (locale operating-system-locale ; string (default "en_US.utf8")) (locale-definitions operating-system-locale-definitions ; list of (default %default-locale-definitions)) (locale-libcs operating-system-locale-libcs ; list of (default %default-locale-libcs)) (name-service-switch operating-system-name-service-switch ; (default %default-nss)) (essential-services operating-system-essential-services ; list of services (thunked) (default (operating-system-default-essential-services this-operating-system))) (services operating-system-user-services ; list of services (thunked) ;allow for system-dependent services (default %base-services) (sanitize validate-service-list)) (pam-services operating-system-pam-services ; list of PAM services (default (base-pam-services))) (setuid-programs operating-system-setuid-programs (default %setuid-programs) ; list of (sanitize ensure-setuid-program-list)) (sudoers-file operating-system-sudoers-file ; file-like (default %sudoers-specification)) (location operating-system-location ; (default (and=> (current-source-location) source-properties->location)) (innate))) (define-deprecated (operating-system-hosts-file os) hosts-service-type (%operating-system-hosts-file os)) ;;; XXX: Remove after a new release of Guix no longer suggests to install ;;; nss-certs. (define (operating-system-packages os) "Return the packages of the OS record object." ;; This wrapper is used to warn users that their operating system packages ;; field contains a duplicated nss-certs packages. (let* ((packages (%operating-system-packages os)) (nss-certs-packages (sort (filter (lambda (p) (and (package? p) (string=? "nss-certs" (package-name p)))) packages) (lambda (x y) ;; Sort from newer to older versions. (version>? (package-version x) (package-version y)))))) (if (> (length nss-certs-packages) 1) (begin (warning #f (G_ "multiple 'nss-certs' packages found; 'nss-certs' \ is now included by default in '%base-packages'; ensure it is not explicitly \ listed in the operating system 'packages' field~%")) (fold delete packages (drop nss-certs-packages 1))) packages))) (define* (operating-system-kernel-arguments os root-device #:key (version %boot-parameters-version)) "Return all the kernel arguments, including the ones not specified directly by the user. VERSION should match that of the target record object that will contain the kernel parameters." (append (bootable-kernel-arguments os root-device version) (operating-system-user-kernel-arguments os))) ;;; ;;; Boot parameters ;;; ;;; Version 1 was introduced early 2022 to mark the departure from long option ;;; names such as '--load' to the more conventional initrd option names like ;;; 'gnu.load'. ;;; ;;; When bumping the boot-parameters version, increment it by one (1). (define %boot-parameters-version 1) (define-record-type* boot-parameters make-boot-parameters boot-parameters? (label boot-parameters-label) ;; Because we will use the 'store-device' to create the GRUB search command, ;; the 'store-device' has slightly different semantics than 'root-device'. ;; The 'store-device' can be a file system uuid, a file system label, or #f, ;; but it cannot be a device file name such as "/dev/sda3", since GRUB would ;; not understand that. The 'root-device', on the other hand, corresponds ;; exactly to the device field of the object representing the ;; OS's root file system, so it might be a device file name like ;; "/dev/sda3". The 'store-directory-prefix' field contains #f or the store ;; file name inside the 'store-device' as it is seen by GRUB, e.g. it would ;; contain "/storefs" if the store is located in that subvolume of a btrfs ;; partition. (root-device boot-parameters-root-device) (bootloader-name boot-parameters-bootloader-name) (bootloader-menu-entries ;list of boot-parameters-bootloader-menu-entries) (store-device boot-parameters-store-device) (store-mount-point boot-parameters-store-mount-point) (store-directory-prefix boot-parameters-store-directory-prefix) (store-crypto-devices boot-parameters-store-crypto-devices (default '())) (locale boot-parameters-locale) (kernel boot-parameters-kernel) (kernel-arguments boot-parameters-kernel-arguments) (initrd boot-parameters-initrd) (multiboot-modules boot-parameters-multiboot-modules) (version boot-parameters-version ;positive integer (default %boot-parameters-version))) (define (ensure-not-/dev device) "If DEVICE starts with a slash, return #f. This is meant to filter out Linux device names such as /dev/sda, and to preserve GRUB device names and file system labels." (if (and (string? device) (string-prefix? "/" device)) #f device)) (define (read-boot-parameters port) "Read boot parameters from PORT and return the corresponding object. Raise an error if the format is unrecognized." (define device-sexp->device (match-lambda (('uuid (? symbol? type) (? bytevector? bv)) (bytevector->uuid bv type)) (('file-system-label (? string? label)) (file-system-label label)) ((? bytevector? bv) ;old format (bytevector->uuid bv 'dce)) ((? string? device) (if (string-contains device ":/") device ; nfs-root ;; It used to be that we would not distinguish between labels and ;; device names. Try to infer the right thing here. (if (string-prefix? "/" device) device (file-system-label device)))))) (define uuid-sexp->uuid (match-lambda (('uuid (? symbol? type) (? bytevector? bv)) (bytevector->uuid bv type)) (x (warning (G_ "unrecognized uuid ~a at '~a'~%") x (port-filename port)) #f))) ;; New versions are not backward-compatible, so only accept past and current ;; versions, not future ones. (define (version? n) (member n (iota (1+ %boot-parameters-version)))) (match (read port) (('boot-parameters ('version (? version? version)) ('label label) ('root-device root) ('kernel kernel) rest ...) (boot-parameters (version version) (label label) (root-device (device-sexp->device root)) (bootloader-name (match (assq 'bootloader-name rest) ((_ args) args) (#f 'grub))) ; for compatibility reasons. (bootloader-menu-entries (match (assq 'bootloader-menu-entries rest) ((_ entries) (map sexp->menu-entry entries)) (#f '()))) ;; In the past, we would store the directory name of linux instead of ;; the absolute file name of its image. Detect that and correct it. (kernel (if (string=? kernel (direct-store-path kernel)) (string-append kernel "/" (system-linux-image-file-name)) kernel)) (kernel-arguments (match (assq 'kernel-arguments rest) ((_ args) args) (#f '()))) ;the old format (initrd (match (assq 'initrd rest) (('initrd ('string-append directory file)) ;the old format (string-append directory file)) (('initrd (? string? file)) file) (#f #f))) (multiboot-modules (match (assq 'multiboot-modules rest) ((_ args) args) (#f '()))) (locale (match (assq 'locale rest) ((_ locale) locale) (#f #f))) (store-device ;; Linux device names like "/dev/sda1" are not suitable GRUB device ;; identifiers, so we just filter them out. (ensure-not-/dev (match (assq 'store rest) (('store ('device #f) _ ...) root-device) (('store ('device device) _ ...) (device-sexp->device device)) (_ ;the old format root-device)))) (store-directory-prefix (match (assq 'store rest) (('store . store-data) (match (assq 'directory-prefix store-data) (('directory-prefix prefix) prefix) ;; No directory-prefix found. (_ #f))) (_ ;; No store found, old format. #f))) (store-crypto-devices (match (assq 'store rest) (('store . store-data) (match (assq 'crypto-devices store-data) (('crypto-devices (devices ...)) (map uuid-sexp->uuid devices)) (('crypto-devices dev) (warning (G_ "unrecognized crypto-devices ~S at '~a'~%") dev (port-filename port)) '()) (_ ;; No crypto-devices found. '()))) (_ ;; No store found, old format. '()))) (store-mount-point (match (assq 'store rest) (('store ('device _) ('mount-point mount-point) _ ...) mount-point) (_ ;the old format "/"))))) (x ;unsupported format (raise (make-compound-condition (formatted-message (G_ "unrecognized boot parameters at '~a'~%") (port-filename port)) (condition (&fix-hint (hint (format #f (G_ "This probably means that this version of Guix is older than the one that created @file{~a}. To address this, you need to update Guix: @example guix pull @end example") (port-filename port)))))))))) (define (read-boot-parameters-file system) "Read boot parameters from SYSTEM's (system or generation) \"parameters\" file and returns the corresponding object or #f if the format is unrecognized. The object has its kernel-arguments extended in order to make it bootable." (let* ((file (string-append system "/parameters")) (params (call-with-input-file file read-boot-parameters)) (root (boot-parameters-root-device params)) (version (boot-parameters-version params))) (boot-parameters (inherit params) (kernel-arguments (append (bootable-kernel-arguments system root version) (boot-parameters-kernel-arguments params)))))) (define (boot-parameters->menu-entry conf) "Return a instance given CONF, a instance." (let* ((kernel (boot-parameters-kernel conf)) (multiboot-modules (boot-parameters-multiboot-modules conf)) (multiboot? (pair? multiboot-modules))) (menu-entry (label (boot-parameters-label conf)) (device (boot-parameters-store-device conf)) (device-mount-point (boot-parameters-store-mount-point conf)) (linux (and (not multiboot?) kernel)) (linux-arguments (if (not multiboot?) (boot-parameters-kernel-arguments conf) '())) (initrd (boot-parameters-initrd conf)) (multiboot-kernel (and multiboot? kernel)) (multiboot-arguments (if multiboot? (boot-parameters-kernel-arguments conf) '())) (multiboot-modules (if multiboot? (boot-parameters-multiboot-modules conf) '()))))) ;;; ;;; Services. ;;; (define (non-boot-file-system-service os) "Return the file system service for the file systems of OS that are not marked as 'needed-for-boot'." (define file-systems (remove file-system-needed-for-boot? (operating-system-file-systems os))) (define mapped-devices-for-boot (operating-system-boot-mapped-devices os)) (define (device-mappings fs) (let ((device (file-system-device fs))) (if (string? device) ;title is 'device (filter (lambda (md) (any (cut string=? device <>) (map (cut string-append "/dev/mapper" <>) (mapped-device-targets md)))) (operating-system-mapped-devices os)) '()))) (define (add-dependencies fs) ;; Add the dependencies due to device mappings to FS. (file-system (inherit fs) (dependencies (delete-duplicates (remove (cut member <> mapped-devices-for-boot) (append (device-mappings fs) (file-system-dependencies fs))) eq?)))) (service file-system-service-type (map add-dependencies file-systems))) (define (boot-file-system-service os) "Return a service which adds, to the system profile, packages providing the utilities for the file systems marked as 'needed-for-boot' in OS." (let ((file-systems (filter file-system-needed-for-boot? (operating-system-file-systems os)))) (simple-service 'boot-file-system-utilities profile-service-type (file-system-utilities file-systems)))) (define (mapped-device-users device file-systems) "Return the subset of FILE-SYSTEMS that use DEVICE." (let ((targets (map (cut string-append "/dev/mapper/" <>) (mapped-device-targets device)))) (filter (lambda (fs) (or (member device (file-system-dependencies fs)) (and (string? (file-system-device fs)) (any (cut string=? (file-system-device fs) <>) targets)))) file-systems))) (define (operating-system-user-mapped-devices os) "Return the subset of mapped devices that can be installed in user-land--i.e., those not needed during boot." (let ((devices (operating-system-mapped-devices os)) (file-systems (operating-system-file-systems os))) (filter (lambda (md) (let ((users (mapped-device-users md file-systems))) (not (any file-system-needed-for-boot? users)))) devices))) (define (operating-system-boot-mapped-devices os) "Return the subset of mapped devices that must be installed during boot, from the initrd." (let ((devices (operating-system-mapped-devices os)) (file-systems (operating-system-file-systems os))) (filter (lambda (md) (let ((users (mapped-device-users md file-systems))) (any file-system-needed-for-boot? users))) devices))) (define operating-system-bootloader-crypto-devices (mlambdaq (os) ;to avoid duplicated output "Return the sources of the LUKS mapped devices specified by UUID." ;; XXX: Device ordering is important, we trust the returned one. (let* ((luks-devices (filter (lambda (m) (eq? luks-device-mapping (mapped-device-type m))) (operating-system-boot-mapped-devices os))) (uuid-crypto-devices non-uuid-crypto-devices (partition (compose uuid? mapped-device-source) luks-devices))) (when (not (null? non-uuid-crypto-devices)) (for-each (lambda (dev) (warning (source-properties->location (mapped-device-location dev)) (G_ "mapped device '~a' may be ignored by bootloader~%") (mapped-device-source dev))) non-uuid-crypto-devices) (display-hint "Specify mapped device sources via their LUKS UUID.")) (map mapped-device-source uuid-crypto-devices)))) (define (device-mapping-services os) "Return the list of device-mapping services for OS as a list." (map device-mapping-service (operating-system-user-mapped-devices os))) (define-syntax-rule (warn-swap-devices-change value) (%warn-swap-devices-change value (current-source-location))) (define (%warn-swap-devices-change value location) (map (lambda (x) (unless (swap-space? x) (warning (source-properties->location location) (G_ "List elements of the field 'swap-devices' should \ now use the record, as the old method is deprecated. \ See \"(guix) operating-system Reference\" for more details.~%"))) x) value)) (define (swap-services os) "Return the list of swap services for OS." (define early-userspace-file-systems (filter file-system-needed-for-boot? (operating-system-file-systems os))) (define early-userspace-mapped-devices (operating-system-boot-mapped-devices os)) (define (filter-deps swap) (if (swap-space? swap) (swap-space (inherit swap) (dependencies (remove (lambda (dep) (or (member dep early-userspace-mapped-devices) (member dep early-userspace-file-systems))) (swap-space-dependencies swap)))) swap)) (map (compose swap-service filter-deps) (operating-system-swap-devices os))) (define* (system-linux-image-file-name #:optional (target (or (%current-target-system) (%current-system)))) "Return the basename of the kernel image file for TARGET." (cond ((string-prefix? "arm" target) "zImage") ((string-prefix? "mips" target) "vmlinuz") ((string-prefix? "aarch64" target) "Image") ((string-prefix? "riscv64" target) "Image") (else "bzImage"))) (define (operating-system-kernel-file os) "Return an object representing the absolute file name of the kernel image of OS." (if (operating-system-hurd os) (file-append (operating-system-kernel os) "/boot/gnumach") (file-append (operating-system-kernel os) "/" (system-linux-image-file-name)))) (define %default-modprobe-blacklist ;; List of kernel modules to blacklist by default. '("usbmouse" ;races with bcm5974, see "usbkbd")) ;races with usbhid, see (define %default-kernel-arguments ;; Default arguments passed to the kernel. (list (string-append "modprobe.blacklist=" (string-join %default-modprobe-blacklist ",")) "quiet")) (define* (operating-system-directory-base-entries os) "Return the basic entries of the 'system' directory of OS for use as the value of the SYSTEM-SERVICE-TYPE service." (let* ((locale (operating-system-locale-directory os)) (kernel (operating-system-kernel os)) (hurd (operating-system-hurd os)) (initrd (and (not hurd) (operating-system-initrd-file os))) (params (operating-system-boot-parameters-file os))) `(,@(if hurd `(("hurd" ,hurd) ("kernel" ,kernel)) '()) ("parameters" ,params) ,@(if initrd `(("initrd" ,initrd)) '()) ("locale" ,locale)))) ;used by libc (define (operating-system-default-essential-services os) "Return the list of essential services for OS. These are special services that implement part of what's declared in OS are responsible for low-level bookkeeping." (define known-fs (map file-system-mount-point (operating-system-file-systems os))) (let* ((mappings (device-mapping-services os)) (root-fs (root-file-system-service)) (boot-fs (boot-file-system-service os)) (non-boot-fs (non-boot-file-system-service os)) (swaps (swap-services os)) (procs (service user-processes-service-type)) (host-name (operating-system-host-name os)) (hosts-file (%operating-system-hosts-file os)) (entries (operating-system-directory-base-entries os))) (cons* (service system-service-type entries) (service linux-builder-service-type (linux-builder-configuration (kernel (operating-system-kernel os)) (modules (operating-system-kernel-loadable-modules os)))) %boot-service ;; %SHEPHERD-ROOT-SERVICE must come last so that the gexp that ;; execs shepherd comes last in the boot script (XXX). Likewise, ;; the cleanup service must come first so that its gexp runs before ;; activation code. (service cleanup-service-type #f) %activation-service %shepherd-root-service (pam-root-service (operating-system-pam-services os)) (account-service (append (operating-system-accounts os) (operating-system-groups os)) (operating-system-skeletons os)) (operating-system-etc-service os) ;; XXX: hosts-file is deprecated (if hosts-file (simple-service 'deprecated-hosts-file etc-service-type (list `("hosts" ,hosts-file))) (service hosts-service-type (local-host-entries host-name))) (service fstab-service-type (filter file-system-needed-for-boot? (operating-system-file-systems os))) (session-environment-service (operating-system-environment-variables os)) (service host-name-service-type host-name) procs root-fs (service setuid-program-service-type (operating-system-setuid-programs os)) (service profile-service-type (operating-system-packages os)) boot-fs non-boot-fs (append mappings swaps ;; Add the firmware service. (list %linux-bare-metal-service (service firmware-service-type (operating-system-firmware os))))))) (define (hurd-default-essential-services os) (let ((host-name (operating-system-host-name os)) (hosts-file (%operating-system-hosts-file os)) (entries (operating-system-directory-base-entries os))) (list (service system-service-type entries) %boot-service %hurd-startup-service %activation-service (service shepherd-root-service-type) (service user-processes-service-type) (account-service (append (operating-system-accounts os) (operating-system-groups os)) (operating-system-skeletons os)) (root-file-system-service) (service file-system-service-type '()) (service fstab-service-type (filter file-system-needed-for-boot? (operating-system-file-systems os))) (pam-root-service (operating-system-pam-services os)) (operating-system-etc-service os) ;; XXX: hosts-file is deprecated (if hosts-file (simple-service 'deprecated-hosts-file etc-service-type (list `("hosts" ,hosts-file))) (service hosts-service-type (local-host-entries host-name))) (service setuid-program-service-type (operating-system-setuid-programs os)) (service profile-service-type (operating-system-packages os))))) (define* (operating-system-services os) "Return all the services of OS, including \"essential\" services." (instantiate-missing-services (append (operating-system-user-services os) (operating-system-essential-services os)))) (define (operating-system-with-gc-roots os roots) "Return a variant of OS where ROOTS are registered as GC roots." (operating-system (inherit os) ;; We use this procedure for the installation OS, which already defines GC ;; roots. Add ROOTS to those. (services (cons (simple-service 'extra-root gc-root-service-type roots) (operating-system-user-services os))))) (define (operating-system-configuration-file os) "Return the configuration file of OS, based on its 'location' field, or #f if it could not be determined." (let ((file (and=> (operating-system-location os) location-file))) (and file (or (and (string-prefix? "/" file) file) (search-path %load-path file))))) (define* (operating-system-with-provenance os #:optional (config-file (operating-system-configuration-file os))) "Return a variant of OS that stores its own provenance information, including CONFIG-FILE, if available. This is achieved by adding an instance of PROVENANCE-SERVICE-TYPE to its services." (operating-system (inherit os) (services (cons (service provenance-service-type config-file) (operating-system-user-services os))))) ;;; ;;; /etc. ;;; (define %base-firmware ;; Firmware usable by default. (list ath9k-htc-ar7010-firmware ath9k-htc-ar9271-firmware openfwwf-firmware)) (define %base-packages-artwork ;; Default set of artwork packages. (list guix-icons)) (define %base-packages-utils ;; Default set of utilities packages. (cons* procps psmisc which shadow ;for 'passwd' e2fsprogs ;for lsattr, chattr, etc. guile-3.0-latest ;; The packages below are also in %FINAL-INPUTS, so take them from ;; there to avoid duplication. (list bash coreutils findutils grep sed diffutils patch gawk tar gzip bzip2 xz lzip))) (define %base-packages-linux ;; Default set of linux specific packages. (list pciutils usbutils util-linux+udev ;; Get 'insmod' & co. from kmod, not module-init-tools, since udev ;; already depends on it anyway. kmod eudev)) (define %base-packages-interactive ;; Default set of common interactive packages. (list less mg nano nvi man-db info-reader ;the standalone Info reader (no Perl) bash-completion kbd ;; The 'sudo' command is already in %SETUID-PROGRAMS, but we also ;; want the other commands and the man pages (notably because ;; auto-completion in Emacs shell relies on man pages.) sudo guile-readline guile-colorized)) (define %base-packages-networking ;; Default set of networking packages. (list inetutils isc-dhcp iproute wget nss-certs ;; wireless-tools is deprecated in favor of iw, but it's still what ;; many people are familiar with, so keep it around. iw wireless-tools)) (define-deprecated %base-packages-disk-utilities #f '()) (define %base-packages ;; Default set of packages globally visible. It should include anything ;; required for basic administrator tasks. (append %base-packages-artwork %base-packages-interactive %base-packages-linux %base-packages-networking %base-packages-utils)) (define %default-issue ;; Default contents for /etc/issue. " This is the GNU system. Welcome.\n") (define-deprecated (local-host-aliases host-name) local-host-entries "Return aliases for HOST-NAME, to be used in /etc/hosts." (string-append "127.0.0.1 localhost " host-name "\n" "::1 localhost " host-name "\n")) (define (local-host-entries host-name) "Return records for @var{host-name}." (map (lambda (address) (host address "localhost" (list host-name))) '("127.0.0.1" "::1"))) (define (validated-sudoers-file file) "Return a copy of FILE, a sudoers file, after checking that it is syntactically correct." (computed-file "sudoers" (with-imported-modules '((guix build utils)) #~(begin (use-modules (guix build utils)) (invoke #+(file-append sudo "/sbin/visudo") "--check" "--file" #$file) (copy-file #$file #$output))))) (define os-release (plain-file "os-release" "\ NAME=\"Guix System\" ID=guix PRETTY_NAME=\"Guix System\" LOGO=guix-icon HOME_URL=\"https://guix.gnu.org\" DOCUMENTATION_URL=\"https://guix.gnu.org/en/manual\" SUPPORT_URL=\"https://guix.gnu.org/en/help\" BUG_REPORT_URL=\"https://lists.gnu.org/mailman/listinfo/bug-guix\" ")) (define* (operating-system-etc-service os) "Return a that builds a directory containing the static part of the /etc directory." (let* ((login.defs (plain-file "login.defs" (string-append "# Default paths for non-login shells started by su(1).\n" "ENV_PATH /run/setuid-programs:" "/run/current-system/profile/bin:" "/run/current-system/profile/sbin\n" "ENV_SUPATH /run/setuid-programs:" "/run/current-system/profile/bin:" "/run/current-system/profile/sbin\n" "\n" "# Allow 'chfn' to change the full name,\n" "# room number, and so on.\n" "CHFN_RESTRICT frwh\n"))) (hurd (operating-system-hurd os)) (issue (plain-file "issue" (operating-system-issue os))) (nsswitch (and=> (operating-system-name-service-switch os) (compose (cut plain-file "nsswitch.conf" <>) name-service-switch->string))) (sudoers (operating-system-sudoers-file os)) ;; Startup file for POSIX-compliant login shells, which set system-wide ;; environment variables. (profile (mixed-text-file "profile" "\ # Crucial variables that could be missing in the profiles' 'etc/profile' # because they would require combining both profiles. # FIXME: See . export MANPATH=$HOME/.guix-profile/share/man:/run/current-system/profile/share/man export INFOPATH=$HOME/.guix-profile/share/info:/run/current-system/profile/share/info export XDG_DATA_DIRS=$HOME/.guix-profile/share:/run/current-system/profile/share export XDG_CONFIG_DIRS=$HOME/.guix-profile/etc/xdg:/run/current-system/profile/etc/xdg # Make sure libXcursor finds cursors installed into user or system profiles. See export XCURSOR_PATH=$HOME/.icons:$HOME/.guix-profile/share/icons:/run/current-system/profile/share/icons # Ignore the default value of 'PATH'. unset PATH # Load the system profile's settings. GUIX_PROFILE=/run/current-system/profile ; \\ . /run/current-system/profile/etc/profile # Since 'lshd' does not use pam_env, /etc/environment must be explicitly # loaded when someone logs in via SSH. See . # We need 'PATH' to be defined here, for 'cat' and 'cut'. Do this before # reading the user's 'etc/profile' to allow variables to be overridden. if [ -f /etc/environment -a -n \"$SSH_CLIENT\" \\ -a -z \"$LINUX_MODULE_DIRECTORY\" ] then . /etc/environment export `cat /etc/environment | cut -d= -f1` fi # Arrange so that ~/.config/guix/current comes first. for profile in \"$HOME/.guix-profile\" \"$HOME/.config/guix/current\" do if [ -f \"$profile/etc/profile\" ] then # Load the user profile's settings. GUIX_PROFILE=\"$profile\" ; \\ . \"$profile/etc/profile\" else # At least define this one so that basic things just work # when the user installs their first package. export PATH=\"$profile/bin:$PATH\" fi done # Prepend setuid programs. export PATH=/run/setuid-programs:$PATH # Arrange so that ~/.config/guix/current/share/info comes first. export INFOPATH=\"$HOME/.config/guix/current/share/info:$INFOPATH\" # Set the umask, notably for users logging in via 'lsh'. # See . umask 022 # Allow Hunspell-based applications (IceCat, LibreOffice, etc.) to # find dictionaries. export DICPATH=\"$HOME/.guix-profile/share/hunspell:/run/current-system/profile/share/hunspell\" # Allow GStreamer-based applications to find plugins. export GST_PLUGIN_PATH=\"$HOME/.guix-profile/lib/gstreamer-1.0\" if [ -n \"$BASH_VERSION\" -a -f /etc/bashrc ] then # Load Bash-specific initialization code. . /etc/bashrc fi ")) (bashrc (plain-file "bashrc" "\ # Bash-specific initialization. # Provide a default prompt. The user's ~/.bashrc can override it. PS1='\\u@\\h \\w${GUIX_ENVIRONMENT:+ [env]}\\$ ' # The 'bash-completion' package. if [ -f /run/current-system/profile/etc/profile.d/bash_completion.sh ] then # Bash-completion sources ~/.bash_completion. It installs a dynamic # completion loader that searches its own completion files as well # as those in ~/.guix-profile and /run/current-system/profile. source /run/current-system/profile/etc/profile.d/bash_completion.sh fi\n"))) (service etc-service-type `(("os-release" ,os-release) ("services" ,(file-append net-base "/etc/services")) ("protocols" ,(file-append net-base "/etc/protocols")) ("rpc" ,(file-append net-base "/etc/rpc")) ("login.defs" ,login.defs) ("issue" ,issue) ,@(if nsswitch `(("nsswitch.conf" ,nsswitch)) '()) ("profile" ,profile) ("bashrc" ,bashrc) ;; Write the operating-system-host-name to /etc/hostname to prevent ;; NetworkManager from changing the system's hostname when connecting ;; to certain networks. Some discussion at ;; https://lists.gnu.org/archive/html/help-guix/2017-09/msg00037.html ("hostname" ,(plain-file "hostname" (operating-system-host-name os))) ;; Some programs (e.g., GLib) look at /etc/timezone to find the ;; name of the current timezone. For details, see ;; https://lists.gnu.org/archive/html/guix-devel/2019-07/msg00166.html ;; Some programs expect a terminating newline. ("timezone" ,(plain-file "timezone" (string-append (string-trim-both (operating-system-timezone os)) "\n"))) ("localtime" ,(file-append tzdata "/share/zoneinfo/" (operating-system-timezone os))) ,@(if sudoers `(("sudoers" ,(validated-sudoers-file sudoers))) '()) ,@(if hurd `(("login" ,(file-append hurd "/etc/login")) ("motd" ,(file-append hurd "/etc/motd")) ("ttys" ,(file-append hurd "/etc/ttys"))) '()))))) (define %root-account ;; Default root account. (user-account (name "root") (password "") (uid 0) (group "root") (comment "System administrator") (home-directory "/root"))) (define (operating-system-accounts os) "Return the user accounts for OS, including an obligatory 'root' account, and excluding accounts requested by services." ;; Make sure there's a root account. (if (find (lambda (user) (and=> (user-account-uid user) zero?)) (operating-system-users os)) (operating-system-users os) (cons %root-account (operating-system-users os)))) (define (maybe-string->file file-name thing) "If THING is a string, return a with THING as its content. Otherwise just return THING. This is for backward-compatibility of fields that used to be strings and are now file-like objects.." (match thing ((? string?) (warning (G_ "using a string for file '~a' is deprecated; \ use 'plain-file' instead~%") file-name) (plain-file file-name thing)) (x x))) (define (maybe-file->monadic file-name thing) "If THING is a value in %STORE-MONAD, return it as is; otherwise return THING in the %STORE-MONAD. This is for backward-compatibility of fields that used to be monadic values and are now file-like objects." (with-monad %store-monad (match thing ((? procedure?) (warning (G_ "using a monadic value for '~a' is deprecated; \ use 'plain-file' instead~%") file-name) thing) (x (return x))))) (define (operating-system-etc-directory os) "Return that static part of the /etc directory of OS." (etc-directory (fold-services (operating-system-services os) #:target-type etc-service-type))) (define (operating-system-environment-variables os) "Return the environment variables of OS for @var{session-environment-service-type}, to be used in @file{/etc/environment}." `(("LANG" . ,(operating-system-locale os)) ;; Note: No need to set 'TZ' since (1) we provide /etc/localtime, and (2) ;; it doesn't work for setuid binaries. See . ("TZDIR" . ,(file-append tzdata "/share/zoneinfo")) ;; Tell 'modprobe' & co. where to look for modules. ("LINUX_MODULE_DIRECTORY" . "/run/booted-system/kernel/lib/modules") ;; These variables are honored by OpenSSL (libssl) and Git. ("SSL_CERT_DIR" . "/etc/ssl/certs") ("SSL_CERT_FILE" . "/etc/ssl/certs/ca-certificates.crt") ("GIT_SSL_CAINFO" . "/etc/ssl/certs/ca-certificates.crt") ;; 'GTK_DATA_PREFIX' must name one directory where GTK+ themes are ;; searched for. ("GTK_DATA_PREFIX" . "/run/current-system/profile") ;; By default, applications that use D-Bus, such as Emacs, abort at startup ;; when /etc/machine-id is missing. Make sure these warnings are non-fatal. ("DBUS_FATAL_WARNINGS" . "0"))) ;; Ensure LST is a list of records and warn otherwise. (define-with-syntax-properties (ensure-setuid-program-list (lst properties)) (%ensure-setuid-program-list lst properties)) ;; We want to be able to use defines, so define a procedure. (define (%ensure-setuid-program-list lst properties) (define warned? #f) (define (warn-once) (unless warned? (warning (source-properties->location properties) (G_ "representing setuid programs with file-like objects is \ deprecated; use 'setuid-program' instead~%")) (set! warned? #t))) (map (match-lambda ((? setuid-program? program) program) (program ;; PROGRAM is a file-like or a gexp like #~(string-append #$foo ;; "/bin/bar"). (warn-once) (setuid-program (program program)))) lst)) (define %setuid-programs ;; Default set of setuid-root programs. (let ((shadow (@ (gnu packages admin) shadow))) (map file-like->setuid-program (list (file-append shadow "/bin/passwd") (file-append shadow "/bin/chfn") (file-append shadow "/bin/sg") (file-append shadow "/bin/su") (file-append shadow "/bin/newgrp") (file-append shadow "/bin/newuidmap") (file-append shadow "/bin/newgidmap") (file-append inetutils "/bin/ping") (file-append inetutils "/bin/ping6") (file-append sudo "/bin/sudo") (file-append sudo "/bin/sudoedit") (file-append fuse-2 "/bin/fusermount") (file-append fuse "/bin/fusermount3") ;; To allow mounts with the "user" option, "mount" and "umount" must ;; be setuid-root. (file-append util-linux "/bin/mount") (file-append util-linux "/bin/umount"))))) (define %sudoers-specification ;; Default /etc/sudoers contents: 'root' and all members of the 'wheel' ;; group can do anything. See ;; . ;; TODO: Add a declarative API. (plain-file "sudoers" "\ root ALL=(ALL) ALL %wheel ALL=(ALL) ALL\n")) (define* (operating-system-activation-script os) "Return the activation script for OS---i.e., the code that \"activates\" the stateful part of OS, including user accounts and groups, special directories, etc." (let* ((services (operating-system-services os)) (activation (fold-services services #:target-type activation-service-type))) (activation-service->script activation))) (define* (operating-system-boot-script os) "Return the boot script for OS---i.e., the code started by the initrd once we're running in the final root." (let* ((services (operating-system-services os)) (boot (fold-services services #:target-type boot-service-type))) (service-value boot))) (define (operating-system-user-accounts os) "Return the list of user accounts of OS." (let* ((services (operating-system-services os)) (account (fold-services services #:target-type account-service-type))) (filter user-account? (service-value account)))) (define (operating-system-shepherd-service-names os) "Return the list of Shepherd service names for OS." (append-map shepherd-service-provision (shepherd-configuration-services (service-value (fold-services (operating-system-services os) #:target-type shepherd-root-service-type))))) (define* (operating-system-derivation os) "Return a derivation that builds OS." (let* ((services (operating-system-services os)) (system (fold-services services))) ;; SYSTEM contains the derivation as a monadic value. (service-value system))) (define* (operating-system-profile os) "Return a derivation that builds the system profile of OS." (mlet* %store-monad ((services -> (operating-system-services os)) (profile (fold-services services #:target-type profile-service-type))) (match profile (("profile" profile) (return profile))))) (define (operating-system-root-file-system os) "Return the root file system of OS." (or (find (lambda (fs) (string=? "/" (file-system-mount-point fs))) (operating-system-file-systems os)) (raise (condition (&message (message "missing root file system")) (&error-location (location (operating-system-location os))))))) (define (operating-system-initrd-file os) "Return a gexp denoting the initrd file of OS." (define boot-file-systems (filter file-system-needed-for-boot? (operating-system-file-systems os))) (define mapped-devices (operating-system-boot-mapped-devices os)) (define make-initrd (operating-system-initrd os)) (make-initrd boot-file-systems #:linux (operating-system-kernel os) #:linux-modules (operating-system-initrd-modules os) #:mapped-devices mapped-devices #:keyboard-layout (operating-system-keyboard-layout os))) (define* (operating-system-uuid os #:optional (type 'dce)) "Compute UUID object with a deterministic \"UUID\" for OS, of the given TYPE (one of 'iso9660 or 'dce). Return a UUID object." ;; Note: For this to be deterministic, we must not hash things that contains ;; (directly or indirectly) procedures, for example. That rules out ;; anything that contains gexps, thunk or delayed record fields, etc. (define service-name (compose service-type-name service-kind)) (define (file-system-digest fs) ;; Return a hashable digest that does not contain 'dependencies' since ;; this field can contain procedures. (let ((device (file-system-device fs))) (list (file-system-mount-point fs) (file-system-type fs) (file-system-device->string device) (file-system-options fs)))) (if (eq? type 'iso9660) (let ((pad (compose (cut string-pad <> 2 #\0) number->string)) (h (hash (map service-name (operating-system-services os)) 3600))) (bytevector->uuid (string->iso9660-uuid (string-append "1970-01-01-" (pad (hash (operating-system-host-name os) 24)) "-" (pad (quotient h 60)) "-" (pad (modulo h 60)) "-" (pad (hash (map file-system-digest (operating-system-file-systems os)) 100)))) 'iso9660)) (bytevector->uuid (uint-list->bytevector (list (hash (map file-system-digest (operating-system-file-systems os)) (- (expt 2 32) 1)) (hash (operating-system-host-name os) (- (expt 2 32) 1)) (hash (map service-name (operating-system-services os)) (- (expt 2 32) 1)) (hash (map file-system-digest (operating-system-file-systems os)) (- (expt 2 32) 1))) (endianness little) 4) type))) (define (locale-name->definition* name) "Variant of 'locale-name->definition' that raises an error upon failure." (match (locale-name->definition name) (#f (raise (formatted-message (G_ "~a: invalid locale name") name))) (def def))) (define (operating-system-locale-directory os) "Return the directory containing the locales compiled for the definitions listed in OS. The C library expects to find it under /run/current-system/locale." (define name (operating-system-locale os)) (define definitions ;; While we're at it, check whether NAME is defined and add it if needed. (if (member name (map locale-definition-name (operating-system-locale-definitions os))) (operating-system-locale-definitions os) (cons (locale-name->definition* name) (operating-system-locale-definitions os)))) (locale-directory definitions #:libcs (operating-system-locale-libcs os))) (define* (kernel->boot-label kernel #:key hurd) "Return a label for the bootloader menu entry that boots KERNEL." (cond ((package? hurd) (string-append "GNU with the " (string-titlecase (package-name hurd)) " " (package-version hurd))) ((package? kernel) (string-append "GNU with " (string-titlecase (package-name kernel)) " " (package-version kernel))) ((inferior-package? kernel) (string-append "GNU with " (string-titlecase (inferior-package-name kernel)) " " (inferior-package-version kernel))) (else "GNU"))) (define (operating-system-default-label os) "Return the default label for OS, as it will appear in the bootloader menu entry." (kernel->boot-label (operating-system-kernel os) #:hurd (operating-system-hurd os))) (define (store-file-system file-systems) "Return the file system object among FILE-SYSTEMS that contains the store." (match (filter (lambda (fs) (and (file-system-mount? fs) (not (memq 'bind-mount (file-system-flags fs))) (string-prefix? (file-system-mount-point fs) (%store-prefix)))) file-systems) ((and candidates (head . tail)) (reduce (lambda (fs1 fs2) (if (> (string-length (file-system-mount-point fs1)) (string-length (file-system-mount-point fs2))) fs1 fs2)) head candidates)))) (define (operating-system-store-file-system os) "Return the file system that contains the store of OS." (store-file-system (operating-system-file-systems os))) (define* (operating-system-bootcfg os #:optional (old-entries '())) "Return the bootloader configuration file for OS. Use OLD-ENTRIES, a list of , to populate the \"old entries\" menu." (let* ((file-systems (operating-system-file-systems os)) (root-fs (operating-system-root-file-system os)) (root-device (file-system-device root-fs)) (locale (operating-system-locale os)) (crypto-devices (operating-system-bootloader-crypto-devices os)) (params (operating-system-boot-parameters os root-device #:system-kernel-arguments? #t)) (entry (boot-parameters->menu-entry params)) (bootloader-conf (operating-system-bootloader os))) (define generate-config-file (bootloader-configuration-file-generator (bootloader-configuration-bootloader bootloader-conf))) (generate-config-file bootloader-conf (list entry) #:old-entries old-entries #:locale locale #:store-crypto-devices crypto-devices #:store-directory-prefix (btrfs-store-subvolume-file-name file-systems)))) (define (operating-system-multiboot-modules os) (if (operating-system-hurd os) (hurd-multiboot-modules os) '())) (define (hurd-multiboot-modules os) (let* ((hurd (operating-system-hurd os)) (pci-arbiter-command (list (file-append hurd "/hurd/pci-arbiter.static") "pci-arbiter" "--host-priv-port='${host-port}'" "--device-master-port='${device-port}'" "--next-task='${disk-task}'" "'$(pci-task=task-create)'" "'$(task-resume)'")) (rumpdisk-command (list (file-append hurd "/hurd/rumpdisk.static") "rumpdisk" "--next-task='${fs-task}'" "'$(disk-task=task-create)'")) (root-file-system-command (list (file-append hurd "/hurd/ext2fs.static") "ext2fs" "--multiboot-command-line='${kernel-command-line}'" "--exec-server-task='${exec-task}'" "--store-type=typed" "--x-xattr-translator-records" "'${root}'" "'$(fs-task=task-create)'")) (target (%current-target-system)) (libc (if target (with-parameters ((%current-target-system #f)) ;; TODO: cross-libc has extra patches for the Hurd; ;; remove in next rebuild cycle (cross-libc target)) glibc)) (exec-server-command ;; XXX: Run the statically-linked 'exec' to work around ;; , which manifests on some ;; machines. ;; (list (file-append libc "/lib/ld.so.1") "exec" ;; (file-append hurd "/hurd/exec") "'$(exec-task=task-create)'") (list (file-append hurd "/hurd/exec.static") "exec" "'$(exec-task=task-create)'"))) (list pci-arbiter-command rumpdisk-command root-file-system-command exec-server-command))) (define* (operating-system-boot-parameters os root-device #:key system-kernel-arguments?) "Return a monadic record that describes the boot parameters of OS. When SYSTEM-KERNEL-ARGUMENTS? is true, add the kernel arguments 'root', 'gnu.load' and 'gnu.system' to . The SYSTEM-KERNEL-ARGUMENTS? should only be used in necessity, as the 'gnu.load' and 'gnu.system' values are self-referential (they refer to the system), thus susceptible to introduce a cyclic dependency." (let* ((initrd (and (not (operating-system-hurd os)) (operating-system-initrd-file os))) (store (operating-system-store-file-system os)) (file-systems (operating-system-file-systems os)) (crypto-devices (operating-system-bootloader-crypto-devices os)) (locale (operating-system-locale os)) (bootloader (bootloader-configuration-bootloader (operating-system-bootloader os))) (bootloader-name (bootloader-name bootloader)) (label (operating-system-label os)) (multiboot-modules (operating-system-multiboot-modules os))) (boot-parameters (label label) (root-device root-device) (kernel (operating-system-kernel-file os)) (kernel-arguments (if system-kernel-arguments? (operating-system-kernel-arguments os root-device) (operating-system-user-kernel-arguments os))) (initrd initrd) (multiboot-modules multiboot-modules) (bootloader-name bootloader-name) (bootloader-menu-entries (bootloader-configuration-menu-entries (operating-system-bootloader os))) (locale locale) (store-device (ensure-not-/dev (file-system-device store))) (store-directory-prefix (btrfs-store-subvolume-file-name file-systems)) (store-crypto-devices crypto-devices) (store-mount-point (file-system-mount-point store))))) (define (device->sexp device) "Serialize DEVICE as an sexp (really, as an object with a read syntax.)" (match device ((? uuid? uuid) `(uuid ,(uuid-type uuid) ,(uuid-bytevector uuid))) ((? file-system-label? label) `(file-system-label ,(file-system-label->string label))) (_ device))) (define* (operating-system-boot-parameters-file os) "Return a file that describes the boot parameters of OS. The primary use of this file is the reconstruction of GRUB menu entries for old configurations." (let* ((root (operating-system-root-file-system os)) (device (file-system-device root)) (params (operating-system-boot-parameters os device))) (scheme-file "parameters" #~(boot-parameters (version #$(boot-parameters-version params)) (label #$(boot-parameters-label params)) (root-device #$(device->sexp (boot-parameters-root-device params))) (kernel #$(boot-parameters-kernel params)) (kernel-arguments #$(boot-parameters-kernel-arguments params)) #$@(if (boot-parameters-initrd params) #~((initrd #$(boot-parameters-initrd params))) #~()) #$@(if (pair? (boot-parameters-multiboot-modules params)) #~((multiboot-modules #$(boot-parameters-multiboot-modules params))) #~()) (bootloader-name #$(boot-parameters-bootloader-name params)) (bootloader-menu-entries #$(map menu-entry->sexp (or (and=> (operating-system-bootloader os) bootloader-configuration-menu-entries) '()))) (locale #$(boot-parameters-locale params)) (store (device #$(device->sexp (boot-parameters-store-device params))) (mount-point #$(boot-parameters-store-mount-point params)) (directory-prefix #$(boot-parameters-store-directory-prefix params)) (crypto-devices #$(map device->sexp (boot-parameters-store-crypto-devices params))))) #:set-load-path? #f))) (define-gexp-compiler (operating-system-compiler (os ) system target) ((store-lift (lambda (store) ;; XXX: This is not super elegant but we can't pass SYSTEM and TARGET to ;; 'operating-system-derivation'. (parameterize ((%current-system system) (%current-target-system target)) (run-with-store store (mbegin %store-monad (set-guile-for-build (default-guile)) (operating-system-derivation os)) #:system system #:target target)))))) ;;; system.scm ends here