X-Git-Url: https://git.hcoop.net/jackhill/guix/guix.git/blobdiff_plain/154d97abdd16674fdebc763351f661bbcdc869a4..e6e076281e62518056987e9ddd3d96fccab20475:/gnu/system.scm diff --git a/gnu/system.scm b/gnu/system.scm index 96c2b5aad3..a56fdc6304 100644 --- a/gnu/system.scm +++ b/gnu/system.scm @@ -1,10 +1,16 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018, 2019 Ludovic Courtès +;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020 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 © 2020 Danny Milosavljevic +;;; Copyright © 2020 Brice Waegeneire +;;; Copyright © 2020 Florian Pelz +;;; Copyright © 2020 Maxim Cournoyer +;;; Copyright © 2020 Jan (janneke) Nieuwenhuizen +;;; Copyright © 2020 Efraim Flashner ;;; ;;; This file is part of GNU Guix. ;;; @@ -30,23 +36,30 @@ #:use-module (guix packages) #:use-module (guix derivations) #:use-module (guix profiles) - #:use-module (guix ui) + #:use-module ((guix utils) #:select (substitute-keyword-arguments)) + #:use-module (guix i18n) + #:use-module (guix diagnostics) + #:use-module (gnu packages admin) #:use-module (gnu packages base) #:use-module (gnu packages bash) + #:use-module (gnu packages compression) + #:use-module (gnu packages cross-base) + #:use-module (gnu packages cryptsetup) + #:use-module (gnu packages disk) + #:use-module (gnu packages file-systems) + #:use-module (gnu packages firmware) + #:use-module (gnu packages gawk) #: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) - #:use-module (gnu packages package-management) + #:use-module (gnu packages hurd) #:use-module (gnu packages less) - #:use-module (gnu packages zile) - #:use-module (gnu packages nano) - #:use-module (gnu packages gawk) + #:use-module (gnu packages linux) #:use-module (gnu packages man) + #:use-module (gnu packages nano) + #:use-module (gnu packages package-management) + #:use-module (gnu packages pciutils) #:use-module (gnu packages texinfo) - #:use-module (gnu packages compression) - #:use-module (gnu packages firmware) + #:use-module (gnu packages zile) #:use-module (gnu services) #:use-module (gnu services shepherd) #:use-module (gnu services base) @@ -77,6 +90,7 @@ operating-system-packages operating-system-host-name operating-system-hosts-file + operating-system-hurd operating-system-kernel operating-system-kernel-file operating-system-kernel-arguments @@ -100,6 +114,16 @@ operating-system-user-accounts operating-system-shepherd-service-names operating-system-user-kernel-arguments + operating-system-firmware + operating-system-keyboard-layout + operating-system-name-service-switch + operating-system-pam-services + operating-system-setuid-programs + operating-system-skeletons + operating-system-sudoers-file + operating-system-swap-devices + operating-system-kernel-loadable-modules + operating-system-location operating-system-derivation operating-system-profile @@ -107,9 +131,13 @@ operating-system-etc-directory operating-system-locale-directory operating-system-boot-script + operating-system-uuid system-linux-image-file-name operating-system-with-gc-roots + operating-system-with-provenance + + hurd-default-essential-services boot-parameters boot-parameters? @@ -122,6 +150,7 @@ boot-parameters-kernel boot-parameters-kernel-arguments boot-parameters-initrd + boot-parameters-multiboot-modules read-boot-parameters read-boot-parameters-file boot-parameters->menu-entry @@ -129,8 +158,15 @@ local-host-aliases %root-account %setuid-programs + %sudoers-specification %base-packages - %base-firmware)) + %base-packages-interactive + %base-packages-linux + %base-packages-networking + %base-packages-disk-utilities + %base-packages-utils + %base-firmware + %default-kernel-arguments)) ;;; Commentary: ;;; @@ -141,16 +177,11 @@ (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))) + ;; Note: Always use the DCE format because that's what + ;; (gnu build linux-boot) expects for the '--root' + ;; kernel command-line option. + (file-system-device->string root-device + #:uuid-type 'dce)) #~(string-append "--system=" #$system) #~(string-append "--load=" #$system "/boot"))) @@ -163,8 +194,12 @@ (kernel operating-system-kernel ; package (default linux-libre)) + (kernel-loadable-modules operating-system-kernel-loadable-modules + (default '())) ; list of packages (kernel-arguments operating-system-user-kernel-arguments - (default '("quiet"))) ; list of gexps/strings + (default %default-kernel-arguments)) ; list of gexps/strings + (hurd operating-system-hurd + (default #f)) ; package (bootloader operating-system-bootloader) ; (label operating-system-label ; string (thunked) @@ -227,7 +262,12 @@ (default %setuid-programs)) ; list of string-valued gexps (sudoers-file operating-system-sudoers-file ; file-like - (default %sudoers-specification))) + (default %sudoers-specification)) + + (location operating-system-location ; + (default (and=> (current-source-location) + source-properties->location)) + (innate))) (define (operating-system-kernel-arguments os root-device) "Return all the kernel arguments, including the ones not specified @@ -258,7 +298,8 @@ directly by the user." (store-mount-point boot-parameters-store-mount-point) (kernel boot-parameters-kernel) (kernel-arguments boot-parameters-kernel-arguments) - (initrd boot-parameters-initrd)) + (initrd boot-parameters-initrd) + (multiboot-modules boot-parameters-multiboot-modules)) (define (ensure-not-/dev device) "If DEVICE starts with a slash, return #f. This is meant to filter out @@ -280,16 +321,18 @@ file system labels." ((? bytevector? bv) ;old format (bytevector->uuid bv 'dce)) ((? string? device) - ;; It used to be that we would not distinguish between labels and - ;; device names. Try to infer the right thing here. - (if (string-prefix? "/dev/" device) - device - (file-system-label 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)))))) (match (read port) (('boot-parameters ('version 0) ('label label) ('root-device root) - ('kernel linux) + ('kernel kernel) rest ...) (boot-parameters (label label) @@ -305,12 +348,12 @@ file system labels." ((_ 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)) - (string-append linux "/" + ;; 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)) - linux)) + kernel)) (kernel-arguments (match (assq 'kernel-arguments rest) @@ -322,7 +365,13 @@ file system labels." (('initrd ('string-append directory file)) ;the old format (string-append directory file)) (('initrd (? string? file)) - file))) + file) + (#f #f))) + + (multiboot-modules + (match (assq 'multiboot-modules rest) + ((_ args) args) + (#f '()))) (store-device ;; Linux device names like "/dev/sda1" are not suitable GRUB device @@ -361,14 +410,25 @@ The object has its kernel-arguments extended in order to make it bootable." (boot-parameters-kernel-arguments params)))))) (define (boot-parameters->menu-entry conf) - (menu-entry - (label (boot-parameters-label conf)) - (device (boot-parameters-store-device conf)) - (device-mount-point (boot-parameters-store-mount-point conf)) - (linux (boot-parameters-kernel conf)) - (linux-arguments (boot-parameters-kernel-arguments conf)) - (initrd (boot-parameters-initrd conf)))) - + (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) + '()))))) ;;; @@ -447,33 +507,71 @@ 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) - "Return the basename of the kernel image file for SYSTEM." - ;; FIXME: Evaluate the conditional based on the actual current system. - (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* (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") + (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))) + (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 (package-for-kernel target-kernel module-package) + "Return a package like MODULE-PACKAGE, adapted for TARGET-KERNEL, if +possible (that is if there's a LINUX keyword argument in the build system)." + (package + (inherit module-package) + (arguments + (substitute-keyword-arguments (package-arguments module-package) + ((#:linux kernel #f) + target-kernel))))) + +(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))) - (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 + (let* ((locale (operating-system-locale-directory os)) + (kernel (operating-system-kernel os)) + (hurd (operating-system-hurd os)) + (modules (operating-system-kernel-loadable-modules os)) + (kernel (if hurd + kernel + (profile + (content (packages->manifest + (cons kernel + (map (lambda (module) + (if (package? module) + (package-for-kernel kernel + module) + module)) + modules)))) + (hooks (list linux-module-database))))) + (initrd (and (not hurd) (operating-system-initrd-file os))) + (params (operating-system-boot-parameters-file os))) + `(("kernel" ,kernel) + ,@(if hurd `(("hurd" ,hurd)) '()) + ("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 @@ -523,6 +621,28 @@ bookkeeping." (service firmware-service-type (operating-system-firmware os))))))) +(define (hurd-default-essential-services os) + (let ((entries (operating-system-directory-base-entries os))) + (list (service system-service-type entries) + %boot-service + %hurd-startup-service + %activation-service + %shepherd-root-service + (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) + (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 @@ -540,6 +660,28 @@ bookkeeping." 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. @@ -550,49 +692,68 @@ bookkeeping." (list ath9k-htc-firmware openfwwf-firmware)) +(define %base-packages-utils + ;; Default set of utilities packages. + (cons* procps psmisc which + (@ (gnu packages admin) shadow) ;for 'passwd' + + 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 zile nano + 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 + ;; 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 %base-packages-disk-utilities + ;; A well-rounded set of packages for interacting with disks, partitions + ;; and filesystems. + (list parted gptfdisk ddrescue + ;; We used to provide fdisk from GNU fdisk, but as of version 2.0.0a + ;; it pulls Guile 1.8, which takes unreasonable space; furthermore + ;; util-linux's fdisk is already available, in %base-packages-linux. + cryptsetup mdadm + dosfstools + btrfs-progs + f2fs-tools + jfsutils)) + (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 - guile-readline guile-colorized - - ;; 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)))) + (append (list e2fsprogs) + %base-packages-interactive + %base-packages-linux + %base-packages-networking + %base-packages-utils)) (define %default-issue ;; Default contents for /etc/issue. @@ -608,10 +769,22 @@ This is the GNU system. Welcome.\n") "Return the default /etc/hosts file." (plain-file "hosts" (local-host-aliases host-name))) +(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* (operating-system-etc-service os) "Return a that builds containing the static part of the /etc directory." - (let ((login.defs + (let* ((login.defs (plain-file "login.defs" (string-append "# Default paths for non-login shells started by su(1).\n" @@ -622,10 +795,13 @@ directory." "/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)))) + (hurd (operating-system-hurd os)) + (issue (plain-file "issue" (operating-system-issue os))) + (nsswitch (operating-system-name-service-switch os)) + (nsswitch (and nsswitch + (plain-file "nsswitch.conf" + (name-service-switch->string nsswitch)))) + (sudoers (operating-system-sudoers-file os)) ;; Startup file for POSIX-compliant login shells, which set system-wide ;; environment variables. @@ -715,7 +891,7 @@ fi\n"))) ("rpc" ,(file-append net-base "/etc/rpc")) ("login.defs" ,#~#$login.defs) ("issue" ,#~#$issue) - ("nsswitch.conf" ,#~#$nsswitch) + ,@(if nsswitch `(("nsswitch.conf" ,#~#$nsswitch)) '()) ("profile" ,#~#$profile) ("bashrc" ,#~#$bashrc) ("hosts" ,#~#$(or (operating-system-hosts-file os) @@ -731,7 +907,14 @@ fi\n"))) ("timezone" ,(plain-file "timezone" (operating-system-timezone os))) ("localtime" ,(file-append tzdata "/share/zoneinfo/" (operating-system-timezone os))) - ("sudoers" ,(operating-system-sudoers-file 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. @@ -823,7 +1006,9 @@ use 'plain-file' instead~%") ;; Default set of setuid-root programs. (let ((shadow (@ (gnu packages admin) shadow))) (list (file-append shadow "/bin/passwd") + (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") @@ -897,9 +1082,13 @@ we're running in the final root." (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))) + (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." @@ -920,13 +1109,60 @@ we're running in the final root." #: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 (condition - (&message - (message (format #f (G_ "~a: invalid locale name") name)))))) + (raise (formatted-message (G_ "~a: invalid locale name") name))) (def def))) (define (operating-system-locale-directory os) @@ -947,9 +1183,13 @@ listed in OS. The C library expects to find it under (locale-directory definitions #:libcs (operating-system-locale-libcs os))) -(define (kernel->boot-label kernel) +(define* (kernel->boot-label kernel #:key hurd) "Return a label for the bootloader menu entry that boots KERNEL." - (cond ((package? 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))) @@ -962,7 +1202,8 @@ listed in OS. The C library expects to find it under (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))) + (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." @@ -988,31 +1229,64 @@ entry." (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* ((root-fs (operating-system-root-file-system os)) + (let* ((file-systems (operating-system-file-systems os)) + (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))) + #:old-entries old-entries + #: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)) + (root-file-system-command + (list (file-append hurd "/hurd/ext2fs.static") + "ext2fs" + "--multiboot-command-line='${kernel-command-line}'" + "--host-priv-port='${host-port}'" + "--device-master-port='${device-port}'" + "--exec-server-task='${exec-task}'" + "--store-type=typed" + "--x-xattr-translator-records" + "'${root}'" "'$(task-create)'" "'$(task-resume)'")) + (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 + (list (file-append libc "/lib/ld.so.1") "exec" + (file-append hurd "/hurd/exec") "'$(exec-task=task-create)'"))) + (list 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 kernel arguments such as '--root' and '--load' to ." - (let* ((initrd (operating-system-initrd-file os)) + (let* ((initrd (and (not (operating-system-hurd os)) + (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))) + (label (operating-system-label os)) + (multiboot-modules (operating-system-multiboot-modules os))) (boot-parameters (label label) (root-device root-device) @@ -1022,6 +1296,7 @@ such as '--root' and '--load' to ." (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))) @@ -1054,28 +1329,35 @@ being stored into the \"parameters\" file)." os device #:system-kernel-arguments? system-kernel-arguments?))) - (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)) - (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))) - (mount-point #$(boot-parameters-store-mount-point params)))) - #:set-load-path? #f))) + (scheme-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)) + #$@(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) + '()))) + (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)