From mboxrd@z Thu Jan 1 00:00:00 1970 Received: from eggs.gnu.org ([2001:4830:134:3::10]:38321) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1d9oH4-0000Wn-6u for guix-patches@gnu.org; Sun, 14 May 2017 03:49:09 -0400 Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.71) (envelope-from ) id 1d9oH1-0007jf-0P for guix-patches@gnu.org; Sun, 14 May 2017 03:49:06 -0400 Received: from debbugs.gnu.org ([208.118.235.43]:40846) by eggs.gnu.org with esmtps (TLS1.0:RSA_AES_128_CBC_SHA1:16) (Exim 4.71) (envelope-from ) id 1d9oH0-0007ja-Sf for guix-patches@gnu.org; Sun, 14 May 2017 03:49:02 -0400 Received: from Debian-debbugs by debbugs.gnu.org with local (Exim 4.84_2) (envelope-from ) id 1d9oH0-0003ur-Ma for guix-patches@gnu.org; Sun, 14 May 2017 03:49:02 -0400 Subject: bug#26339: [PATCH v4 1/7] bootloader: Add extlinux support. Resent-Message-ID: From: Mathieu Othacehe Date: Sun, 14 May 2017 09:47:57 +0200 Message-Id: <20170514074803.25556-2-m.othacehe@gmail.com> In-Reply-To: <20170514074803.25556-1-m.othacehe@gmail.com> References: <20170514074803.25556-1-m.othacehe@gmail.com> MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit List-Id: List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: guix-patches-bounces+kyle=kyleam.com@gnu.org Sender: "Guix-patches" To: 26339@debbugs.gnu.org * 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. --- gnu.scm | 4 +- gnu/bootloader.scm | 114 ++++++++++++++++++++++++++++ gnu/bootloader/extlinux.scm | 147 ++++++++++++++++++++++++++++++++++++ gnu/{system => bootloader}/grub.scm | 105 ++++++++++++++++++-------- gnu/local.mk | 4 +- gnu/system.scm | 14 ++-- gnu/system/vm.scm | 2 +- gnu/tests.scm | 3 +- gnu/tests/nfs.scm | 3 +- guix/scripts/system.scm | 20 +++-- 10 files changed, 364 insertions(+), 52 deletions(-) create mode 100644 gnu/bootloader.scm create mode 100644 gnu/bootloader/extlinux.scm rename gnu/{system => bootloader}/grub.scm (83%) diff --git a/gnu.scm b/gnu.scm index 932e4cdd5..913ce6160 100644 --- a/gnu.scm +++ b/gnu.scm @@ -1,6 +1,7 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2014, 2015, 2016 Ludovic Courtès ;;; Copyright © 2015 Joshua S. Grant +;;; Copyright © 2017 Mathieu Othacehe ;;; ;;; 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) diff --git a/gnu/bootloader.scm b/gnu/bootloader.scm new file mode 100644 index 000000000..77f81d33a --- /dev/null +++ b/gnu/bootloader.scm @@ -0,0 +1,114 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2017 David Craven +;;; Copyright © 2017 Mathieu Othacehe +;;; +;;; 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 . + +(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-theme + 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 + + %bootloaders + lookup-bootloader-by-name)) + + +;;; +;;; Bootloader record. +;;; + +;;; The 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 make-bootloader + bootloader? + (name bootloader-name) + (package bootloader-package) + (theme bootloader-theme + (default #f)) + (installer bootloader-installer) + (configuration-file bootloader-configuration-file) + (configuration-file-generator bootloader-configuration-file-generator)) + + +;;; +;;; Bootloader configuration record. +;;; + +;;; The record contains bootloader independant +;;; configuration used to fill bootloader configuration file. + +(define-record-type* + bootloader-configuration make-bootloader-configuration + bootloader-configuration? + (bootloader bootloader-configuration-bootloader) ; + (device bootloader-configuration-device ; string + (default #f)) + (menu-entries bootloader-configuration-menu-entries ; list of + (default '())) + (default-entry bootloader-configuration-default-entry ; integer + (default 0)) + (timeout bootloader-configuration-timeout ; integer + (default 5)) + (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) + (format #t "~a\n" (eq? name (bootloader-name bootloader))) + (eq? name (bootloader-name bootloader))) + (force %bootloaders)) + (leave (G_ "~a: no such bootloader~%") name))) diff --git a/gnu/bootloader/extlinux.scm b/gnu/bootloader/extlinux.scm new file mode 100644 index 000000000..002477c0c --- /dev/null +++ b/gnu/bootloader/extlinux.scm @@ -0,0 +1,147 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2017 David Craven +;;; Copyright © 2017 Mathieu Othacehe +;;; +;;; 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 . + +(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 + object, and where the store is available at STORE-FS, a + 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-syslinux + #~(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"))) + (mkdir-p install-dir) + (for-each (lambda (file) + (copy-file file + (string-append install-dir "/" (basename file)))) + (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 #f) + (installer #f) + (configuration-file "/boot/extlinux/extlinux.conf") + (configuration-file-generator extlinux-configuration-file))) + +(define syslinux-bootloader + (bootloader + (inherit extlinux-bootloader) + (name 'syslinux) + (package syslinux) + (installer install-syslinux))) + + +;;; +;;; Compatibility macros. +;;; + +(define-syntax-rule (extlinux-configuration fields ...) + (bootloader-configuration + (bootloader extlinux-bootloader) + fields ...)) + +(define-syntax-rule (syslinux-configuration fields ...) + (bootloader-configuration + (bootloader syslinux-bootloader) + fields ...)) diff --git a/gnu/system/grub.scm b/gnu/bootloader/grub.scm similarity index 83% rename from gnu/system/grub.scm rename to gnu/bootloader/grub.scm index 58096429f..1dd50e391 100644 --- a/gnu/system/grub.scm +++ b/gnu/bootloader/grub.scm @@ -1,6 +1,7 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2013, 2014, 2015, 2016, 2017 Ludovic Courtès ;;; Copyright © 2016 Chris Marusich +;;; Copyright © 2017 Mathieu Othacehe ;;; ;;; This file is part of GNU Guix. ;;; @@ -17,7 +18,7 @@ ;;; You should have received a copy of the GNU General Public License ;;; along with GNU Guix. If not, see . -(define-module (gnu system grub) +(define-module (gnu bootloader grub) #:use-module (guix store) #:use-module (guix packages) #:use-module (guix derivations) @@ -27,6 +28,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) @@ -49,15 +51,11 @@ %background-image %default-theme - grub-configuration - grub-configuration? - grub-configuration-device - grub-configuration-grub - - menu-entry - menu-entry? + grub-bootloader + grub-efi-bootloader - grub-configuration-file)) + grub-configuration + grub-efi-configuration)) ;;; Commentary: ;;; @@ -105,21 +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 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 ; - (default %default-theme))) - (define-record-type* menu-entry make-menu-entry menu-entry? @@ -162,7 +145,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 + (bootloader-configuration-bootloader config)))))) (if image (svg->png (grub-image-file image) #:width width #:height height) @@ -205,7 +189,8 @@ system string---e.g., \"x86_64-linux\"." "")) (define (theme-colors type) - (let* ((theme (grub-configuration-theme config)) + (let* ((theme (bootloader-theme + (bootloader-configuration-bootloader config))) (colors (type theme))) (string-append (symbol->string (assoc-ref colors 'fg)) "/" (symbol->string (assoc-ref colors 'bg))))) @@ -282,12 +267,12 @@ code." (system (%current-system)) (old-entries '())) "Return the GRUB configuration file corresponding to CONFIG, a - object, and where the store is available at STORE-FS, a - object. OLD-ENTRIES is taken to be a list of menu entries -corresponding to old generations of the system." + object, and where the store is available at +STORE-FS, a 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))) + (bootloader-configuration-menu-entries config))) (define entry->gexp (match-lambda @@ -326,8 +311,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) @@ -339,4 +324,60 @@ 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) + (theme %default-theme) + (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-rule (grub-configuration fields ...) + (bootloader-configuration + (bootloader grub-bootloader) + fields ...)) + +(define-syntax-rule (grub-efi-configuration fields ...) + (bootloader-configuration + (bootloader grub-efi-bootloader) + fields ...)) + ;;; grub.scm ends here diff --git a/gnu/local.mk b/gnu/local.mk index 28a283ab7..73650c673 100644 --- a/gnu/local.mk +++ b/gnu/local.mk @@ -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 \ @@ -441,7 +444,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 \ diff --git a/gnu/system.scm b/gnu/system.scm index 9fc6cc5e7..8040e2b15 100644 --- a/gnu/system.scm +++ b/gnu/system.scm @@ -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) @@ -138,7 +139,7 @@ booted from ROOT-DEVICE" (default linux-libre)) (kernel-arguments operating-system-user-kernel-arguments (default '())) ; list of gexps/strings - (bootloader operating-system-bootloader) ; + (bootloader operating-system-bootloader) ; (initrd operating-system-initrd ; (list fs) -> M derivation (default base-initrd)) @@ -846,12 +847,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 object, return a value suitable for use as the diff --git a/gnu/system/vm.scm b/gnu/system/vm.scm index 2c8b954c8..080014cde 100644 --- a/gnu/system/vm.scm +++ b/gnu/system/vm.scm @@ -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) diff --git a/gnu/tests.scm b/gnu/tests.scm index 810711ab9..2886a982f 100644 --- a/gnu/tests.scm +++ b/gnu/tests.scm @@ -1,5 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2016, 2017 Ludovic Courtès +;;; Copyright © 2017 Mathieu Othacehe ;;; ;;; 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) diff --git a/gnu/tests/nfs.scm b/gnu/tests/nfs.scm index 1f28f5a5b..9e1ac1d55 100644 --- a/gnu/tests/nfs.scm +++ b/gnu/tests/nfs.scm @@ -1,6 +1,7 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2016 Ludovic Courtès ;;; Copyright © 2016 John Darrington +;;; Copyright © 2017 Mathieu Othacehe ;;; ;;; 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) diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm index 9c0976750..5fd0d7600 100644 --- a/guix/scripts/system.scm +++ b/guix/scripts/system.scm @@ -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 . (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 -- 2.13.0