diff options
| -rw-r--r-- | gnu/bootloader.scm | 26 | ||||
| -rw-r--r-- | gnu/bootloader/extlinux.scm | 3 | ||||
| -rw-r--r-- | gnu/bootloader/grub.scm | 77 | ||||
| -rw-r--r-- | gnu/system.scm | 14 |
4 files changed, 71 insertions, 49 deletions
diff --git a/gnu/bootloader.scm b/gnu/bootloader.scm index 4e77974d31..d5fcf30f05 100644 --- a/gnu/bootloader.scm +++ b/gnu/bootloader.scm @@ -23,7 +23,15 @@ #:use-module (guix records) #:use-module (guix ui) #:use-module (srfi srfi-1) - #:export (bootloader + #:export (menu-entry + menu-entry? + menu-entry-label + menu-entry-device + menu-entry-linux + menu-entry-linux-arguments + menu-entry-initrd + + bootloader bootloader? bootloader-name bootloader-package @@ -50,6 +58,22 @@ ;;; +;;; 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)) + (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 + + +;;; ;;; Bootloader record. ;;; diff --git a/gnu/bootloader/extlinux.scm b/gnu/bootloader/extlinux.scm index 67b8815d40..0a1263aed7 100644 --- a/gnu/bootloader/extlinux.scm +++ b/gnu/bootloader/extlinux.scm @@ -37,7 +37,8 @@ corresponding to old generations of the system." (define all-entries - (append entries (bootloader-configuration-menu-entries config))) + (append entries (map menu-entry->boot-parameters + (bootloader-configuration-menu-entries config)))) (define (boot-parameters->gexp params) (let ((label (boot-parameters-label params)) diff --git a/gnu/bootloader/grub.scm b/gnu/bootloader/grub.scm index 49616b7164..f1cc3324db 100644 --- a/gnu/bootloader/grub.scm +++ b/gnu/bootloader/grub.scm @@ -66,12 +66,15 @@ (define (strip-mount-point mount-point file) "Strip MOUNT-POINT from FILE, which is a gexp or other lowerable object denoting a file name." - (if (string=? mount-point "/") - file - #~(let ((file #$file)) - (if (string-prefix? #$mount-point file) - (substring #$file #$(string-length mount-point)) - file)))) + (match mount-point + ((? string? mount-point) + (if (string=? mount-point "/") + file + #~(let ((file #$file)) + (if (string-prefix? #$mount-point file) + (substring #$file #$(string-length mount-point)) + file)))) + (#f file))) (define-record-type* <grub-image> grub-image make-grub-image @@ -103,19 +106,6 @@ denoting a file name." (color-highlight '((fg . yellow) (bg . black))) (color-normal '((fg . light-gray) (bg . black))))) ;XXX: #x303030 -(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 "/")) - (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 - ;;; ;;; Background image & themes. @@ -312,16 +302,6 @@ code." (#f #~(format #f "search --file --set ~a" #$file))))) -(define (boot-parameters->menu-entry conf) - "Convert a <boot-parameters> instance to a corresponding <menu-entry>." - (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)))) - (define* (grub-configuration-file config entries #:key (system (%current-system)) @@ -331,33 +311,36 @@ code." STORE-FS, a <file-system> object. OLD-ENTRIES is taken to be a list of menu entries corresponding to old generations of the system." (define all-entries - (map boot-parameters->menu-entry - (append entries - (bootloader-configuration-menu-entries config)))) - - (define entry->gexp - (match-lambda - (($ <menu-entry> label device device-mount-point - linux arguments initrd) + (append entries (map menu-entry->boot-parameters + (bootloader-configuration-menu-entries config)))) + + (define (boot-parameters->gexp params) + (let ((device (boot-parameters-store-device params)) + (device-mount-point (boot-parameters-store-mount-point params)) + (label (boot-parameters-label params)) + (kernel (boot-parameters-kernel params)) + (arguments (boot-parameters-kernel-arguments params)) + (initrd (boot-parameters-initrd params))) ;; Here DEVICE is the store and DEVICE-MOUNT-POINT is its mount point. - ;; Use the right file names for LINUX and INITRD in case + ;; Use the right file names for KERNEL and INITRD in case ;; DEVICE-MOUNT-POINT is not "/", meaning that the store is on a ;; separate partition. - (let ((linux (strip-mount-point device-mount-point linux)) - (initrd (strip-mount-point device-mount-point initrd))) + (let ((kernel (strip-mount-point device-mount-point kernel)) + (initrd (strip-mount-point device-mount-point initrd))) #~(format port "menuentry ~s { ~a linux ~a ~a initrd ~a }~%" #$label - #$(grub-root-search device linux) - #$linux (string-join (list #$@arguments)) - #$initrd))))) + #$(grub-root-search device kernel) + #$kernel (string-join (list #$@arguments)) + #$initrd)))) (mlet %store-monad ((sugar (eye-candy config - (menu-entry-device (first all-entries)) - (menu-entry-device-mount-point + (boot-parameters-store-device + (first all-entries)) + (boot-parameters-store-mount-point (first all-entries)) #:system system #:port #~port))) @@ -374,12 +357,12 @@ set default=~a set timeout=~a~%" #$(bootloader-configuration-default-entry config) #$(bootloader-configuration-timeout config)) - #$@(map entry->gexp all-entries) + #$@(map boot-parameters->gexp all-entries) #$@(if (pair? old-entries) #~((format port " submenu \"GNU system, old configurations...\" {~%") - #$@(map entry->gexp (map boot-parameters->menu-entry old-entries)) + #$@(map boot-parameters->gexp old-entries) (format port "}~%")) #~())))) diff --git a/gnu/system.scm b/gnu/system.scm index 0076f2fcb1..674c6f85be 100644 --- a/gnu/system.scm +++ b/gnu/system.scm @@ -112,6 +112,7 @@ boot-parameters-initrd read-boot-parameters read-boot-parameters-file + menu-entry->boot-parameters local-host-aliases %setuid-programs @@ -299,6 +300,19 @@ The object has its kernel-arguments extended in order to make it bootable." system root-device))) #f))) + +(define (menu-entry->boot-parameters menu-entry) + "Convert a <menu-entry> instance to a corresponding <boot-parameters>." + (boot-parameters + (label (menu-entry-label menu-entry)) + (root-device #f) + (boot-name 'custom) + (store-device #f) + (store-mount-point #f) + (kernel (menu-entry-linux menu-entry)) + (kernel-arguments (menu-entry-linux-arguments menu-entry)) + (initrd (menu-entry-initrd menu-entry)))) + ;;; ;;; Services. |