;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018 Ludovic Courtès ;;; Copyright © 2015 Mark H Weaver ;;; Copyright © 2015, 2016 Alex Kost ;;; Copyright © 2016 Chris Marusich ;;; Copyright © 2017 Mathieu Othacehe ;;; ;;; This file is part of GNU Guix. ;;; ;;; GNU Guix is free software; you can redistribute it and/or modify it ;;; under the terms of the GNU General Public License as published by ;;; the Free Software Foundation; either version 3 of the License, or (at ;;; your option) any later version. ;;; ;;; GNU Guix is distributed in the hope that it will be useful, but ;;; WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;;; GNU General Public License for more details. ;;; ;;; You should have received a copy of the GNU General Public License ;;; along with GNU Guix. If not, see
aboutsummaryrefslogtreecommitdiff
path: root/gnu/bootloader.scm
blob: 01bdd4acaa9d78feccd1ec67f345b1a75cb5b01a (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
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190

;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2017 David Craven <david@craven.ch>
;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com>
;;; Copyright © 2017 Leo Famulari <leo@famulari.name>
;;; Copyright © 2019 Ludovic Courtès <ludo@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
;;; GNU Guix is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; GNU Guix is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.

(define-module (gnu bootloader)
  #:use-module (guix discovery)
  #:use-module (guix records)
  #:use-module (guix ui)
  #:use-module (srfi srfi-1)
  #:use-module (ice-9 match)
  #:export (menu-entry
            menu-entry?
            menu-entry-label
            menu-entry-device
            menu-entry-linux
            menu-entry-linux-arguments
            menu-entry-initrd
            menu-entry-device-mount-point

            menu-entry->sexp
            sexp->menu-entry

            bootloader
            bootloader?
            bootloader-name
            bootloader-package
            bootloader-installer
            bootloader-configuration-file
            bootloader-configuration-file-generator

            bootloader-configuration
            bootloader-configuration?
            bootloader-configuration-bootloader
            bootloader-configuration-target
            bootloader-configuration-menu-entries
            bootloader-configuration-default-entry
            bootloader-configuration-timeout
            bootloader-configuration-keyboard-layout
            bootloader-configuration-theme
            bootloader-configuration-terminal-outputs
            bootloader-configuration-terminal-inputs
            bootloader-configuration-serial-unit
            bootloader-configuration-serial-speed
            bootloader-configuration-additional-configuration

            %bootloaders
            lookup-bootloader-by-name))


;;;
;;; Menu-entry record.
;;;

(define-record-type* <menu-entry>
  menu-entry make-menu-entry
  menu-entry?
  (label           menu-entry-label)
  (device          menu-entry-device       ; file system uuid, label, or #f
                   (default #f))
  (device-mount-point menu-entry-device-mount-point
                   (default #f))
  (linux           menu-entry-linux)
  (linux-arguments menu-entry-linux-arguments
                   (default '()))          ; list of string-valued gexps
  (initrd          menu-entry-initrd))     ; file name of the initrd as a gexp

(define (menu-entry->sexp entry)
  "Return ENTRY serialized as an sexp."
  (match entry
    (($ <menu-entry> label device mount-point linux linux-arguments initrd)
     `(menu-entry (version 0)
                  (label ,label)
                  (device ,device)
                  (device-mount-point ,mount-point)
                  (linux ,linux)
                  (linux-arguments ,linux-arguments)
                  (initrd ,initrd)))))

(define (sexp->menu-entry sexp)
  "Turn SEXP, an sexp as returned by 'menu-entry->sexp', into a <menu-entry>
record."
  (match sexp
    (('menu-entry ('version 0)
                  ('label label) ('device device)
                  ('device-mount-point mount-point)
                  ('linux linux) ('linux-arguments linux-arguments)
                  ('initrd initrd) _ ...)
     (menu-entry
      (label label)
      (device device)
      (device-mount-point mount-point)
      (linux linux)
      (linux-arguments linux-arguments)
      (initrd initrd)))))


;;;
;;; Bootloader record.
;;;

;; The <bootloader> record contains fields expressing how the bootloader
;; should be installed. Every bootloader in gnu/bootloader/ directory
;; has to be described by this record.

(define-record-type* <bootloader>
  bootloader make-bootloader
  bootloader?
  (name                            bootloader-name)
  (package                         bootloader-package)
  (installer                       bootloader-installer)
  (configuration-file              bootloader-configuration-file)
  (configuration-file-generator    bootloader-configuration-file-generator))


;;;
;;; Bootloader configuration record.
;;;

;; The <bootloader-configuration> record contains bootloader independant
;; configuration used to fill bootloader configuration file.

(define-record-type* <bootloader-configuration>
  bootloader-configuration make-bootloader-configuration
  bootloader-configuration?
  (bootloader         bootloader-configuration-bootloader) ;<bootloader>
  (target             bootloader-configuration-target      ;string
                      (default #f))
  (menu-entries       bootloader-configuration-menu-entries ;list of <menu-entry>
                      (default '()))
  (default-entry      bootloader-configuration-default-entry ;integer
                      (default 0))
  (timeout            bootloader-configuration-timeout ;seconds as integer
                      (default 5))
  (keyboard-layout    bootloader-configuration-keyboard-layout ;<keyboard-layout> | #f
                      (default #f))
  (theme              bootloader-configuration-theme ;bootloader-specific theme
                      (default #f))
  (terminal-outputs   bootloader-configuration-terminal-outputs ;list of symbols
                      (default '(gfxterm)))
  (terminal-inputs    bootloader-configuration-terminal-inputs ;list of symbols
                      (default '()))
  (serial-unit        bootloader-configuration-serial-unit ;integer | #f
                      (default #f))
  (serial-speed       bootloader-configuration-serial-speed ;integer | #f
                      (default #f)))


;;;
;;; Bootloaders.
;;;

(define (bootloader-modules)
  "Return the list of bootloader modules."
  (all-modules (map (lambda (entry)
                      `(,entry . "gnu/bootloader"))
                    %load-path)
               #:warn warn-about-load-error))

(define %bootloaders
  ;; The list of publically-known bootloaders.
  (delay (fold-module-public-variables (lambda (obj result)
                                         (if (bootloader? obj)
                                             (cons obj result)
                                             result))
                                       '()
                                       (bootloader-modules))))

(define (lookup-bootloader-by-name name)
  "Return the bootloader called NAME."
  (or (find (lambda (bootloader)
              (eq? name (bootloader-name bootloader)))
            (force %bootloaders))
      (leave (G_ "~a: no such bootloader~%") name)))
generated by cgit
(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 (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 (swap-services os) "Return the list of swap services for OS." (map swap-service (operating-system-swap-devices os))) (define* (system-linux-image-file-name #:optional (system (%current-system))) "Return the basename of the kernel image file for SYSTEM." ;; FIXME: Evaluate the conditional based on the actual current system. (cond ((string-prefix? "arm" (%current-system)) "zImage") ((string-prefix? "mips" (%current-system)) "vmlinuz") ((string-prefix? "aarch64" (%current-system)) "Image") (else "bzImage"))) (define (operating-system-kernel-file os) "Return an object representing the absolute file name of the kernel image of OS." (file-append (operating-system-kernel os) "/" (system-linux-image-file-name os))) (define* (operating-system-directory-base-entries os #:key container?) "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))) (with-monad %store-monad (if container? (return `(("locale" ,locale))) (mlet %store-monad ((kernel -> (operating-system-kernel os)) (initrd (operating-system-initrd-file os)) (params (operating-system-boot-parameters-file os))) (return `(("kernel" ,kernel) ("parameters" ,params) ("initrd" ,initrd) ("locale" ,locale)))))))) ;used by libc (define* (essential-services os #:key container?) "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. CONTAINER? determines whether to return the list of services for a container or that of a \"bare metal\" system." (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)) (other-fs (non-boot-file-system-service os)) (swaps (swap-services os)) (procs (service user-processes-service-type)) (host-name (host-name-service (operating-system-host-name os))) (entries (operating-system-directory-base-entries os #:container? container?))) (cons* (service system-service-type entries) %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) (service fstab-service-type '()) (session-environment-service (operating-system-environment-variables os)) host-name procs root-fs (service setuid-program-service-type (operating-system-setuid-programs os)) (service profile-service-type (operating-system-packages os)) other-fs (append mappings swaps ;; Add the firmware service, unless we are building for a ;; container. (if container? (list %containerized-shepherd-service) (list %linux-bare-metal-service (service firmware-service-type (operating-system-firmware os)))))))) (define* (operating-system-services os #:key container?) "Return all the services of OS, including \"internal\" services that do not explicitly appear in OS." (instantiate-missing-services (append (operating-system-user-services os) (essential-services os #:container? container?)))) ;;; ;;; /etc. ;;; (define %base-firmware ;; Firmware usable by default. (list ath9k-htc-firmware openfwwf-firmware)) (define %base-packages ;; Default set of packages globally visible. It should include anything ;; required for basic administrator tasks. (cons* procps psmisc which less zile nano pciutils usbutils util-linux inetutils isc-dhcp (@ (gnu packages admin) shadow) ;for 'passwd' ;; 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 iproute net-tools ; XXX: remove when Inetutils suffices man-db info-reader ;the standalone Info reader (no Perl) ;; 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 ;; Get 'insmod' & co. from kmod, not module-init-tools, since udev ;; already depends on it anyway. kmod eudev e2fsprogs kbd bash-completion ;; XXX: We don't use (canonical-package guile-2.2) here because that ;; would create a collision in the global profile between the GMP ;; variant propagated by 'guile-final' and the GMP variant propagated ;; by 'gnutls', itself propagated by 'guix'. guile-2.2 ;; The packages below are also in %FINAL-INPUTS, so take them from ;; there to avoid duplication. (map canonical-package (list bash coreutils findutils grep sed diffutils patch gawk tar gzip bzip2 xz lzip)))) (define %default-issue ;; Default contents for /etc/issue. " This is the GNU system. Welcome.\n") (define (local-host-aliases host-name) "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 (default-/etc/hosts host-name) "Return the default /etc/hosts file." (plain-file "hosts" (local-host-aliases host-name))) (define* (operating-system-etc-service os) "Return a that builds 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"))) (issue (plain-file "issue" (operating-system-issue os))) (nsswitch (plain-file "nsswitch.conf" (name-service-switch->string (operating-system-name-service-switch 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. # 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"))) (etc-service `(("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) ("nsswitch.conf" ,#~#$nsswitch) ("profile" ,#~#$profile) ("bashrc" ,#~#$bashrc) ("hosts" ,#~#$(or (operating-system-hosts-file os) (default-/etc/hosts (operating-system-host-name os)))) ;; 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))) ("localtime" ,(file-append tzdata "/share/zoneinfo/" (operating-system-timezone os))) ("sudoers" ,(operating-system-sudoers-file os)))))) (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") ;; XXX: Normally we wouldn't need to do this, but our glibc@2.23 package ;; used to look things up in 'PREFIX/lib/locale' instead of ;; '/run/current-system/locale' as was intended. Keep this hack around so ;; that people who still have glibc@2.23-using packages in their profiles ;; can use them correctly. ;; TODO: Remove when glibc@2.23 is long gone. ("GUIX_LOCPATH" . "/run/current-system/locale"))) (define %setuid-programs ;; Default set of setuid-root programs. (let ((shadow (@ (gnu packages admin) shadow))) (list (file-append shadow "/bin/passwd") (file-append shadow "/bin/su") (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 fuse "/bin/fusermount")))) (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 #:key container?) "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 #:container? container?)) (activation (fold-services services #:target-type activation-service-type))) (activation-service->script activation))) (define* (operating-system-boot-script os #:key container?) "Return the boot script for OS---i.e., the code started by the initrd once we're running in the final root. When CONTAINER? is true, skip all hardware-related operations as necessary when booting a Linux container." (let* ((services (operating-system-services os #:container? container?)) (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 (service-value (fold-services (operating-system-services os) #:target-type shepherd-root-service-type)))) (define* (operating-system-derivation os #:key container?) "Return a derivation that builds OS." (let* ((services (operating-system-services os #:container? container?)) (system (fold-services services))) ;; SYSTEM contains the derivation as a monadic value. (service-value system))) (define* (operating-system-profile os #:key container?) "Return a derivation that builds the system profile of OS." (mlet* %store-monad ((services -> (operating-system-services os #:container? container?)) (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." (find (lambda (fs) (string=? "/" (file-system-mount-point fs))) (operating-system-file-systems 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)) (mlet %store-monad ((initrd (make-initrd boot-file-systems #:linux (operating-system-kernel os) #:linux-modules (operating-system-initrd-modules os) #:mapped-devices mapped-devices))) (return (file-append initrd "/initrd")))) (define (locale-name->definition* name) "Variant of 'locale-name->definition' that raises an error upon failure." (match (locale-name->definition name) (#f (raise (condition (&message (message (format #f (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) "Return a label for the bootloader menu entry that boots KERNEL." (string-append "GNU with " (string-titlecase (package-name kernel)) " " (package-version kernel) " (beta)")) (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 (which is a list of ) to populate the \"old entries\" menu." (mlet* %store-monad ((system (operating-system-derivation os)) (root-fs -> (operating-system-root-file-system os)) (root-device -> (file-system-device root-fs)) (params (operating-system-boot-parameters os system root-device)) (entry -> (boot-parameters->menu-entry params)) (bootloader-conf -> (operating-system-bootloader os))) ((bootloader-configuration-file-generator (bootloader-configuration-bootloader bootloader-conf)) bootloader-conf (list entry) #:old-entries old-entries))) (define (operating-system-boot-parameters os system.drv root-device) "Return a monadic record that describes the boot parameters of OS. SYSTEM.DRV is either a derivation or #f. If it's a derivation, adds kernel arguments for that derivation to ." (mlet* %store-monad ((initrd (operating-system-initrd-file os)) (store -> (operating-system-store-file-system os)) (bootloader -> (bootloader-configuration-bootloader (operating-system-bootloader os))) (bootloader-name -> (bootloader-name bootloader)) (label -> (kernel->boot-label (operating-system-kernel os)))) (return (boot-parameters (label label) (root-device root-device) (kernel (operating-system-kernel-file os)) (kernel-arguments (if system.drv (operating-system-kernel-arguments os system.drv root-device) (operating-system-user-kernel-arguments os))) (initrd initrd) (bootloader-name bootloader-name) (store-device (ensure-not-/dev (file-system-device store))) (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 #:optional (system.drv #f)) "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. SYSTEM.DRV is optional. If given, adds kernel arguments for that system to the returned file (since the returned file is then usually stored into the content-addressed \"system\" directory, it's usually not a good idea to give it because the content hash would change by the content hash being stored into the \"parameters\" file)." (mlet* %store-monad ((root -> (operating-system-root-file-system os)) (device -> (file-system-device root)) (params (operating-system-boot-parameters os system.drv device))) (gexp->file "parameters" #~(boot-parameters (version 0) (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)) (initrd #$(boot-parameters-initrd params)) (bootloader-name #$(boot-parameters-bootloader-name params)) (store (device #$(device->sexp (boot-parameters-store-device params))) (mount-point #$(boot-parameters-store-mount-point 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'. (run-with-store store (operating-system-derivation os) #:system system #:target target))))) ;;; system.scm ends here