From cd903ef7871170d3c4eced45418459d293ef48a7 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 3 May 2017 23:03:20 +0200 Subject: Add (guix discovery). * guix/discovery.scm, tests/discovery.scm: New files. * gnu/packages.scm (scheme-files, file-name->module-name) (scheme-modules, all-package-modules): Remove. (fold-packages): Rewrite in terms of 'fold-module-public-variables'. * gnu/tests.scm: Use (guix discovery). * Makefile.am (MODULES): Add guix/discovery.scm. (SCM_TESTS): Add tests/discovery.scm. --- gnu/tests.scm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'gnu/tests.scm') diff --git a/gnu/tests.scm b/gnu/tests.scm index e84d1ebb20..0df6e5a2ef 100644 --- a/gnu/tests.scm +++ b/gnu/tests.scm @@ -27,7 +27,7 @@ #:use-module (gnu services) #:use-module (gnu services base) #:use-module (gnu services shepherd) - #:use-module ((gnu packages) #:select (scheme-modules)) + #:use-module ((guix discovery) #:select (scheme-modules)) #:use-module (srfi srfi-1) #:use-module (srfi srfi-9 gnu) #:use-module (ice-9 match) -- cgit v1.2.3 From 67d84d6335ae84ac7c217061570e6b968060073c Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 4 May 2017 11:43:01 +0200 Subject: tests: Use 'fold-module-public-variables' for discovery. * gnu/tests.scm (fold-system-tests): Write in terms of 'fold-module-public-variables'. --- gnu/tests.scm | 19 +++++++------------ 1 file changed, 7 insertions(+), 12 deletions(-) (limited to 'gnu/tests.scm') diff --git a/gnu/tests.scm b/gnu/tests.scm index 0df6e5a2ef..810711ab91 100644 --- a/gnu/tests.scm +++ b/gnu/tests.scm @@ -27,7 +27,7 @@ #:use-module (gnu services) #:use-module (gnu services base) #:use-module (gnu services shepherd) - #:use-module ((guix discovery) #:select (scheme-modules)) + #:use-module (guix discovery) #:use-module (srfi srfi-1) #:use-module (srfi srfi-9 gnu) #:use-module (ice-9 match) @@ -263,17 +263,12 @@ the system under test." (define (fold-system-tests proc seed) "Invoke PROC on each system test, passing it the test and the previous result." - (fold (lambda (module result) - (fold (lambda (thing result) - (if (system-test? thing) - (proc thing result) - result)) - result - (module-map (lambda (sym var) - (false-if-exception (variable-ref var))) - module))) - '() - (test-modules))) + (fold-module-public-variables (lambda (obj result) + (if (system-test? obj) + (cons obj result) + result)) + '() + (test-modules))) (define (all-system-tests) "Return the list of system tests." -- cgit v1.2.3 From b09a8da4a2e50845a297e041762f3ff9e649c047 Mon Sep 17 00:00:00 2001 From: Mathieu Othacehe Date: Mon, 15 May 2017 22:24:18 +0200 Subject: bootloader: Add extlinux support. * 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 | 127 +++++++++++++ gnu/bootloader/extlinux.scm | 123 ++++++++++++ gnu/bootloader/grub.scm | 448 ++++++++++++++++++++++++++++++++++++++++++++ gnu/local.mk | 4 +- gnu/system.scm | 14 +- gnu/system/grub.scm | 407 ---------------------------------------- gnu/system/vm.scm | 2 +- gnu/tests.scm | 3 +- gnu/tests/nfs.scm | 3 +- guix/scripts/system.scm | 20 +- 11 files changed, 728 insertions(+), 427 deletions(-) create mode 100644 gnu/bootloader.scm create mode 100644 gnu/bootloader/extlinux.scm create mode 100644 gnu/bootloader/grub.scm delete mode 100644 gnu/system/grub.scm (limited to 'gnu/tests.scm') diff --git a/gnu.scm b/gnu.scm index 932e4cdd58..913ce61600 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 0000000000..4e77974d31 --- /dev/null +++ b/gnu/bootloader.scm @@ -0,0 +1,127 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2017 David Craven +;;; Copyright © 2017 Mathieu Othacehe +;;; Copyright © 2017 Leo Famulari +;;; +;;; 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-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 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) + (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 ; 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))) diff --git a/gnu/bootloader/extlinux.scm b/gnu/bootloader/extlinux.scm new file mode 100644 index 0000000000..a002001071 --- /dev/null +++ b/gnu/bootloader/extlinux.scm @@ -0,0 +1,123 @@ +;;; 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-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))) diff --git a/gnu/bootloader/grub.scm b/gnu/bootloader/grub.scm new file mode 100644 index 0000000000..49616b7164 --- /dev/null +++ b/gnu/bootloader/grub.scm @@ -0,0 +1,448 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2013, 2014, 2015, 2016, 2017 Ludovic Courtès +;;; Copyright © 2016 Chris Marusich +;;; Copyright © 2017 Leo Famulari +;;; 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 grub) + #:use-module (guix store) + #:use-module (guix packages) + #:use-module (guix derivations) + #:use-module (guix records) + #:use-module (guix monads) + #:use-module (guix gexp) + #: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) + #:autoload (gnu packages gtk) (guile-cairo guile-rsvg) + #:use-module (ice-9 match) + #:use-module (ice-9 regex) + #:use-module (srfi srfi-1) + #:use-module (rnrs bytevectors) + #:export (grub-image + grub-image? + grub-image-aspect-ratio + grub-image-file + + grub-theme + grub-theme? + grub-theme-images + grub-theme-color-normal + grub-theme-color-highlight + + %background-image + %default-theme + + grub-bootloader + grub-efi-bootloader + + grub-configuration)) + +;;; Commentary: +;;; +;;; Configuration of GNU GRUB. +;;; +;;; Code: + +(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)))) + +(define-record-type* + grub-image make-grub-image + grub-image? + (aspect-ratio grub-image-aspect-ratio ;rational number + (default 4/3)) + (file grub-image-file)) ;file-valued gexp (SVG) + +(define-record-type* + grub-theme make-grub-theme + grub-theme? + (images grub-theme-images + (default '())) ;list of + (color-normal grub-theme-color-normal + (default '((fg . cyan) (bg . blue)))) + (color-highlight grub-theme-color-highlight + (default '((fg . white) (bg . blue))))) + +(define %background-image + (grub-image + (aspect-ratio 4/3) + (file (file-append %artwork-repository + "/grub/GuixSD-fully-black-4-3.svg")))) + +(define %default-theme + ;; Default theme contributed by Felipe López. + (grub-theme + (images (list %background-image)) + (color-highlight '((fg . yellow) (bg . black))) + (color-normal '((fg . light-gray) (bg . black))))) ;XXX: #x303030 + +(define-record-type* + 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. +;;; + +(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" + (with-imported-modules '((gnu build svg)) + #~(begin + ;; We need these two libraries. + (add-to-load-path (string-append #+guile-rsvg + "/share/guile/site/" + (effective-version))) + (add-to-load-path (string-append #+guile-cairo + "/share/guile/site/" + (effective-version))) + + (use-modules (gnu build svg)) + (svg->png #+svg #$output + #:width #$width + #:height #$height))))) + +(define* (grub-background-image config #:key (width 1024) (height 768)) + "Return the GRUB background image defined in CONFIG with a ratio of +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 + (bootloader-theme config))))) + (if image + (svg->png (grub-image-file image) + #:width width #:height height) + (with-monad %store-monad + (return #f))))) + +(define* (eye-candy config store-device store-mount-point + #:key system port) + "Return in %STORE-MONAD a gexp that writes to PORT (a port-valued gexp) the +'grub.cfg' part concerned with graphics mode, background images, colors, and +all that. STORE-DEVICE designates the device holding the store, and +STORE-MOUNT-POINT is its mount point; these are used to determine where the +background image and fonts must be searched for. SYSTEM must be the target +system string---e.g., \"x86_64-linux\"." + (define setup-gfxterm-body + ;; Intel and EFI systems need to be switched into graphics mode, whereas + ;; most other modern architectures have no other mode and therefore don't + ;; need to be switched. + (if (string-match "^(x86_64|i[3-6]86)-" system) + " + # Leave 'gfxmode' to 'auto'. + insmod video_bochs + insmod video_cirrus + insmod gfxterm + + if [ \"${grub_platform}\" == efi ]; then + # This is for (U)EFI systems (these modules are unavailable in the + # non-EFI GRUB.) If we don't load them, GRUB boots in \"blind mode\", + # which isn't convenient. + insmod efi_gop + insmod efi_uga + else + # These are specific to non-EFI Intel machines. + insmod vbe + insmod vga + fi +" + "")) + + (define (setup-gfxterm config font-file) + (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 (bootloader-theme config)) + (colors (type theme))) + (string-append (symbol->string (assoc-ref colors 'fg)) "/" + (symbol->string (assoc-ref colors 'bg))))) + + (define font-file + (strip-mount-point store-mount-point + (file-append grub "/share/grub/unicode.pf2"))) + + (mlet* %store-monad ((image (grub-background-image config))) + (return (and image + #~(format #$port " +function setup_gfxterm {~a} + +# Set 'root' to the partition that contains /gnu/store. +~a + +~a +~a + +insmod png +if background_image ~a; then + set color_normal=~a + set color_highlight=~a +else + set menu_color_normal=cyan/blue + set menu_color_highlight=white/blue +fi~%" + #$setup-gfxterm-body + #$(grub-root-search store-device font-file) + #$(setup-gfxterm config font-file) + #$(grub-setup-io config) + + #$(strip-mount-point store-mount-point image) + #$(theme-colors grub-theme-color-normal) + #$(theme-colors grub-theme-color-highlight)))))) + + +;;; +;;; Configuration file. +;;; + +(define (grub-setup-io config) + "Return GRUB commands to configure the input / output interfaces. The result +is a string that can be inserted in grub.cfg." + (let* ((symbols->string (lambda (list) + (string-join (map symbol->string list) " "))) + (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 + ;; Handling". + (valid-outputs '(console serial serial_0 serial_1 serial_2 serial_3 + gfxterm vga_text mda_text morse spkmodem)) + (valid-inputs '(console serial serial_0 serial_1 serial_2 serial_3 + at_keyboard usb_keyboard)) + + (io (string-append + "terminal_output " + (symbols->string + (map + (lambda (output) + (if (memq output valid-outputs) output #f)) outputs)) "\n" + (if (null? inputs) + "" + (string-append + "terminal_input " + (symbols->string + (map + (lambda (input) + (if (memq input valid-inputs) input #f)) inputs)) "\n")) + ;; UNIT and SPEED are arguments to the same GRUB command + ;; ("serial"), so we process them together. + (if (or unit speed) + (string-append + "serial" + (if unit + ;; COM ports 1 through 4 + (if (and (exact-integer? unit) (<= unit 3) (>= unit 0)) + (string-append " --unit=" (number->string unit)) + #f) + "") + (if speed + (if (exact-integer? speed) + (string-append " --speed=" (number->string speed)) + #f) + "")) + "")))) + (format #f "~a" io))) + +(define (grub-root-search device file) + "Return the GRUB 'search' command to look for DEVICE, which contains FILE, +a gexp. The result is a gexp that can be inserted in the grub.cfg-generation +code." + ;; Usually FILE is a file name gexp like "/gnu/store/…-linux/vmlinuz", but + ;; it can also be something like "(hd0,msdos1)/vmlinuz" in the case of + ;; custom menu entries. In the latter case, don't emit a 'search' command. + (if (and (string? file) (not (string-prefix? "/" file))) + "" + (match device + ;; Preferably refer to DEVICE by its UUID or label. This is more + ;; efficient and less ambiguous, see . + ((? bytevector? uuid) + (format #f "search --fs-uuid --set ~a" + (uuid->string device))) + ((? string? label) + (format #f "search --label --set ~a" label)) + (#f + #~(format #f "search --file --set ~a" #$file))))) + +(define (boot-parameters->menu-entry conf) + "Convert a instance to a corresponding ." + (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)) + (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." + (define all-entries + (map boot-parameters->menu-entry + (append entries + (bootloader-configuration-menu-entries config)))) + + (define entry->gexp + (match-lambda + (($ label device device-mount-point + linux arguments initrd) + ;; Here DEVICE is the store and DEVICE-MOUNT-POINT is its mount point. + ;; Use the right file names for LINUX 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))) + #~(format port "menuentry ~s { + ~a + linux ~a ~a + initrd ~a +}~%" + #$label + #$(grub-root-search device linux) + #$linux (string-join (list #$@arguments)) + #$initrd))))) + + (mlet %store-monad ((sugar (eye-candy config + (menu-entry-device (first all-entries)) + (menu-entry-device-mount-point + (first all-entries)) + #:system system + #:port #~port))) + (define builder + #~(call-with-output-file #$output + (lambda (port) + (format port + "# This file was generated from your GuixSD configuration. Any changes +# will be lost upon reconfiguration. +") + #$sugar + (format port " +set default=~a +set timeout=~a~%" + #$(bootloader-configuration-default-entry config) + #$(bootloader-configuration-timeout config)) + #$@(map entry->gexp all-entries) + + #$@(if (pair? old-entries) + #~((format port " +submenu \"GNU system, old configurations...\" {~%") + #$@(map entry->gexp (map boot-parameters->menu-entry old-entries)) + (format port "}~%")) + #~())))) + + (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 diff --git a/gnu/local.mk b/gnu/local.mk index c560c71725..d0c5b9daf8 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 \ @@ -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 \ diff --git a/gnu/system.scm b/gnu/system.scm index f9a0da9a75..a705bf6900 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) @@ -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) ; + (bootloader operating-system-bootloader) ; (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 object, return a value suitable for use as the diff --git a/gnu/system/grub.scm b/gnu/system/grub.scm deleted file mode 100644 index 85878de85c..0000000000 --- a/gnu/system/grub.scm +++ /dev/null @@ -1,407 +0,0 @@ -;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2013, 2014, 2015, 2016, 2017 Ludovic Courtès -;;; Copyright © 2016 Chris Marusich -;;; Copyright © 2017 Leo Famulari -;;; -;;; 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 system grub) - #:use-module (guix store) - #:use-module (guix packages) - #:use-module (guix derivations) - #:use-module (guix records) - #:use-module (guix monads) - #:use-module (guix gexp) - #:use-module (guix download) - #:use-module (gnu artwork) - #:use-module (gnu system) - #:use-module (gnu system file-systems) - #:autoload (gnu packages bootloaders) (grub) - #:autoload (gnu packages compression) (gzip) - #:autoload (gnu packages gtk) (guile-cairo guile-rsvg) - #:use-module (ice-9 match) - #:use-module (ice-9 regex) - #:use-module (srfi srfi-1) - #:use-module (rnrs bytevectors) - #:export (grub-image - grub-image? - grub-image-aspect-ratio - grub-image-file - - grub-theme - grub-theme? - grub-theme-images - grub-theme-color-normal - grub-theme-color-highlight - - %background-image - %default-theme - - grub-configuration - grub-configuration? - grub-configuration-device - grub-configuration-grub - - menu-entry - menu-entry? - - grub-configuration-file)) - -;;; Commentary: -;;; -;;; Configuration of GNU GRUB. -;;; -;;; Code: - -(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)))) - -(define-record-type* - grub-image make-grub-image - grub-image? - (aspect-ratio grub-image-aspect-ratio ;rational number - (default 4/3)) - (file grub-image-file)) ;file-valued gexp (SVG) - -(define-record-type* - grub-theme make-grub-theme - grub-theme? - (images grub-theme-images - (default '())) ;list of - (color-normal grub-theme-color-normal - (default '((fg . cyan) (bg . blue)))) - (color-highlight grub-theme-color-highlight - (default '((fg . white) (bg . blue))))) - -(define %background-image - (grub-image - (aspect-ratio 4/3) - (file (file-append %artwork-repository - "/grub/GuixSD-fully-black-4-3.svg")))) - -(define %default-theme - ;; Default theme contributed by Felipe López. - (grub-theme - (images (list %background-image)) - (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)) - (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 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. -;;; - -(define* (svg->png svg #:key width height) - "Build a PNG of HEIGHT x WIDTH from SVG." - (gexp->derivation "grub-image.png" - (with-imported-modules '((gnu build svg)) - #~(begin - ;; We need these two libraries. - (add-to-load-path (string-append #+guile-rsvg - "/share/guile/site/" - (effective-version))) - (add-to-load-path (string-append #+guile-cairo - "/share/guile/site/" - (effective-version))) - - (use-modules (gnu build svg)) - (svg->png #+svg #$output - #:width #$width - #:height #$height))))) - -(define* (grub-background-image config #:key (width 1024) (height 768)) - "Return the GRUB background image defined in CONFIG with a ratio of -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))))) - (if image - (svg->png (grub-image-file image) - #:width width #:height height) - (with-monad %store-monad - (return #f))))) - -(define* (eye-candy config store-device store-mount-point - #:key system port) - "Return in %STORE-MONAD a gexp that writes to PORT (a port-valued gexp) the -'grub.cfg' part concerned with graphics mode, background images, colors, and -all that. STORE-DEVICE designates the device holding the store, and -STORE-MOUNT-POINT is its mount point; these are used to determine where the -background image and fonts must be searched for. SYSTEM must be the target -system string---e.g., \"x86_64-linux\"." - (define setup-gfxterm-body - ;; Intel and EFI systems need to be switched into graphics mode, whereas - ;; most other modern architectures have no other mode and therefore don't - ;; need to be switched. - (if (string-match "^(x86_64|i[3-6]86)-" system) - " - # Leave 'gfxmode' to 'auto'. - insmod video_bochs - insmod video_cirrus - insmod gfxterm - - if [ \"${grub_platform}\" == efi ]; then - # This is for (U)EFI systems (these modules are unavailable in the - # non-EFI GRUB.) If we don't load them, GRUB boots in \"blind mode\", - # which isn't convenient. - insmod efi_gop - insmod efi_uga - else - # These are specific to non-EFI Intel machines. - insmod vbe - insmod vga - fi -" - "")) - - (define (setup-gfxterm config font-file) - (if (memq 'gfxterm (grub-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)) - (colors (type theme))) - (string-append (symbol->string (assoc-ref colors 'fg)) "/" - (symbol->string (assoc-ref colors 'bg))))) - - (define font-file - (strip-mount-point store-mount-point - (file-append grub "/share/grub/unicode.pf2"))) - - (mlet* %store-monad ((image (grub-background-image config))) - (return (and image - #~(format #$port " -function setup_gfxterm {~a} - -# Set 'root' to the partition that contains /gnu/store. -~a - -~a -~a - -insmod png -if background_image ~a; then - set color_normal=~a - set color_highlight=~a -else - set menu_color_normal=cyan/blue - set menu_color_highlight=white/blue -fi~%" - #$setup-gfxterm-body - #$(grub-root-search store-device font-file) - #$(setup-gfxterm config font-file) - #$(grub-setup-io config) - - #$(strip-mount-point store-mount-point image) - #$(theme-colors grub-theme-color-normal) - #$(theme-colors grub-theme-color-highlight)))))) - - -;;; -;;; Configuration file. -;;; - -(define (grub-setup-io config) - "Return GRUB commands to configure the input / output interfaces. The result -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)) - - ;; Respectively, GRUB_TERMINAL_OUTPUT and GRUB_TERMINAL_INPUT, - ;; as documented in GRUB manual section "Simple Configuration - ;; Handling". - (valid-outputs '(console serial serial_0 serial_1 serial_2 serial_3 - gfxterm vga_text mda_text morse spkmodem)) - (valid-inputs '(console serial serial_0 serial_1 serial_2 serial_3 - at_keyboard usb_keyboard)) - - (io (string-append - "terminal_output " - (symbols->string - (map - (lambda (output) - (if (memq output valid-outputs) output #f)) outputs)) "\n" - (if (null? inputs) - "" - (string-append - "terminal_input " - (symbols->string - (map - (lambda (input) - (if (memq input valid-inputs) input #f)) inputs)) "\n")) - ;; UNIT and SPEED are arguments to the same GRUB command - ;; ("serial"), so we process them together. - (if (or unit speed) - (string-append - "serial" - (if unit - ;; COM ports 1 through 4 - (if (and (exact-integer? unit) (<= unit 3) (>= unit 0)) - (string-append " --unit=" (number->string unit)) - #f) - "") - (if speed - (if (exact-integer? speed) - (string-append " --speed=" (number->string speed)) - #f) - "")) - "")))) - (format #f "~a" io))) - -(define (grub-root-search device file) - "Return the GRUB 'search' command to look for DEVICE, which contains FILE, -a gexp. The result is a gexp that can be inserted in the grub.cfg-generation -code." - ;; Usually FILE is a file name gexp like "/gnu/store/…-linux/vmlinuz", but - ;; it can also be something like "(hd0,msdos1)/vmlinuz" in the case of - ;; custom menu entries. In the latter case, don't emit a 'search' command. - (if (and (string? file) (not (string-prefix? "/" file))) - "" - (match device - ;; Preferably refer to DEVICE by its UUID or label. This is more - ;; efficient and less ambiguous, see . - ((? bytevector? uuid) - (format #f "search --fs-uuid --set ~a" - (uuid->string device))) - ((? string? label) - (format #f "search --label --set ~a" label)) - (#f - #~(format #f "search --file --set ~a" #$file))))) - -(define (boot-parameters->menu-entry conf) - "Convert a instance to a corresponding ." - (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)) - (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." - (define all-entries - (append (map boot-parameters->menu-entry entries) - (grub-configuration-menu-entries config))) - - (define entry->gexp - (match-lambda - (($ label device device-mount-point - linux arguments initrd) - ;; Here DEVICE is the store and DEVICE-MOUNT-POINT is its mount point. - ;; Use the right file names for LINUX 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))) - #~(format port "menuentry ~s { - ~a - linux ~a ~a - initrd ~a -}~%" - #$label - #$(grub-root-search device linux) - #$linux (string-join (list #$@arguments)) - #$initrd))))) - - (mlet %store-monad ((sugar (eye-candy config - (menu-entry-device (first all-entries)) - (menu-entry-device-mount-point - (first all-entries)) - #:system system - #:port #~port))) - (define builder - #~(call-with-output-file #$output - (lambda (port) - (format port - "# This file was generated from your GuixSD configuration. Any changes -# will be lost upon reconfiguration. -") - #$sugar - (format port " -set default=~a -set timeout=~a~%" - #$(grub-configuration-default-entry config) - #$(grub-configuration-timeout config)) - #$@(map entry->gexp all-entries) - - #$@(if (pair? old-entries) - #~((format port " -submenu \"GNU system, old configurations...\" {~%") - #$@(map entry->gexp (map boot-parameters->menu-entry old-entries)) - (format port "}~%")) - #~())))) - - (gexp->derivation "grub.cfg" builder))) - -;;; grub.scm ends here diff --git a/gnu/system/vm.scm b/gnu/system/vm.scm index 2c8b954c80..080014cde4 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 810711ab91..2886a982f4 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 1f28f5a5b8..9e1ac1d55a 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 9c09767508..5fd0d7600c 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 -- cgit v1.2.3