summaryrefslogtreecommitdiff
path: root/gnu/bootloader
diff options
context:
space:
mode:
Diffstat (limited to 'gnu/bootloader')
-rw-r--r--gnu/bootloader/extlinux.scm3
-rw-r--r--gnu/bootloader/grub.scm77
2 files changed, 32 insertions, 48 deletions
diff --git a/gnu/bootloader/extlinux.scm b/gnu/bootloader/extlinux.scm
index 67b8815d406..0a1263aed72 100644
--- a/gnu/bootloader/extlinux.scm
+++ b/gnu/bootloader/extlinux.scm
@@ -37,7 +37,8 @@
37corresponding to old generations of the system." 37corresponding to old generations of the system."
38 38
39 (define all-entries 39 (define all-entries
40 (append entries (bootloader-configuration-menu-entries config))) 40 (append entries (map menu-entry->boot-parameters
41 (bootloader-configuration-menu-entries config))))
41 42
42 (define (boot-parameters->gexp params) 43 (define (boot-parameters->gexp params)
43 (let ((label (boot-parameters-label params)) 44 (let ((label (boot-parameters-label params))
diff --git a/gnu/bootloader/grub.scm b/gnu/bootloader/grub.scm
index 49616b71642..f1cc3324db9 100644
--- a/gnu/bootloader/grub.scm
+++ b/gnu/bootloader/grub.scm
@@ -66,12 +66,15 @@
66(define (strip-mount-point mount-point file) 66(define (strip-mount-point mount-point file)
67 "Strip MOUNT-POINT from FILE, which is a gexp or other lowerable object 67 "Strip MOUNT-POINT from FILE, which is a gexp or other lowerable object
68denoting a file name." 68denoting a file name."
69 (if (string=? mount-point "/") 69 (match mount-point
70 file 70 ((? string? mount-point)
71 #~(let ((file #$file)) 71 (if (string=? mount-point "/")
72 (if (string-prefix? #$mount-point file) 72 file
73 (substring #$file #$(string-length mount-point)) 73 #~(let ((file #$file))
74 file)))) 74 (if (string-prefix? #$mount-point file)
75 (substring #$file #$(string-length mount-point))
76 file))))
77 (#f file)))
75 78
76(define-record-type* <grub-image> 79(define-record-type* <grub-image>
77 grub-image make-grub-image 80 grub-image make-grub-image
@@ -103,19 +106,6 @@ denoting a file name."
103 (color-highlight '((fg . yellow) (bg . black))) 106 (color-highlight '((fg . yellow) (bg . black)))
104 (color-normal '((fg . light-gray) (bg . black))))) ;XXX: #x303030 107 (color-normal '((fg . light-gray) (bg . black))))) ;XXX: #x303030
105 108
106(define-record-type* <menu-entry>
107 menu-entry make-menu-entry
108 menu-entry?
109 (label menu-entry-label)
110 (device menu-entry-device ; file system uuid, label, or #f
111 (default #f))
112 (device-mount-point menu-entry-device-mount-point
113 (default "/"))
114 (linux menu-entry-linux)
115 (linux-arguments menu-entry-linux-arguments
116 (default '())) ; list of string-valued gexps
117 (initrd menu-entry-initrd)) ; file name of the initrd as a gexp
118
119 109
120;;; 110;;;
121;;; Background image & themes. 111;;; Background image & themes.
@@ -312,16 +302,6 @@ code."
312 (#f 302 (#f
313 #~(format #f "search --file --set ~a" #$file))))) 303 #~(format #f "search --file --set ~a" #$file)))))
314 304
315(define (boot-parameters->menu-entry conf)
316 "Convert a <boot-parameters> instance to a corresponding <menu-entry>."
317 (menu-entry
318 (label (boot-parameters-label conf))
319 (device (boot-parameters-store-device conf))
320 (device-mount-point (boot-parameters-store-mount-point conf))
321 (linux (boot-parameters-kernel conf))
322 (linux-arguments (boot-parameters-kernel-arguments conf))
323 (initrd (boot-parameters-initrd conf))))
324
325(define* (grub-configuration-file config entries 305(define* (grub-configuration-file config entries
326 #:key 306 #:key
327 (system (%current-system)) 307 (system (%current-system))
@@ -331,33 +311,36 @@ code."
331STORE-FS, a <file-system> object. OLD-ENTRIES is taken to be a list of menu 311STORE-FS, a <file-system> object. OLD-ENTRIES is taken to be a list of menu
332entries corresponding to old generations of the system." 312entries corresponding to old generations of the system."
333 (define all-entries 313 (define all-entries
334 (map boot-parameters->menu-entry 314 (append entries (map menu-entry->boot-parameters
335 (append entries 315 (bootloader-configuration-menu-entries config))))
336 (bootloader-configuration-menu-entries config)))) 316
337 317 (define (boot-parameters->gexp params)
338 (define entry->gexp 318 (let ((device (boot-parameters-store-device params))
339 (match-lambda 319 (device-mount-point (boot-parameters-store-mount-point params))
340 (($ <menu-entry> label device device-mount-point 320 (label (boot-parameters-label params))
341 linux arguments initrd) 321 (kernel (boot-parameters-kernel params))
322 (arguments (boot-parameters-kernel-arguments params))
323 (initrd (boot-parameters-initrd params)))
342 ;; Here DEVICE is the store and DEVICE-MOUNT-POINT is its mount point. 324 ;; Here DEVICE is the store and DEVICE-MOUNT-POINT is its mount point.
343 ;; Use the right file names for LINUX and INITRD in case 325 ;; Use the right file names for KERNEL and INITRD in case
344 ;; DEVICE-MOUNT-POINT is not "/", meaning that the store is on a 326 ;; DEVICE-MOUNT-POINT is not "/", meaning that the store is on a
345 ;; separate partition. 327 ;; separate partition.
346 (let ((linux (strip-mount-point device-mount-point linux)) 328 (let ((kernel (strip-mount-point device-mount-point kernel))
347 (initrd (strip-mount-point device-mount-point initrd))) 329 (initrd (strip-mount-point device-mount-point initrd)))
348 #~(format port "menuentry ~s { 330 #~(format port "menuentry ~s {
349 ~a 331 ~a
350 linux ~a ~a 332 linux ~a ~a
351 initrd ~a 333 initrd ~a
352}~%" 334}~%"
353 #$label 335 #$label
354 #$(grub-root-search device linux) 336 #$(grub-root-search device kernel)
355 #$linux (string-join (list #$@arguments)) 337 #$kernel (string-join (list #$@arguments))
356 #$initrd))))) 338 #$initrd))))
357 339
358 (mlet %store-monad ((sugar (eye-candy config 340 (mlet %store-monad ((sugar (eye-candy config
359 (menu-entry-device (first all-entries)) 341 (boot-parameters-store-device
360 (menu-entry-device-mount-point 342 (first all-entries))
343 (boot-parameters-store-mount-point
361 (first all-entries)) 344 (first all-entries))
362 #:system system 345 #:system system
363 #:port #~port))) 346 #:port #~port)))
@@ -374,12 +357,12 @@ set default=~a
374set timeout=~a~%" 357set timeout=~a~%"
375 #$(bootloader-configuration-default-entry config) 358 #$(bootloader-configuration-default-entry config)
376 #$(bootloader-configuration-timeout config)) 359 #$(bootloader-configuration-timeout config))
377 #$@(map entry->gexp all-entries) 360 #$@(map boot-parameters->gexp all-entries)
378 361
379 #$@(if (pair? old-entries) 362 #$@(if (pair? old-entries)
380 #~((format port " 363 #~((format port "
381submenu \"GNU system, old configurations...\" {~%") 364submenu \"GNU system, old configurations...\" {~%")
382 #$@(map entry->gexp (map boot-parameters->menu-entry old-entries)) 365 #$@(map boot-parameters->gexp old-entries)
383 (format port "}~%")) 366 (format port "}~%"))
384 #~())))) 367 #~()))))
385 368