X-Git-Url: https://git.hcoop.net/jackhill/guix/guix.git/blobdiff_plain/0d6f84aab1c2f4cd8ce1b68215a7a77426dc6cd5..7e93817dfb021ab0bf881bacc5e028e2becbc6da:/gnu/system.scm diff --git a/gnu/system.scm b/gnu/system.scm index c53bccf82c..abdbb081e6 100644 --- a/gnu/system.scm +++ b/gnu/system.scm @@ -1,9 +1,10 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018 Ludovic Courtès +;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018, 2019 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 ;;; ;;; This file is part of GNU Guix. ;;; @@ -21,6 +22,7 @@ ;;; along with GNU Guix. If not, see . (define-module (gnu system) + #:use-module (guix inferior) #:use-module (guix store) #:use-module (guix monads) #:use-module (guix gexp) @@ -32,6 +34,7 @@ #:use-module (gnu packages base) #:use-module (gnu packages bash) #:use-module (gnu packages guile) + #:use-module (gnu packages guile-xyz) #:use-module (gnu packages admin) #:use-module (gnu packages linux) #:use-module (gnu packages pciutils) @@ -64,9 +67,12 @@ #:use-module (rnrs bytevectors) #:export (operating-system operating-system? + this-operating-system operating-system-bootloader operating-system-services + operating-system-essential-services + operating-system-default-essential-services operating-system-user-services operating-system-packages operating-system-host-name @@ -74,6 +80,8 @@ operating-system-kernel operating-system-kernel-file operating-system-kernel-arguments + operating-system-label + operating-system-default-label operating-system-initrd-modules operating-system-initrd operating-system-users @@ -101,12 +109,15 @@ operating-system-boot-script system-linux-image-file-name + operating-system-with-gc-roots + operating-system-with-provenance boot-parameters boot-parameters? boot-parameters-label boot-parameters-root-device boot-parameters-bootloader-name + boot-parameters-bootloader-menu-entries boot-parameters-store-device boot-parameters-store-mount-point boot-parameters-kernel @@ -117,6 +128,7 @@ boot-parameters->menu-entry local-host-aliases + %root-account %setuid-programs %base-packages %base-firmware)) @@ -127,36 +139,41 @@ ;;; ;;; Code: -(define (bootable-kernel-arguments kernel-arguments system.drv root-device) - "Prepend extra arguments to KERNEL-ARGUMENTS that allow SYSTEM.DRV to be -booted from ROOT-DEVICE" - (cons* (string-append "--root=" - (cond ((uuid? root-device) - - ;; Note: Always use the DCE format because that's - ;; what (gnu build linux-boot) expects for the - ;; '--root' kernel command-line option. - (uuid->string (uuid-bytevector root-device) - 'dce)) - ((file-system-label? root-device) - (file-system-label->string root-device)) - (else root-device))) - #~(string-append "--system=" #$system.drv) - #~(string-append "--load=" #$system.drv "/boot") - kernel-arguments)) +(define (bootable-kernel-arguments system root-device) + "Return a list of kernel arguments (gexps) to boot SYSTEM from ROOT-DEVICE." + (list (string-append "--root=" + (cond ((uuid? root-device) + + ;; Note: Always use the DCE format because that's + ;; what (gnu build linux-boot) expects for the + ;; '--root' kernel command-line option. + (uuid->string (uuid-bytevector root-device) + 'dce)) + ((file-system-label? root-device) + (file-system-label->string root-device)) + (else root-device))) + #~(string-append "--system=" #$system) + #~(string-append "--load=" #$system "/boot"))) ;; System-wide configuration. ;; TODO: Add per-field docstrings/stexi. (define-record-type* operating-system make-operating-system operating-system? + this-operating-system + (kernel operating-system-kernel ; package (default linux-libre)) (kernel-arguments operating-system-user-kernel-arguments - (default '())) ; list of gexps/strings + (default '("quiet"))) ; list of gexps/strings (bootloader operating-system-bootloader) ; + (label operating-system-label ; string + (thunked) + (default (operating-system-default-label this-operating-system))) - (initrd operating-system-initrd ; (list fs) -> M derivation + (keyboard-layout operating-system-keyboard-layout ;#f | + (default #f)) + (initrd operating-system-initrd ; (list fs) -> file-like (default base-initrd)) (initrd-modules operating-system-initrd-modules ; list of strings (thunked) ; it's system-dependent @@ -180,7 +197,7 @@ booted from ROOT-DEVICE" (groups operating-system-groups ; list of user groups (default %base-groups)) - (skeletons operating-system-skeletons ; list of name/monadic value + (skeletons operating-system-skeletons ; list of name/file-like value (default (default-skeletons))) (issue operating-system-issue ; string (default %default-issue)) @@ -198,7 +215,11 @@ booted from ROOT-DEVICE" (name-service-switch operating-system-name-service-switch ; (default %default-nss)) - (services operating-system-user-services ; list of monadic services + (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 (default %base-services)) (pam-services operating-system-pam-services ; list of PAM services @@ -209,12 +230,11 @@ booted from ROOT-DEVICE" (sudoers-file operating-system-sudoers-file ; file-like (default %sudoers-specification))) -(define (operating-system-kernel-arguments os system.drv root-device) +(define (operating-system-kernel-arguments os root-device) "Return all the kernel arguments, including the ones not specified directly by the user." - (bootable-kernel-arguments (operating-system-user-kernel-arguments os) - system.drv - root-device)) + (append (bootable-kernel-arguments os root-device) + (operating-system-user-kernel-arguments os))) ;;; @@ -233,6 +253,8 @@ directly by the user." ;; OS's root file system, so it might be a device path like "/dev/sda3". (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) (kernel boot-parameters-kernel) @@ -279,6 +301,11 @@ file system labels." ((_ 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 the kernel instead ;; of the absolute file name of its image. Detect that and correct it. (kernel (if (string=? linux (direct-store-path linux)) @@ -317,8 +344,8 @@ file system labels." (_ ;the old format "/"))))) (x ;unsupported format - (warning (G_ "unrecognized boot parameters for '~a'~%") - system) + (warning (G_ "unrecognized boot parameters at '~a'~%") + (port-filename port)) #f))) (define (read-boot-parameters-file system) @@ -328,14 +355,11 @@ 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)) - (kernel-arguments (boot-parameters-kernel-arguments params))) - (if params - (boot-parameters - (inherit params) - (kernel-arguments (bootable-kernel-arguments kernel-arguments - system root))) - #f))) + (root (boot-parameters-root-device params))) + (boot-parameters + (inherit params) + (kernel-arguments (append (bootable-kernel-arguments system root) + (boot-parameters-kernel-arguments params)))))) (define (boot-parameters->menu-entry conf) (menu-entry @@ -359,6 +383,9 @@ marked as 'needed-for-boot'." (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 @@ -374,21 +401,23 @@ marked as 'needed-for-boot'." (file-system (inherit fs) (dependencies - (delete-duplicates (append (device-mappings fs) - (file-system-dependencies fs)) - eq?)))) + (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 (mapped-device-user device file-systems) - "Return a file system among FILE-SYSTEMS that uses DEVICE, or #f." +(define (mapped-device-users device file-systems) + "Return the subset of FILE-SYSTEMS that use DEVICE." (let ((target (string-append "/dev/mapper/" (mapped-device-target device)))) - (find (lambda (fs) - (or (member device (file-system-dependencies fs)) - (and (string? (file-system-device fs)) - (string=? (file-system-device fs) target)))) - file-systems))) + (filter (lambda (fs) + (or (member device (file-system-dependencies fs)) + (and (string? (file-system-device fs)) + (string=? (file-system-device fs) target)))) + file-systems))) (define (operating-system-user-mapped-devices os) "Return the subset of mapped devices that can be installed in @@ -396,9 +425,8 @@ 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 ((user (mapped-device-user md file-systems))) - (or (not user) - (not (file-system-needed-for-boot? user))))) + (let ((users (mapped-device-users md file-systems))) + (not (any file-system-needed-for-boot? users)))) devices))) (define (operating-system-boot-mapped-devices os) @@ -407,8 +435,8 @@ from the initrd." (let ((devices (operating-system-mapped-devices os)) (file-systems (operating-system-file-systems os))) (filter (lambda (md) - (let ((user (mapped-device-user md file-systems))) - (and user (file-system-needed-for-boot? user)))) + (let ((users (mapped-device-users md file-systems))) + (any file-system-needed-for-boot? users))) devices))) (define (device-mapping-services os) @@ -420,42 +448,38 @@ from the initrd." "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))) +(define* (system-linux-image-file-name) "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"))) + (let ((target (or (%current-target-system) (%current-system)))) + (cond + ((string-prefix? "arm" target) "zImage") + ((string-prefix? "mips" target) "vmlinuz") + ((string-prefix? "aarch64" target) "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))) + "/" (system-linux-image-file-name))) -(define* (operating-system-directory-base-entries os #:key container?) +(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))) - (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?) + (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 (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. CONTAINER? determines whether to return the list of services for -a container or that of a \"bare metal\" system." +bookkeeping." (define known-fs (map file-system-mount-point (operating-system-file-systems os))) @@ -465,25 +489,26 @@ a container or that of a \"bare metal\" system." (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?))) + (entries (operating-system-directory-base-entries os))) (cons* (service system-service-type entries) %boot-service - ;; %SHEPHERD-ROOT-SERVICE must come first so that the gexp that + ;; %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 last so that its gexp runs before + ;; the cleanup service must come first so that its gexp runs before ;; activation code. - %shepherd-root-service - %activation-service (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 '()) + (service fstab-service-type + (filter file-system-needed-for-boot? + (operating-system-file-systems os))) (session-environment-service (operating-system-environment-variables os)) host-name procs root-fs @@ -494,20 +519,36 @@ a container or that of a \"bare metal\" system." other-fs (append mappings swaps - ;; Add the firmware service, unless we are building for a - ;; container. - (if container? - '() - (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." + ;; Add the firmware service. + (list %linux-bare-metal-service + (service firmware-service-type + (operating-system-firmware os))))))) + +(define* (operating-system-services os) + "Return all the services of OS, including \"essential\" services." (instantiate-missing-services (append (operating-system-user-services os) - (essential-services os #:container? container?)))) + (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-with-provenance os #:optional config-file) + "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))))) ;;; @@ -555,6 +596,7 @@ explicitly appear in OS." ;; variant propagated by 'guile-final' and the GMP variant propagated ;; by 'gnutls', itself propagated by 'guix'. guile-2.2 + guile-readline guile-colorized ;; The packages below are also in %FINAL-INPUTS, so take them from ;; there to avoid duplication. @@ -616,9 +658,6 @@ unset PATH GUIX_PROFILE=/run/current-system/profile ; \\ . /run/current-system/profile/etc/profile -# Prepend setuid programs. -export PATH=/run/setuid-programs:$PATH - # 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 @@ -630,16 +669,26 @@ then export `cat /etc/environment | cut -d= -f1` fi -if [ -f \"$HOME/.guix-profile/etc/profile\" ] -then - # Load the user profile's settings. - GUIX_PROFILE=\"$HOME/.guix-profile\" ; \\ - . \"$HOME/.guix-profile/etc/profile\" -else - # At least define this one so that basic things just work - # when the user installs their first package. - export PATH=\"$HOME/.guix-profile/bin:$PATH\" -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 . @@ -686,6 +735,10 @@ fi\n"))) ;; 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 + ("timezone" ,(plain-file "timezone" (operating-system-timezone os))) ("localtime" ,(file-append tzdata "/share/zoneinfo/" (operating-system-timezone os))) ("sudoers" ,(operating-system-sudoers-file os)))))) @@ -786,7 +839,13 @@ use 'plain-file' instead~%") (file-append inetutils "/bin/ping") (file-append inetutils "/bin/ping6") (file-append sudo "/bin/sudo") - (file-append fuse "/bin/fusermount")))) + (file-append sudo "/bin/sudoedit") + (file-append fuse "/bin/fusermount") + + ;; 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' @@ -797,22 +856,20 @@ use 'plain-file' instead~%") root ALL=(ALL) ALL %wheel ALL=(ALL) ALL\n")) -(define* (operating-system-activation-script os #:key container?) +(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 #:container? container?)) + (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 #:key container?) +(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. When CONTAINER? is true, skip all -hardware-related operations as necessary when booting a Linux container." - (let* ((services (operating-system-services os #:container? container?)) +we're running in the final root." + (let* ((services (operating-system-services os)) (boot (fold-services services #:target-type boot-service-type))) - ;; BOOT is the script as a monadic value. (service-value boot))) (define (operating-system-user-accounts os) @@ -831,17 +888,17 @@ hardware-related operations as necessary when booting a Linux container." #:target-type shepherd-root-service-type)))) -(define* (operating-system-derivation os #:key container?) +(define* (operating-system-derivation os) "Return a derivation that builds OS." - (let* ((services (operating-system-services os #:container? container?)) + (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 #:key container?) +(define* (operating-system-profile os) "Return a derivation that builds the system profile of OS." (mlet* %store-monad - ((services -> (operating-system-services os #:container? container?)) + ((services -> (operating-system-services os)) (profile (fold-services services #:target-type profile-service-type))) (match profile @@ -866,12 +923,12 @@ hardware-related operations as necessary when booting a Linux container." (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")))) + (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 (locale-name->definition* name) "Variant of 'locale-name->definition' that raises an error upon failure." @@ -902,10 +959,20 @@ listed in OS. The C library expects to find it under (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)")) + (cond ((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))) (define (store-file-system file-systems) "Return the file system object among FILE-SYSTEMS that contains the store." @@ -929,42 +996,47 @@ listed in OS. The C library expects to find it under (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)))))) + "Return the bootloader configuration file for OS. Use OLD-ENTRIES, +a list of , to populate the \"old entries\" menu." + (let* ((root-fs (operating-system-root-file-system os)) + (root-device (file-system-device root-fs)) + (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))) + +(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 kernel arguments +such as '--root' and '--load' to ." + (let* ((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 (operating-system-label 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) + (bootloader-name bootloader-name) + (bootloader-menu-entries + (bootloader-configuration-menu-entries (operating-system-bootloader os))) + (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.)" @@ -976,19 +1048,22 @@ kernel arguments for that derivation to ." (_ device))) -(define* (operating-system-boot-parameters-file os #:optional (system.drv #f)) +(define* (operating-system-boot-parameters-file os + #:key system-kernel-arguments?) "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 + +When SYSTEM-KERNEL-ARGUMENTS? is true, add kernel arguments such as '--root' +and '--load' 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))) + (let* ((root (operating-system-root-file-system os)) + (device (file-system-device root)) + (params (operating-system-boot-parameters + os device + #:system-kernel-arguments? + system-kernel-arguments?))) (gexp->file "parameters" #~(boot-parameters (version 0) @@ -1001,6 +1076,11 @@ being stored into the \"parameters\" file)." #$(boot-parameters-kernel-arguments params)) (initrd #$(boot-parameters-initrd 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) + '()))) (store (device #$(device->sexp (boot-parameters-store-device params)))