1 ;;; GNU Guix --- Functional package management for GNU
2 ;;; Copyright © 2013, 2014, 2015, 2016 Ludovic Courtès <ludo@gnu.org>
3 ;;; Copyright © 2015 Mark H Weaver <mhw@netris.org>
4 ;;; Copyright © 2015, 2016 Alex Kost <alezost@gmail.com>
6 ;;; This file is part of GNU Guix.
8 ;;; GNU Guix is free software; you can redistribute it and/or modify it
9 ;;; under the terms of the GNU General Public License as published by
10 ;;; the Free Software Foundation; either version 3 of the License, or (at
11 ;;; your option) any later version.
13 ;;; GNU Guix is distributed in the hope that it will be useful, but
14 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
15 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
16 ;;; GNU General Public License for more details.
18 ;;; You should have received a copy of the GNU General Public License
19 ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
21 (define-module (gnu system)
22 #:use-module (guix store)
23 #:use-module (guix monads)
24 #:use-module (guix gexp)
25 #:use-module (guix records)
26 #:use-module (guix packages)
27 #:use-module (guix derivations)
28 #:use-module (guix profiles)
29 #:use-module (guix ui)
30 #:use-module (gnu packages base)
31 #:use-module (gnu packages bash)
32 #:use-module (gnu packages guile)
33 #:use-module (gnu packages admin)
34 #:use-module (gnu packages linux)
35 #:use-module (gnu packages pciutils)
36 #:use-module (gnu packages package-management)
37 #:use-module (gnu packages less)
38 #:use-module (gnu packages zile)
39 #:use-module (gnu packages nano)
40 #:use-module (gnu packages lsof)
41 #:use-module (gnu packages gawk)
42 #:use-module (gnu packages man)
43 #:use-module (gnu packages texinfo)
44 #:use-module (gnu packages compression)
45 #:use-module (gnu packages firmware)
46 #:autoload (gnu packages cryptsetup) (cryptsetup)
47 #:use-module (gnu services)
48 #:use-module (gnu services shepherd)
49 #:use-module (gnu services base)
50 #:use-module (gnu system grub)
51 #:use-module (gnu system shadow)
52 #:use-module (gnu system nss)
53 #:use-module (gnu system locale)
54 #:use-module (gnu system pam)
55 #:use-module (gnu system linux-initrd)
56 #:use-module (gnu system file-systems)
57 #:use-module (ice-9 match)
58 #:use-module (srfi srfi-1)
59 #:use-module (srfi srfi-26)
60 #:use-module (srfi srfi-34)
61 #:use-module (srfi srfi-35)
62 #:export (operating-system
65 operating-system-bootloader
66 operating-system-services
67 operating-system-user-services
68 operating-system-packages
69 operating-system-host-name
70 operating-system-hosts-file
71 operating-system-kernel
72 operating-system-kernel-arguments
73 operating-system-initrd
74 operating-system-users
75 operating-system-groups
76 operating-system-issue
77 operating-system-timezone
78 operating-system-locale
79 operating-system-locale-definitions
80 operating-system-locale-libcs
81 operating-system-mapped-devices
82 operating-system-file-systems
83 operating-system-store-file-system
84 operating-system-activation-script
86 operating-system-derivation
87 operating-system-profile
88 operating-system-grub.cfg
89 operating-system-etc-directory
90 operating-system-locale-directory
91 operating-system-boot-script
96 boot-parameters-root-device
97 boot-parameters-kernel
98 boot-parameters-kernel-arguments
106 luks-device-mapping))
110 ;;; This module supports whole-system configuration.
114 ;; System-wide configuration.
115 ;; TODO: Add per-field docstrings/stexi.
116 (define-record-type* <operating-system> operating-system
117 make-operating-system
119 (kernel operating-system-kernel ; package
120 (default linux-libre))
121 (kernel-arguments operating-system-kernel-arguments
122 (default '())) ; list of gexps/strings
123 (bootloader operating-system-bootloader) ; <grub-configuration>
125 (initrd operating-system-initrd ; (list fs) -> M derivation
126 (default base-initrd))
127 (firmware operating-system-firmware ; list of packages
128 (default %base-firmware))
130 (host-name operating-system-host-name) ; string
131 (hosts-file operating-system-hosts-file ; file-like | #f
134 (mapped-devices operating-system-mapped-devices ; list of <mapped-device>
136 (file-systems operating-system-file-systems) ; list of fs
137 (swap-devices operating-system-swap-devices ; list of strings
140 (users operating-system-users ; list of user accounts
141 (default %base-user-accounts))
142 (groups operating-system-groups ; list of user groups
143 (default %base-groups))
145 (skeletons operating-system-skeletons ; list of name/monadic value
146 (default (default-skeletons)))
147 (issue operating-system-issue ; string
148 (default %default-issue))
150 (packages operating-system-packages ; list of (PACKAGE OUTPUT...)
151 (default %base-packages)) ; or just PACKAGE
153 (timezone operating-system-timezone) ; string
154 (locale operating-system-locale ; string
155 (default "en_US.utf8"))
156 (locale-definitions operating-system-locale-definitions ; list of <locale-definition>
157 (default %default-locale-definitions))
158 (locale-libcs operating-system-locale-libcs ; list of <packages>
159 (default %default-locale-libcs))
160 (name-service-switch operating-system-name-service-switch ; <name-service-switch>
161 (default %default-nss))
163 (services operating-system-user-services ; list of monadic services
164 (default %base-services))
166 (pam-services operating-system-pam-services ; list of PAM services
167 (default (base-pam-services)))
168 (setuid-programs operating-system-setuid-programs
169 (default %setuid-programs)) ; list of string-valued gexps
171 (sudoers-file operating-system-sudoers-file ; file-like
172 (default %sudoers-specification)))
179 (define (open-luks-device source target)
180 "Return a gexp that maps SOURCE to TARGET as a LUKS device, using
182 #~(zero? (system* (string-append #$cryptsetup "/sbin/cryptsetup")
183 "open" "--type" "luks"
186 (define (close-luks-device source target)
187 "Return a gexp that closes TARGET, a LUKS device."
188 #~(zero? (system* (string-append #$cryptsetup "/sbin/cryptsetup")
191 (define luks-device-mapping
192 ;; The type of LUKS mapped devices.
194 (open open-luks-device)
195 (close close-luks-device)))
197 (define (other-file-system-services os)
198 "Return file system services for the file systems of OS that are not marked
199 as 'needed-for-boot'."
201 (remove file-system-needed-for-boot?
202 (operating-system-file-systems os)))
204 (define (device-mappings fs)
205 (let ((device (file-system-device fs)))
206 (if (string? device) ;title is 'device
208 (string=? (string-append "/dev/mapper/"
209 (mapped-device-target md))
211 (operating-system-mapped-devices os))
214 (define (add-dependencies fs)
215 ;; Add the dependencies due to device mappings to FS.
219 (delete-duplicates (append (device-mappings fs)
220 (file-system-dependencies fs))
223 (map (compose file-system-service add-dependencies) file-systems))
225 (define (mapped-device-user device file-systems)
226 "Return a file system among FILE-SYSTEMS that uses DEVICE, or #f."
227 (let ((target (string-append "/dev/mapper/" (mapped-device-target device))))
229 (and (eq? 'device (file-system-title fs))
230 (string=? (file-system-device fs) target)))
233 (define (operating-system-user-mapped-devices os)
234 "Return the subset of mapped devices that can be installed in
235 user-land--i.e., those not needed during boot."
236 (let ((devices (operating-system-mapped-devices os))
237 (file-systems (operating-system-file-systems os)))
239 (let ((user (mapped-device-user md file-systems)))
241 (not (file-system-needed-for-boot? user)))))
244 (define (operating-system-boot-mapped-devices os)
245 "Return the subset of mapped devices that must be installed during boot,
247 (let ((devices (operating-system-mapped-devices os))
248 (file-systems (operating-system-file-systems os)))
250 (let ((user (mapped-device-user md file-systems)))
251 (and user (file-system-needed-for-boot? user))))
254 (define (device-mapping-services os)
255 "Return the list of device-mapping services for OS as a list."
257 (let* ((source (mapped-device-source md))
258 (target (mapped-device-target md))
259 (type (mapped-device-type md))
260 (open (mapped-device-kind-open type))
261 (close (mapped-device-kind-close type)))
262 (device-mapping-service target
264 (close source target))))
265 (operating-system-user-mapped-devices os)))
267 (define (swap-services os)
268 "Return the list of swap services for OS."
269 (map swap-service (operating-system-swap-devices os)))
271 (define* (operating-system-directory-base-entries os #:key container?)
272 "Return the basic entries of the 'system' directory of OS for use as the
273 value of the SYSTEM-SERVICE-TYPE service."
274 (mlet %store-monad ((locale (operating-system-locale-directory os)))
276 (return `(("locale" ,locale)))
278 ((kernel -> (operating-system-kernel os))
279 (initrd (operating-system-initrd-file os))
280 (params (operating-system-parameters-file os)))
281 (return `(("kernel" ,kernel)
282 ("parameters" ,params)
284 ("locale" ,locale))))))) ;used by libc
286 (define* (essential-services os #:key container?)
287 "Return the list of essential services for OS. These are special services
288 that implement part of what's declared in OS are responsible for low-level
289 bookkeeping. CONTAINER? determines whether to return the list of services for
290 a container or that of a \"bare metal\" system."
292 (map file-system-mount-point (operating-system-file-systems os)))
294 (let* ((mappings (device-mapping-services os))
295 (root-fs (root-file-system-service))
296 (other-fs (other-file-system-services os))
297 (unmount (user-unmount-service known-fs))
298 (swaps (swap-services os))
299 (procs (user-processes-service
300 (map service-parameters other-fs)))
301 (host-name (host-name-service (operating-system-host-name os)))
302 (entries (operating-system-directory-base-entries
303 os #:container? container?)))
304 (cons* (service system-service-type entries)
307 ;; %SHEPHERD-ROOT-SERVICE must come first so that the gexp that
308 ;; execs shepherd comes last in the boot script (XXX). Likewise,
309 ;; the cleanup service must come last so that its gexp runs before
311 %shepherd-root-service
313 (service cleanup-service-type #f)
315 (pam-root-service (operating-system-pam-services os))
316 (account-service (append (operating-system-accounts os)
317 (operating-system-groups os))
318 (operating-system-skeletons os))
319 (operating-system-etc-service os)
320 (service fstab-service-type '())
321 (session-environment-service
322 (operating-system-environment-variables os))
323 host-name procs root-fs unmount
324 (service setuid-program-service-type
325 (operating-system-setuid-programs os))
326 (service profile-service-type
327 (operating-system-packages os))
328 (append other-fs mappings swaps
330 ;; Add the firmware service, unless we are building for a
334 (list %linux-bare-metal-service
335 (service firmware-service-type
336 (operating-system-firmware os))))))))
338 (define* (operating-system-services os #:key container?)
339 "Return all the services of OS, including \"internal\" services that do not
340 explicitly appear in OS."
341 (append (operating-system-user-services os)
342 (essential-services os #:container? container?)))
349 (define %base-firmware
350 ;; Firmware usable by default.
351 (list ath9k-htc-firmware))
353 (define %base-packages
354 ;; Default set of packages globally visible. It should include anything
355 ;; required for basic administrator tasks.
356 (cons* procps psmisc which less zile nano
357 lsof ;for Guix's 'list-runtime-roots'
359 util-linux inetutils isc-dhcp
361 ;; wireless-tools is deprecated in favor of iw, but it's still what
362 ;; many people are familiar with, so keep it around.
363 iw wireless-tools rfkill
366 net-tools ; XXX: remove when Inetutils suffices
368 texinfo ;for the standalone Info reader
370 ;; The 'sudo' command is already in %SETUID-PROGRAMS, but we also
371 ;; want the other commands and the man pages (notably because
372 ;; auto-completion in Emacs shell relies on man pages.)
375 ;; Get 'insmod' & co. from kmod, not module-init-tools, since udev
376 ;; already depends on it anyway.
377 kmod eudev-with-blkid
383 ;; The packages below are also in %FINAL-INPUTS, so take them from
384 ;; there to avoid duplication.
385 (map canonical-package
386 (list guile-2.0 bash coreutils findutils grep sed
387 diffutils patch gawk tar gzip bzip2 xz lzip))))
389 (define %default-issue
390 ;; Default contents for /etc/issue.
392 This is the GNU system. Welcome.\n")
394 (define (local-host-aliases host-name)
395 "Return aliases for HOST-NAME, to be used in /etc/hosts."
396 (string-append "127.0.0.1 localhost " host-name "\n"
397 "::1 localhost " host-name "\n"))
399 (define (default-/etc/hosts host-name)
400 "Return the default /etc/hosts file."
401 (plain-file "hosts" (local-host-aliases host-name)))
403 (define (emacs-site-file)
404 "Return the Emacs 'site-start.el' file. That file contains the necessary
405 settings for 'guix.el' to work out-of-the-box."
406 (scheme-file "site-start.el"
408 ;; Add the "normal" elisp directory to the search path;
409 ;; guix.el may be there.
412 "/run/current-system/profile/share/emacs/site-lisp")
414 ;; Attempt to load guix.el.
415 (require 'guix-init nil t)
417 ;; Attempt to load geiser.
418 (require 'geiser-install nil t))))
420 (define (emacs-site-directory)
421 "Return the Emacs site directory, aka. /etc/emacs."
422 (computed-file "emacs"
426 (symlink #$(emacs-site-file) "site-start.el"))))
428 (define* (operating-system-etc-service os)
429 "Return a <service> that builds containing the static part of the /etc
431 (let ((login.defs (plain-file "login.defs" "# Empty for now.\n"))
433 (emacs (emacs-site-directory))
434 (issue (plain-file "issue" (operating-system-issue os)))
435 (nsswitch (plain-file "nsswitch.conf"
436 (name-service-switch->string
437 (operating-system-name-service-switch os))))
439 ;; Startup file for POSIX-compliant login shells, which set system-wide
440 ;; environment variables.
441 (profile (mixed-text-file "profile" "\
442 # Crucial variables that could be missing in the profiles' 'etc/profile'
443 # because they would require combining both profiles.
444 # FIXME: See <http://bugs.gnu.org/20255>.
445 export MANPATH=$HOME/.guix-profile/share/man:/run/current-system/profile/share/man
446 export INFOPATH=$HOME/.guix-profile/share/info:/run/current-system/profile/share/info
447 export XDG_DATA_DIRS=$HOME/.guix-profile/share:/run/current-system/profile/share
448 export XDG_CONFIG_DIRS=$HOME/.guix-profile/etc/xdg:/run/current-system/profile/etc/xdg
450 # Ignore the default value of 'PATH'.
453 # Load the system profile's settings.
454 GUIX_PROFILE=/run/current-system/profile \\
455 . /run/current-system/profile/etc/profile
457 # Prepend setuid programs.
458 export PATH=/run/setuid-programs:$PATH
460 if [ -f \"$HOME/.guix-profile/etc/profile\" ]
462 # Load the user profile's settings.
463 GUIX_PROFILE=\"$HOME/.guix-profile\" \\
464 . \"$HOME/.guix-profile/etc/profile\"
466 # At least define this one so that basic things just work
467 # when the user installs their first package.
468 export PATH=\"$HOME/.guix-profile/bin:$PATH\"
471 # Since 'lshd' does not use pam_env, /etc/environment must be explicitly
472 # loaded when someone logs in via SSH. See <http://bugs.gnu.org/22175>.
473 # We need 'PATH' to be defined here, for 'cat' and 'cut'.
474 if [ -f /etc/environment -a -n \"$SSH_CLIENT\" \\
475 -a -z \"$LINUX_MODULE_DIRECTORY\" ]
478 export `cat /etc/environment | cut -d= -f1`
482 # Allow GStreamer-based applications to find plugins.
483 export GST_PLUGIN_PATH=\"$HOME/.guix-profile/lib/gstreamer-1.0\"
485 if [ -n \"$BASH_VERSION\" -a -f /etc/bashrc ]
487 # Load Bash-specific initialization code.
492 (bashrc (plain-file "bashrc" "\
493 # Bash-specific initialization.
495 # The 'bash-completion' package.
496 if [ -f /run/current-system/profile/etc/profile.d/bash_completion.sh ]
498 # Bash-completion sources ~/.bash_completion. It installs a dynamic
499 # completion loader that searches its own completion files as well
500 # as those in ~/.guix-profile and /run/current-system/profile.
501 source /run/current-system/profile/etc/profile.d/bash_completion.sh
504 `(("services" ,#~(string-append #$net-base "/etc/services"))
505 ("protocols" ,#~(string-append #$net-base "/etc/protocols"))
506 ("rpc" ,#~(string-append #$net-base "/etc/rpc"))
508 ("login.defs" ,#~#$login.defs)
510 ("nsswitch.conf" ,#~#$nsswitch)
511 ("profile" ,#~#$profile)
512 ("bashrc" ,#~#$bashrc)
513 ("hosts" ,#~#$(or (operating-system-hosts-file os)
514 (default-/etc/hosts (operating-system-host-name os))))
515 ("localtime" ,#~(string-append #$tzdata "/share/zoneinfo/"
516 #$(operating-system-timezone os)))
517 ("sudoers" ,(operating-system-sudoers-file os))))))
519 (define %root-account
520 ;; Default root account.
524 (uid 0) (group "root")
525 (comment "System administrator")
526 (home-directory "/root")))
528 (define (operating-system-accounts os)
529 "Return the user accounts for OS, including an obligatory 'root' account,
530 and excluding accounts requested by services."
531 ;; Make sure there's a root account.
532 (if (find (lambda (user)
533 (and=> (user-account-uid user) zero?))
534 (operating-system-users os))
535 (operating-system-users os)
536 (cons %root-account (operating-system-users os))))
538 (define (maybe-string->file file-name thing)
539 "If THING is a string, return a <plain-file> with THING as its content.
540 Otherwise just return THING.
542 This is for backward-compatibility of fields that used to be strings and are
543 now file-like objects.."
546 (warning (_ "using a string for file '~a' is deprecated; \
547 use 'plain-file' instead~%")
549 (plain-file file-name thing))
553 (define (maybe-file->monadic file-name thing)
554 "If THING is a value in %STORE-MONAD, return it as is; otherwise return
555 THING in the %STORE-MONAD.
557 This is for backward-compatibility of fields that used to be monadic values
558 and are now file-like objects."
559 (with-monad %store-monad
562 (warning (_ "using a monadic value for '~a' is deprecated; \
563 use 'plain-file' instead~%")
569 (define (operating-system-etc-directory os)
570 "Return that static part of the /etc directory of OS."
572 (fold-services (operating-system-services os)
573 #:target-type etc-service-type)))
575 (define (operating-system-environment-variables os)
576 "Return the environment variables of OS for
577 @var{session-environment-service-type}, to be used in @file{/etc/environment}."
578 `(("LANG" . ,(operating-system-locale os))
579 ("TZ" . ,(operating-system-timezone os))
580 ("TZDIR" . ,#~(string-append #$tzdata "/share/zoneinfo"))
581 ;; Tell 'modprobe' & co. where to look for modules.
582 ("LINUX_MODULE_DIRECTORY" . "/run/booted-system/kernel/lib/modules")
583 ;; These variables are honored by OpenSSL (libssl) and Git.
584 ("SSL_CERT_DIR" . "/etc/ssl/certs")
585 ("SSL_CERT_FILE" . "/etc/ssl/certs/ca-certificates.crt")
586 ("GIT_SSL_CAINFO" . "/etc/ssl/certs/ca-certificates.crt")
587 ;; Prepend the directory of 'site-start.el' to the search path, so
588 ;; that it has higher precedence than the 'site-start.el' file our
589 ;; Emacs package provides.
590 ("EMACSLOADPATH" . "/etc/emacs:")
591 ;; By default, applications that use D-Bus, such as Emacs, abort at startup
592 ;; when /etc/machine-id is missing. Make sure these warnings are non-fatal.
593 ("DBUS_FATAL_WARNINGS" . "0")))
595 (define %setuid-programs
596 ;; Default set of setuid-root programs.
597 (let ((shadow (@ (gnu packages admin) shadow)))
598 (list #~(string-append #$shadow "/bin/passwd")
599 #~(string-append #$shadow "/bin/su")
600 #~(string-append #$inetutils "/bin/ping")
601 #~(string-append #$inetutils "/bin/ping6")
602 #~(string-append #$sudo "/bin/sudo")
603 #~(string-append #$fuse "/bin/fusermount"))))
605 (define %sudoers-specification
606 ;; Default /etc/sudoers contents: 'root' and all members of the 'wheel'
607 ;; group can do anything. See
608 ;; <http://www.sudo.ws/sudo/man/1.8.10/sudoers.man.html>.
609 ;; TODO: Add a declarative API.
610 (plain-file "sudoers" "\
612 %wheel ALL=(ALL) ALL\n"))
614 (define* (operating-system-activation-script os #:key container?)
615 "Return the activation script for OS---i.e., the code that \"activates\" the
616 stateful part of OS, including user accounts and groups, special directories,
618 (let* ((services (operating-system-services os #:container? container?))
619 (activation (fold-services services
620 #:target-type activation-service-type)))
621 (activation-service->script activation)))
623 (define* (operating-system-boot-script os #:key container?)
624 "Return the boot script for OS---i.e., the code started by the initrd once
625 we're running in the final root. When CONTAINER? is true, skip all
626 hardware-related operations as necessary when booting a Linux container."
627 (let* ((services (operating-system-services os #:container? container?))
628 (boot (fold-services services #:target-type boot-service-type)))
629 ;; BOOT is the script as a monadic value.
630 (service-parameters boot)))
632 (define* (operating-system-derivation os #:key container?)
633 "Return a derivation that builds OS."
634 (let* ((services (operating-system-services os #:container? container?))
635 (system (fold-services services)))
636 ;; SYSTEM contains the derivation as a monadic value.
637 (service-parameters system)))
639 (define* (operating-system-profile os #:key container?)
640 "Return a derivation that builds the system profile of OS."
642 ((services -> (operating-system-services os #:container? container?))
643 (profile (fold-services services
644 #:target-type profile-service-type)))
649 (define (operating-system-root-file-system os)
650 "Return the root file system of OS."
652 (($ <file-system> _ _ "/") #t)
654 (operating-system-file-systems os)))
656 (define (operating-system-initrd-file os)
657 "Return a gexp denoting the initrd file of OS."
658 (define boot-file-systems
659 (filter file-system-needed-for-boot?
660 (operating-system-file-systems os)))
662 (define mapped-devices
663 (operating-system-boot-mapped-devices os))
666 (operating-system-initrd os))
668 (mlet %store-monad ((initrd (make-initrd boot-file-systems
669 #:linux (operating-system-kernel os)
670 #:mapped-devices mapped-devices)))
671 (return #~(string-append #$initrd "/initrd"))))
673 (define (locale-name->definition* name)
674 "Variant of 'locale-name->definition' that raises an error upon failure."
675 (match (locale-name->definition name)
679 (message (format #f (_ "~a: invalid locale name") name))))))
682 (define (operating-system-locale-directory os)
683 "Return the directory containing the locales compiled for the definitions
684 listed in OS. The C library expects to find it under
685 /run/current-system/locale."
687 (operating-system-locale os))
690 ;; While we're at it, check whether NAME is defined and add it if needed.
691 (if (member name (map locale-definition-name
692 (operating-system-locale-definitions os)))
693 (operating-system-locale-definitions os)
694 (cons (locale-name->definition* name)
695 (operating-system-locale-definitions os))))
697 (locale-directory definitions
698 #:libcs (operating-system-locale-libcs os)))
700 (define (kernel->grub-label kernel)
701 "Return a label for the GRUB menu entry that boots KERNEL."
702 (string-append "GNU with "
703 (string-titlecase (package-name kernel)) " "
704 (package-version kernel)
707 (define (store-file-system file-systems)
708 "Return the file system object among FILE-SYSTEMS that contains the store."
709 (match (filter (lambda (fs)
710 (and (file-system-mount? fs)
711 (not (memq 'bind-mount (file-system-flags fs)))
712 (string-prefix? (file-system-mount-point fs)
715 ((and candidates (head . tail))
716 (reduce (lambda (fs1 fs2)
717 (if (> (string-length (file-system-mount-point fs1))
718 (string-length (file-system-mount-point fs2)))
724 (define (operating-system-store-file-system os)
725 "Return the file system that contains the store of OS."
726 (store-file-system (operating-system-file-systems os)))
728 (define* (operating-system-grub.cfg os #:optional (old-entries '()))
729 "Return the GRUB configuration file for OS. Use OLD-ENTRIES to populate the
730 \"old entries\" menu."
732 ((system (operating-system-derivation os))
733 (root-fs -> (operating-system-root-file-system os))
734 (store-fs -> (operating-system-store-file-system os))
735 (kernel -> (operating-system-kernel os))
736 (root-device -> (if (eq? 'uuid (file-system-title root-fs))
737 (uuid->string (file-system-device root-fs))
738 (file-system-device root-fs)))
739 (entries -> (list (menu-entry
740 (label (kernel->grub-label kernel))
743 (cons* (string-append "--root=" root-device)
744 #~(string-append "--system=" #$system)
745 #~(string-append "--load=" #$system
747 (operating-system-kernel-arguments os)))
748 (initrd #~(string-append #$system "/initrd"))))))
749 (grub-configuration-file (operating-system-bootloader os)
751 #:old-entries old-entries)))
753 (define (operating-system-parameters-file os)
754 "Return a file that describes the boot parameters of OS. The primary use of
755 this file is the reconstruction of GRUB menu entries for old configurations."
756 (mlet %store-monad ((initrd (operating-system-initrd-file os))
757 (root -> (operating-system-root-file-system os))
758 (label -> (kernel->grub-label
759 (operating-system-kernel os))))
760 (gexp->file "parameters"
761 #~(boot-parameters (version 0)
763 (root-device #$(file-system-device root))
764 (kernel #$(operating-system-kernel os))
766 #$(operating-system-kernel-arguments os))
767 (initrd #$initrd)))))
774 (define-record-type* <boot-parameters>
775 boot-parameters make-boot-parameters boot-parameters?
776 (label boot-parameters-label)
777 (root-device boot-parameters-root-device)
778 (kernel boot-parameters-kernel)
779 (kernel-arguments boot-parameters-kernel-arguments))
781 (define (read-boot-parameters port)
782 "Read boot parameters from PORT and return the corresponding
783 <boot-parameters> object or #f if the format is unrecognized."
785 (('boot-parameters ('version 0)
786 ('label label) ('root-device root)
794 (match (assq 'kernel-arguments rest)
796 (#f '()))))) ;the old format
797 (x ;unsupported format
798 (warning (_ "unrecognized boot parameters for '~a'~%")
802 ;;; system.scm ends here