ryan77627/guix
1
0
Fork 0
mirror of https://git.in.rschanz.org/ryan77627/guix.git synced 2024-11-07 07:26:13 -05:00
Code Issues Projects Releases Packages Wiki Activity Actions

bootloader: Add extlinux support.

Browse source 
* gnu/bootloader.scm: New file.
* gnu/bootloader/extlinux.scm: New file.
* gnu/bootloader/grub.scm: New file.
* gnu/local.mk: Build new files.
* gnu/system.scm: Adapt to new bootloader api.
* gnu/scripts/system.scm: Adapt to new bootloader api.
* gnu.scm: Remove (gnu system grub) and replace by (gnu bootloader) and (gnu
bootloader grub) modules.
* gnu/system/grub.scm: Moved content to gnu/bootloader/grub.scm.
* gnu/system/vm: Replace (gnu system grub) module by (gnu bootloader).
* gnu/tests.scm: Ditto.
* gnu/tests/nfs.scm: Ditto.
This commit is contained in:
Mathieu Othacehe 2017-05-15 22:24:18 +02:00
parent ce92d269fe
commit b09a8da4a2
No known key found for this signature in database
GPG key ID: 8354763531769CA6
10 changed files with 369 additions and 68 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

4
gnu.scm
View file

@ -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 @@ (define %public-modules
'((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)

127
gnu/bootloader.scm Normal file
View file

@ -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)))

123
gnu/bootloader/extlinux.scm Normal file
View file

@ -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)))

137
gnu/system/grub.scm → gnu/bootloader/grub.scm
View file

@ -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 @@ (define-module (gnu system grub)
#: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 @@ (define-module (gnu system grub)
%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 @@ (define %default-theme
(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 @@ (define-record-type* <menu-entry>
;;; 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 @@ (define* (grub-background-image config #:key (width 1024) (height 768))
(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 @@ (define setup-gfxterm-body
""))
(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 @@ (define (grub-setup-io config)
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 @@ (define* (grub-configuration-file config entries
(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 @@ (define builder
(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 @@ (define builder
(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

4
gnu/local.mk
View file

@ -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 \

14
gnu/system.scm
View file

@ -48,6 +48,7 @@ (define-module (gnu system)
#: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 @@ (define-record-type* <operating-system> operating-system
(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 @@ (define* (operating-system-bootcfg os #:optional (old-entries '()))
(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

2
gnu/system/vm.scm
View file

@ -49,7 +49,7 @@ (define-module (gnu system vm)
#: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)

3
gnu/tests.scm
View file

@ -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 @@ (define-module (gnu tests)
#: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)

3
gnu/tests/nfs.scm
View file

@ -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)

20
guix/scripts/system.scm
View file

@ -38,10 +38,10 @@ (define-module (guix scripts system)
#: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 @@ (define println
#: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 @@ (define println
;; --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 @@ (define println
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 @@ (define (process-action action args opts)
((first second) second)
(_ #f)))
(device (and bootloader?
(grub-configuration-device
(bootloader-configuration-device
(operating-system-bootloader os)))))
(with-store store