M gnu.scm => gnu.scm +3 -1
@@ 1,6 1,7 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2014, 2015, 2016 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2015 Joshua S. Grant <jgrant@parenthetical.io>
+;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com>
;;;
;;; This file is part of GNU Guix.
;;;
@@ 34,7 35,8 @@
'((gnu system)
(gnu system mapped-devices)
(gnu system file-systems)
- (gnu system grub) ; 'grub-configuration'
+ (gnu bootloader)
+ (gnu bootloader grub)
(gnu system pam)
(gnu system shadow) ; 'user-account'
(gnu system linux-initrd)
A gnu/bootloader.scm => gnu/bootloader.scm +127 -0
@@ 0,0 1,127 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2017 David Craven <david@craven.ch>
+;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com>
+;;; Copyright © 2017 Leo Famulari <leo@famulari.name>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Guix is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (gnu bootloader)
+ #:use-module (guix discovery)
+ #:use-module (guix records)
+ #:use-module (guix ui)
+ #:use-module (srfi srfi-1)
+ #:export (bootloader
+ bootloader?
+ bootloader-name
+ bootloader-package
+ bootloader-installer
+ bootloader-configuration-file
+ bootloader-configuration-file-generator
+
+ bootloader-configuration
+ bootloader-configuration?
+ bootloader-configuration-bootloader
+ bootloader-configuration-device
+ bootloader-configuration-menu-entries
+ bootloader-configuration-default-entry
+ bootloader-configuration-timeout
+ bootloader-configuration-theme
+ bootloader-configuration-terminal-outputs
+ bootloader-configuration-terminal-inputs
+ bootloader-configuration-serial-unit
+ bootloader-configuration-serial-speed
+ bootloader-configuration-additional-configuration
+
+ %bootloaders
+ lookup-bootloader-by-name))
+
+
+;;;
+;;; Bootloader record.
+;;;
+
+;; The <bootloader> record contains fields expressing how the bootloader
+;; should be installed. Every bootloader in gnu/bootloader/ directory
+;; has to be described by this record.
+
+(define-record-type* <bootloader>
+ bootloader make-bootloader
+ bootloader?
+ (name bootloader-name)
+ (package bootloader-package)
+ (installer bootloader-installer)
+ (configuration-file bootloader-configuration-file)
+ (configuration-file-generator bootloader-configuration-file-generator))
+
+
+;;;
+;;; Bootloader configuration record.
+;;;
+
+;; The <bootloader-configuration> record contains bootloader independant
+;; configuration used to fill bootloader configuration file.
+
+(define-record-type* <bootloader-configuration>
+ bootloader-configuration make-bootloader-configuration
+ bootloader-configuration?
+ (bootloader bootloader-configuration-bootloader) ; <bootloader>
+ (device bootloader-configuration-device ; string
+ (default #f))
+ (menu-entries bootloader-configuration-menu-entries ; list of <boot-parameters>
+ (default '()))
+ (default-entry bootloader-configuration-default-entry ; integer
+ (default 0))
+ (timeout bootloader-configuration-timeout ; seconds as integer
+ (default 5))
+ (theme bootloader-configuration-theme ; bootloader-specific theme
+ (default #f))
+ (terminal-outputs bootloader-configuration-terminal-outputs ; list of symbols
+ (default '(gfxterm)))
+ (terminal-inputs bootloader-configuration-terminal-inputs ; list of symbols
+ (default '()))
+ (serial-unit bootloader-configuration-serial-unit ; integer | #f
+ (default #f))
+ (serial-speed bootloader-configuration-serial-speed ; integer | #f
+ (default #f))
+ (additional-configuration bootloader-configuration-additional-configuration ; record
+ (default #f)))
+
+
+;;;
+;;; Bootloaders.
+;;;
+
+(define (bootloader-modules)
+ "Return the list of bootloader modules."
+ (all-modules (map (lambda (entry)
+ `(,entry . "gnu/bootloader"))
+ %load-path)))
+
+(define %bootloaders
+ ;; The list of publically-known bootloaders.
+ (delay (fold-module-public-variables (lambda (obj result)
+ (if (bootloader? obj)
+ (cons obj result)
+ result))
+ '()
+ (bootloader-modules))))
+
+(define (lookup-bootloader-by-name name)
+ "Return the bootloader called NAME."
+ (or (find (lambda (bootloader)
+ (eq? name (bootloader-name bootloader)))
+ (force %bootloaders))
+ (leave (G_ "~a: no such bootloader~%") name)))
A gnu/bootloader/extlinux.scm => gnu/bootloader/extlinux.scm +123 -0
@@ 0,0 1,123 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2017 David Craven <david@craven.ch>
+;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Guix is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (gnu bootloader extlinux)
+ #:use-module (gnu bootloader)
+ #:use-module (gnu system)
+ #:use-module (gnu packages bootloaders)
+ #:use-module (guix gexp)
+ #:use-module (guix monads)
+ #:use-module (guix records)
+ #:use-module (guix utils)
+ #:export (extlinux-bootloader
+ syslinux-bootloader
+
+ extlinux-configuration
+ syslinux-configuration))
+
+(define* (extlinux-configuration-file config entries
+ #:key
+ (system (%current-system))
+ (old-entries '()))
+ "Return the U-Boot configuration file corresponding to CONFIG, a
+<u-boot-configuration> object, and where the store is available at 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
+ (append entries (bootloader-configuration-menu-entries config)))
+
+ (define (boot-parameters->gexp params)
+ (let ((label (boot-parameters-label params))
+ (kernel (boot-parameters-kernel params))
+ (kernel-arguments (boot-parameters-kernel-arguments params))
+ (initrd (boot-parameters-initrd params)))
+ #~(format port "LABEL ~a
+ MENU LABEL ~a
+ KERNEL ~a
+ FDTDIR ~a/lib/dtbs
+ INITRD ~a
+ APPEND ~a
+~%"
+ #$label #$label
+ #$kernel #$kernel #$initrd
+ (string-join (list #$@kernel-arguments)))))
+
+ (define builder
+ #~(call-with-output-file #$output
+ (lambda (port)
+ (let ((timeout #$(bootloader-configuration-timeout config)))
+ (format port "
+UI menu.c32
+PROMPT ~a
+TIMEOUT ~a~%"
+ (if (> timeout 0) 1 0)
+ ;; timeout is expressed in 1/10s of seconds.
+ (* 10 timeout))
+ #$@(map boot-parameters->gexp all-entries)
+
+ #$@(if (pair? old-entries)
+ #~((format port "~%")
+ #$@(map boot-parameters->gexp old-entries)
+ (format port "~%"))
+ #~())))))
+
+ (gexp->derivation "extlinux.conf" builder))
+
+
+
+
+;;;
+;;; Install procedures.
+;;;
+
+(define dd
+ #~(lambda (bs count if of)
+ (zero? (system* "dd"
+ (string-append "bs=" (number->string bs))
+ (string-append "count=" (number->string count))
+ (string-append "if=" if)
+ (string-append "of=" of)))))
+
+(define install-extlinux
+ #~(lambda (bootloader device mount-point)
+ (let ((extlinux (string-append bootloader "/sbin/extlinux"))
+ (install-dir (string-append mount-point "/boot/extlinux"))
+ (syslinux-dir (string-append bootloader "/share/syslinux")))
+ (for-each (lambda (file)
+ (install-file file install-dir))
+ (find-files syslinux-dir "\\.c32$"))
+
+ (unless (and (zero? (system* extlinux "--install" install-dir))
+ (#$dd 440 1 (string-append syslinux-dir "/mbr.bin") device))
+ (error "failed to install SYSLINUX")))))
+
+
+
+;;;
+;;; Bootloader definitions.
+;;;
+
+(define extlinux-bootloader
+ (bootloader
+ (name 'extlinux)
+ (package syslinux)
+ (installer install-extlinux)
+ (configuration-file "/boot/extlinux/extlinux.conf")
+ (configuration-file-generator extlinux-configuration-file)))
R gnu/system/grub.scm => gnu/bootloader/grub.scm +89 -48
@@ 2,6 2,7 @@
;;; Copyright © 2013, 2014, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2016 Chris Marusich <cmmarusich@gmail.com>
;;; Copyright © 2017 Leo Famulari <leo@famulari.name>
+;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com>
;;;
;;; This file is part of GNU Guix.
;;;
@@ 18,7 19,7 @@
;;; You should have received a copy of the GNU General Public License
;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
-(define-module (gnu system grub)
+(define-module (gnu bootloader grub)
#:use-module (guix store)
#:use-module (guix packages)
#:use-module (guix derivations)
@@ 28,6 29,7 @@
#:use-module (guix download)
#:use-module (gnu artwork)
#:use-module (gnu system)
+ #:use-module (gnu bootloader)
#:use-module (gnu system file-systems)
#:autoload (gnu packages bootloaders) (grub)
#:autoload (gnu packages compression) (gzip)
@@ 50,15 52,10 @@
%background-image
%default-theme
- grub-configuration
- grub-configuration?
- grub-configuration-device
- grub-configuration-grub
+ grub-bootloader
+ grub-efi-bootloader
- menu-entry
- menu-entry?
-
- grub-configuration-file))
+ grub-configuration))
;;; Commentary:
;;;
@@ 106,29 103,6 @@ denoting a file name."
(color-highlight '((fg . yellow) (bg . black)))
(color-normal '((fg . light-gray) (bg . black))))) ;XXX: #x303030
-(define-record-type* <grub-configuration>
- grub-configuration make-grub-configuration
- grub-configuration?
- (grub grub-configuration-grub ; package
- (default (@ (gnu packages bootloaders) grub)))
- (device grub-configuration-device) ; string
- (menu-entries grub-configuration-menu-entries ; list
- (default '()))
- (default-entry grub-configuration-default-entry ; integer
- (default 0))
- (timeout grub-configuration-timeout ; integer
- (default 5))
- (theme grub-configuration-theme ; <grub-theme>
- (default %default-theme))
- (terminal-outputs grub-configuration-terminal-outputs ; list of symbols
- (default '(gfxterm)))
- (terminal-inputs grub-configuration-terminal-inputs ; list of symbols
- (default '()))
- (serial-unit grub-configuration-serial-unit ; integer | #f
- (default #f))
- (serial-speed grub-configuration-serial-speed ; integer | #f
- (default #f)))
-
(define-record-type* <menu-entry>
menu-entry make-menu-entry
menu-entry?
@@ 147,6 121,11 @@ denoting a file name."
;;; Background image & themes.
;;;
+(define (bootloader-theme config)
+ "Return user defined theme in CONFIG if defined or %default-theme
+otherwise."
+ (or (bootloader-configuration-theme config) %default-theme))
+
(define* (svg->png svg #:key width height)
"Build a PNG of HEIGHT x WIDTH from SVG."
(gexp->derivation "grub-image.png"
@@ 171,7 150,8 @@ WIDTH/HEIGHT, or #f if none was found."
(let* ((ratio (/ width height))
(image (find (lambda (image)
(= (grub-image-aspect-ratio image) ratio))
- (grub-theme-images (grub-configuration-theme config)))))
+ (grub-theme-images
+ (bootloader-theme config)))))
(if image
(svg->png (grub-image-file image)
#:width width #:height height)
@@ 212,14 192,14 @@ system string---e.g., \"x86_64-linux\"."
""))
(define (setup-gfxterm config font-file)
- (if (memq 'gfxterm (grub-configuration-terminal-outputs config))
- #~(format #f "if loadfont ~a; then
+ (if (memq 'gfxterm (bootloader-configuration-terminal-outputs config))
+ #~(format #f "if loadfont ~a; then
setup_gfxterm
fi~%" #$font-file)
- ""))
+ ""))
(define (theme-colors type)
- (let* ((theme (grub-configuration-theme config))
+ (let* ((theme (bootloader-theme config))
(colors (type theme)))
(string-append (symbol->string (assoc-ref colors 'fg)) "/"
(symbol->string (assoc-ref colors 'bg)))))
@@ 266,10 246,10 @@ fi~%"
is a string that can be inserted in grub.cfg."
(let* ((symbols->string (lambda (list)
(string-join (map symbol->string list) " ")))
- (outputs (grub-configuration-terminal-outputs config))
- (inputs (grub-configuration-terminal-inputs config))
- (unit (grub-configuration-serial-unit config))
- (speed (grub-configuration-serial-speed config))
+ (outputs (bootloader-configuration-terminal-outputs config))
+ (inputs (bootloader-configuration-terminal-inputs config))
+ (unit (bootloader-configuration-serial-unit config))
+ (speed (bootloader-configuration-serial-speed config))
;; Respectively, GRUB_TERMINAL_OUTPUT and GRUB_TERMINAL_INPUT,
;; as documented in GRUB manual section "Simple Configuration
@@ 347,12 327,13 @@ code."
(system (%current-system))
(old-entries '()))
"Return the GRUB configuration file corresponding to CONFIG, a
-<grub-configuration> object, and where the store is available at STORE-FS, a
-<file-system> object. OLD-ENTRIES is taken to be a list of menu entries
-corresponding to old generations of the system."
+<bootloader-configuration> object, and where the store is available at
+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
- (append (map boot-parameters->menu-entry entries)
- (grub-configuration-menu-entries config)))
+ (map boot-parameters->menu-entry
+ (append entries
+ (bootloader-configuration-menu-entries config))))
(define entry->gexp
(match-lambda
@@ 391,8 372,8 @@ corresponding to old generations of the system."
(format port "
set default=~a
set timeout=~a~%"
- #$(grub-configuration-default-entry config)
- #$(grub-configuration-timeout config))
+ #$(bootloader-configuration-default-entry config)
+ #$(bootloader-configuration-timeout config))
#$@(map entry->gexp all-entries)
#$@(if (pair? old-entries)
@@ 404,4 385,64 @@ submenu \"GNU system, old configurations...\" {~%")
(gexp->derivation "grub.cfg" builder)))
+
+
+;;;
+;;; Install procedures.
+;;;
+
+(define install-grub
+ #~(lambda (bootloader device mount-point)
+ ;; Install GRUB on DEVICE which is mounted at MOUNT-POINT.
+ (let ((grub (string-append bootloader "/sbin/grub-install"))
+ (install-dir (string-append mount-point "/boot")))
+ ;; Tell 'grub-install' that there might be a LUKS-encrypted /boot or
+ ;; root partition.
+ (setenv "GRUB_ENABLE_CRYPTODISK" "y")
+
+ (unless (zero? (system* grub "--no-floppy"
+ "--boot-directory" install-dir
+ device))
+ (error "failed to install GRUB")))))
+
+
+
+;;;
+;;; Bootloader definitions.
+;;;
+
+(define grub-bootloader
+ (bootloader
+ (name 'grub)
+ (package grub)
+ (installer install-grub)
+ (configuration-file "/boot/grub/grub.cfg")
+ (configuration-file-generator grub-configuration-file)))
+
+(define* grub-efi-bootloader
+ (bootloader
+ (inherit grub-bootloader)
+ (name 'grub-efi)
+ (package grub-efi)))
+
+
+;;;
+;;; Compatibility macros.
+;;;
+
+(define-syntax grub-configuration
+ (syntax-rules (grub)
+ ((_ (grub package) fields ...)
+ (if (eq? package grub)
+ (bootloader-configuration
+ (bootloader grub-bootloader)
+ fields ...)
+ (bootloader-configuration
+ (bootloader grub-efi-bootloader)
+ fields ...)))
+ ((_ fields ...)
+ (bootloader-configuration
+ (bootloader grub-bootloader)
+ fields ...))))
+
;;; grub.scm ends here
M gnu/local.mk => gnu/local.mk +3 -1
@@ 36,6 36,9 @@
GNU_SYSTEM_MODULES = \
gnu.scm \
%D%/artwork.scm \
+ %D%/bootloader.scm \
+ %D%/bootloader/grub.scm \
+ %D%/bootloader/extlinux.scm \
%D%/packages.scm \
%D%/packages/abduco.scm \
%D%/packages/abiword.scm \
@@ 443,7 446,6 @@ GNU_SYSTEM_MODULES = \
\
%D%/system.scm \
%D%/system/file-systems.scm \
- %D%/system/grub.scm \
%D%/system/install.scm \
%D%/system/linux-container.scm \
%D%/system/linux-initrd.scm \
M gnu/system.scm => gnu/system.scm +7 -7
@@ 48,6 48,7 @@
#:use-module (gnu services)
#:use-module (gnu services shepherd)
#:use-module (gnu services base)
+ #:use-module (gnu bootloader)
#:use-module (gnu system shadow)
#:use-module (gnu system nss)
#:use-module (gnu system locale)
@@ 139,7 140,7 @@ booted from ROOT-DEVICE"
(default linux-libre))
(kernel-arguments operating-system-user-kernel-arguments
(default '())) ; list of gexps/strings
- (bootloader operating-system-bootloader) ; <grub-configuration>
+ (bootloader operating-system-bootloader) ; <bootloader-configuration>
(initrd operating-system-initrd ; (list fs) -> M derivation
(default base-initrd))
@@ 847,12 848,11 @@ populate the \"old entries\" menu."
(root-device -> (if (eq? 'uuid (file-system-title root-fs))
(uuid->string (file-system-device root-fs))
(file-system-device root-fs)))
- (entry (operating-system-boot-parameters os system root-device)))
- ((module-ref (resolve-interface '(gnu system grub))
- 'grub-configuration-file)
- (operating-system-bootloader os)
- (list entry)
- #:old-entries old-entries)))
+ (entry (operating-system-boot-parameters os system root-device))
+ (bootloader-conf -> (operating-system-bootloader os)))
+ ((bootloader-configuration-file-generator
+ (bootloader-configuration-bootloader bootloader-conf))
+ bootloader-conf (list entry) #:old-entries old-entries)))
(define (fs->boot-device fs)
"Given FS, a <file-system> object, return a value suitable for use as the
M gnu/system/vm.scm => gnu/system/vm.scm +1 -1
@@ 49,7 49,7 @@
#:use-module (gnu system shadow)
#:use-module (gnu system pam)
#:use-module (gnu system linux-initrd)
- #:use-module (gnu system grub)
+ #:use-module (gnu bootloader)
#:use-module (gnu system file-systems)
#:use-module (gnu system)
#:use-module (gnu services)
M gnu/tests.scm => gnu/tests.scm +2 -1
@@ 1,5 1,6 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2016, 2017 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com>
;;;
;;; This file is part of GNU Guix.
;;;
@@ 20,8 21,8 @@
#:use-module (guix gexp)
#:use-module (guix utils)
#:use-module (guix records)
+ #:use-module (gnu bootloader grub)
#:use-module (gnu system)
- #:use-module (gnu system grub)
#:use-module (gnu system file-systems)
#:use-module (gnu system shadow)
#:use-module (gnu services)
M gnu/tests/nfs.scm => gnu/tests/nfs.scm +2 -1
@@ 1,6 1,7 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2016 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2016 John Darrington <jmd@gnu.org>
+;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com>
;;;
;;; This file is part of GNU Guix.
;;;
@@ 19,8 20,8 @@
(define-module (gnu tests nfs)
#:use-module (gnu tests)
+ #:use-module (gnu bootloader grub)
#:use-module (gnu system)
- #:use-module (gnu system grub)
#:use-module (gnu system file-systems)
#:use-module (gnu system shadow)
#:use-module (gnu system vm)
M guix/scripts/system.scm => guix/scripts/system.scm +12 -8
@@ 38,10 38,10 @@
#:use-module (guix build utils)
#:use-module (gnu build install)
#:use-module (gnu system)
+ #:use-module (gnu bootloader)
#:use-module (gnu system file-systems)
#:use-module (gnu system linux-container)
#:use-module (gnu system vm)
- #:use-module (gnu system grub)
#:use-module (gnu services)
#:use-module (gnu services shepherd)
#:use-module (gnu services herd)
@@ 598,8 598,12 @@ output when building a system derivation, such as a disk image."
#:image-size image-size
#:full-boot? full-boot?
#:mappings mappings))
- (grub (package->derivation (grub-configuration-grub
- (operating-system-bootloader os))))
+ (bootloader (let ((bootloader (bootloader-package
+ (bootloader-configuration-bootloader
+ (operating-system-bootloader os)))))
+ (if bootloader
+ (package->derivation bootloader)
+ (return #f))))
(grub.cfg (if (eq? 'container action)
(return #f)
(operating-system-bootcfg os
@@ 611,8 615,8 @@ output when building a system derivation, such as a disk image."
;; --no-grub is passed, because GRUB.CFG because we then use it as a GC
;; root. See <http://bugs.gnu.org/21068>.
(drvs -> (if (memq action '(init reconfigure))
- (if bootloader?
- (list sys grub.cfg grub)
+ (if (and bootloader? bootloader)
+ (list sys grub.cfg bootloader)
(list sys grub.cfg))
(list sys)))
(% (if derivations-only?
@@ 628,8 632,8 @@ output when building a system derivation, such as a disk image."
drvs)
;; Make sure GRUB is accessible.
- (when bootloader?
- (let ((prefix (derivation->output-path grub)))
+ (when (and bootloader? bootloader)
+ (let ((prefix (derivation->output-path bootloader)))
(setenv "PATH"
(string-append prefix "/bin:" prefix "/sbin:"
(getenv "PATH")))))
@@ 832,7 836,7 @@ resulting from command-line parsing."
((first second) second)
(_ #f)))
(device (and bootloader?
- (grub-configuration-device
+ (bootloader-configuration-device
(operating-system-bootloader os)))))
(with-store store