diff --git a/gnu.scm b/gnu.scm index 932e4cd..9207e38 100644 --- a/gnu.scm +++ b/gnu.scm @@ -35,6 +35,7 @@ (gnu system mapped-devices) (gnu system file-systems) (gnu system grub) ; 'grub-configuration' + (gnu system u-boot) ; 'u-boot-configuration' (gnu system pam) (gnu system shadow) ; 'user-account' (gnu system linux-initrd) diff --git a/gnu/build/install.scm b/gnu/build/install.scm index 7431a09..92740d5 100644 --- a/gnu/build/install.scm +++ b/gnu/build/install.scm @@ -21,7 +21,7 @@ #:use-module (guix build store-copy) #:use-module (srfi srfi-26) #:use-module (ice-9 match) - #:export (install-grub + #:export (install-bootloader populate-root-file-system reset-timestamps register-closure @@ -36,28 +36,49 @@ ;;; ;;; Code: -(define* (install-grub grub.cfg device mount-point) +(define* (install-bootloader-config source target) + (let* ((pivot (string-append target ".new"))) + (mkdir-p (dirname target)) + + ;; Copy bootloader config file instead of just symlinking it, because symlinks won't + ;; work when /boot is on a separate partition. Do that atomically. + (copy-file source pivot) + (rename-file pivot target))) + +(define* (install-grub grub-name grub.cfg device mount-point) "Install GRUB with GRUB.CFG on DEVICE, which is assumed to be mounted on -MOUNT-POINT. +MOUNT-POINT. FIXME is that correct? Note that the caller must make sure that GRUB.CFG is registered as a GC root so that the fonts, background images, etc. referred to by GRUB.CFG are not GC'd." - (let* ((target (string-append mount-point "/boot/grub/grub.cfg")) - (pivot (string-append target ".new"))) - (mkdir-p (dirname target)) - - ;; Copy GRUB.CFG instead of just symlinking it, because symlinks won't - ;; work when /boot is on a separate partition. Do that atomically. - (copy-file grub.cfg pivot) - (rename-file pivot target) - + (let ((target (string-append mount-point "/boot/grub/grub.cfg"))) + (install-bootloader-config grub.cfg target) (unless (zero? (system* "grub-install" "--no-floppy" "--boot-directory" (string-append mount-point "/boot") device)) (error "failed to install GRUB")))) +(define* (install-u-boot u-boot-name extlinux.conf device mount-point) + "Install U-Boot with EXTLINUX.CONF on DEVICE, which is assumed to be mounted on +MOUNT-POINT. FIXME is that correct?" + (install-bootloader-config extlinux.conf + (string-append mount-point + "/extlinux.conf")) + (unless (zero? (system* (string-append u-boot-name "/bin/u-boot-install") + (string-append "--boot-directory=" mount-point) + device)) + (error "failed to install U-Boot"))) + +(define* (install-bootloader package-output-name config-filename device mount-point) + "Install bootloader with CONFIG-FILENAME on DEVICE, which is assumed to be +mounted on MOUNT-POINT." + (let* ((grub? (string-contains package-output-name "grub")) + (bootloader-installer (if grub? install-grub + install-u-boot))) + (bootloader-installer package-output-name config-filename device mount-point))) + (define (evaluate-populate-directive directive target) "Evaluate DIRECTIVE, an sexp describing a file or directory to create under directory TARGET." diff --git a/gnu/build/vm.scm b/gnu/build/vm.scm index cc5cf45..2e2079e 100644 --- a/gnu/build/vm.scm +++ b/gnu/build/vm.scm @@ -295,6 +295,7 @@ SYSTEM-DIRECTORY is the name of the directory of the 'system' derivation." (define* (initialize-hard-disk device #:key + grub grub.cfg (partitions '())) "Initialize DEVICE as a disk containing all the objects listed @@ -313,7 +314,7 @@ passing it a directory name where it is mounted." (display "mounting root partition...\n") (mkdir-p target) (mount (partition-device root) target (partition-file-system root)) - (install-grub grub.cfg device target) + (install-bootloader grub grub.cfg device target) ;; Register GRUB.CFG as a GC root. (register-grub.cfg-root target grub.cfg) diff --git a/gnu/system.scm b/gnu/system.scm index 0802010..0c54f8f 100644 --- a/gnu/system.scm +++ b/gnu/system.scm @@ -47,6 +47,7 @@ #:use-module (gnu services shepherd) #:use-module (gnu services base) #:use-module (gnu system grub) + #:use-module (gnu system u-boot) #:use-module (gnu system shadow) #:use-module (gnu system nss) #:use-module (gnu system locale) @@ -89,6 +90,7 @@ operating-system-derivation operating-system-profile + operating-system-grub operating-system-grub.cfg operating-system-etc-directory operating-system-locale-directory @@ -703,6 +705,22 @@ listed in OS. The C library expects to find it under "Return the file system that contains the store of OS." (store-file-system (operating-system-file-systems os))) +(define (operating-system-grub os) + (match (operating-system-bootloader os) + ((? grub-configuration? config) + (grub-configuration-package config os)) + ((? u-boot-configuration? config) + (u-boot-configuration-package config os)))) + +(define* (bootloader-configuration-file config store-fs entries + #:key + (system (%current-system)) + (old-entries '())) + ((match config + ((? grub-configuration? config) grub-configuration-file) + ((? u-boot-configuration? config) u-boot-configuration-file)) + config store-fs entries #:system system #:old-entries old-entries)) + (define* (operating-system-grub.cfg os #:optional (old-entries '())) "Return the GRUB configuration file for OS. Use OLD-ENTRIES to populate the \"old entries\" menu." @@ -724,7 +742,7 @@ listed in OS. The C library expects to find it under "/boot") (operating-system-kernel-arguments os))) (initrd #~(string-append #$system "/initrd")))))) - (grub-configuration-file (operating-system-bootloader os) + (bootloader-configuration-file (operating-system-bootloader os) store-fs entries #:old-entries old-entries))) diff --git a/gnu/system/grub.scm b/gnu/system/grub.scm index aa93c0f..923055e 100644 --- a/gnu/system/grub.scm +++ b/gnu/system/grub.scm @@ -49,8 +49,10 @@ grub-configuration grub-configuration? + grub-configuration-package grub-configuration-device + menu-entry menu-entry? @@ -141,6 +143,9 @@ (system* (string-append #$imagemagick "/bin/convert") "-resize" #$size #$image #$output))))) +(define (grub-configuration-package config os) + grub) + (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." diff --git a/gnu/system/u-boot.scm b/gnu/system/u-boot.scm new file mode 100644 index 0000000..290772f --- /dev/null +++ b/gnu/system/u-boot.scm @@ -0,0 +1,124 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2013, 2014, 2015, 2016 Ludovic Courtès +;;; Copyright © 2016 Danny Milosavljevic +;;; +;;; 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 u-boot) + #: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 file-systems) + #:autoload (gnu packages u-boot) (make-u-boot-package) + #:use-module (gnu system grub) ; + #:use-module (ice-9 match) + #:use-module (ice-9 regex) + #:use-module (srfi srfi-1) + #:export (u-boot-configuration + u-boot-configuration? + u-boot-configuration-package + u-boot-configuration-device + u-boot-configuration-file)) + +;;; Commentary: +;;; +;;; Configuration of U-Boot. +;;; +;;; Code: + +(define-record-type* + u-boot-configuration make-u-boot-configuration + u-boot-configuration? + (board u-boot-board (default #f)) ; string + (u-boot u-boot-configuration-u-boot ; package + (default #f)) ; will actually default to (make-u-boot-package board) + (device u-boot-configuration-device (default #f)) ; string + (menu-entries u-boot-configuration-menu-entries ; list + (default '())) + (default-entry u-boot-configuration-default-entry ; integer + (default 0)) + (timeout u-boot-configuration-timeout ; integer + (default 5))) + + + +(define (u-boot-configuration-package config os) + (or (u-boot-configuration-u-boot config) + (make-u-boot-package (u-boot-configuration-board os)))) + +;;; +;;; Configuration file. +;;; + +(define* (u-boot-configuration-file config store-fs 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 linux-image-name + (if (string-prefix? "mips" system) + "vmlinuz" + "bzImage")) + + (define all-entries + (append entries (u-boot-configuration-menu-entries config))) + + (define entry->gexp + (match-lambda + (($ label linux arguments initrd) + ;; TODO MENU LABEL hotkeys (using caret) + #~(format port "LABEL ~s + MENU LABEL ~a + KERNEL ~a/~a + INITRD ~a + FDTDIR . + APPEND ~a +~%" + #$label #$label + #$linux #$linux-image-name + #$initrd + (string-join (list address@hidden)))))) + + (define builder + #~(call-with-output-file #$output + (lambda (port) + (let ((timeout #$(u-boot-configuration-timeout config))) + (format port " +DEFAULT ~a +PROMPT ~a +TIMEOUT ~a~%" + #$(u-boot-configuration-default-entry config) + (if (< timeout 0) 1 0) + (* 10 timeout)) + #$@(map entry->gexp all-entries) + + #$@(if (pair? old-entries) + #~((format port "~%") + #$@(map entry->gexp old-entries) + (format port "~%")) + #~()))))) + + (gexp->derivation "extlinux.conf" builder)) + +;;; u-boot.scm ends here diff --git a/gnu/system/vm.scm b/gnu/system/vm.scm index 03f7d6c..25f186f 100644 --- a/gnu/system/vm.scm +++ b/gnu/system/vm.scm @@ -175,6 +175,7 @@ made available under the /xchg CIFS share." (file-system-type "ext4") file-system-label os-derivation + grub grub-configuration (register-closures? #t) (inputs '()) @@ -231,6 +232,7 @@ the image." (initializer initialize))))) (initialize-hard-disk "/dev/vda" #:partitions partitions + #:grub #$grub #:grub.cfg #$grub-configuration) (reboot))))) #:system system @@ -283,9 +285,11 @@ to USB sticks meant to be read-only." file-systems-to-keep))))) (mlet* %store-monad ((os-drv (operating-system-derivation os)) + (grub (package->derivation (operating-system-grub os))) (grub.cfg (operating-system-grub.cfg os))) (qemu-image #:name name #:os-derivation os-drv + #:grub grub #:grub-configuration grub.cfg #:disk-image-size disk-image-size #:disk-image-format "raw" @@ -330,6 +334,7 @@ of the GNU system as described by OS." ((os-drv (operating-system-derivation os)) (grub.cfg (operating-system-grub.cfg os))) (qemu-image #:os-derivation os-drv + #:grub grub #:grub-configuration grub.cfg #:disk-image-size disk-image-size #:file-system-type file-system-type @@ -416,12 +421,14 @@ When FULL-BOOT? is true, return an image that does a complete boot sequence, bootloaded included; thus, make a disk image that contains everything the bootloader refers to: OS kernel, initrd, bootloader data, etc." (mlet* %store-monad ((os-drv (operating-system-derivation os)) + (grub (package->derivation (operating-system-grub os))) (grub.cfg (operating-system-grub.cfg os))) ;; XXX: When FULL-BOOT? is true, we end up creating an image that contains ;; GRUB.CFG and all its dependencies, including the output of OS-DRV. ;; This is more than needed (we only need the kernel, initrd, GRUB for its ;; font, and the background image), but it's hard to filter that. (qemu-image #:os-derivation os-drv + #:grub grub #:grub-configuration grub.cfg #:disk-image-size disk-image-size #:inputs (if full-boot? diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm index 953c624..738fa6b 100644 --- a/guix/scripts/system.scm +++ b/guix/scripts/system.scm @@ -126,7 +126,7 @@ TARGET, and register them." (map (cut copy-item <> target #:log-port log-port) to-copy)))) -(define (install-grub* grub.cfg device target) +(define (install-bootloader* grub grub.cfg device target) "This is a variant of 'install-grub' with error handling, lifted in %STORE-MONAD" (let* ((gc-root (string-append target %gc-roots-directory @@ -140,7 +140,7 @@ TARGET, and register them." ;; 'install-grub' completes (being a bit paranoid.) (make-symlink temp-gc-root grub.cfg) - (munless (false-if-exception (install-grub grub.cfg device target)) + (munless (false-if-exception (install-bootloader grub grub.cfg device target)) (delete-file temp-gc-root) (leave (_ "failed to install GRUB on device '~a'~%") device)) @@ -150,7 +150,7 @@ TARGET, and register them." (define* (install os-drv target #:key (log-port (current-output-port)) - grub? grub.cfg device) + grub grub? grub.cfg device) "Copy the closure of GRUB.CFG, which includes the output of OS-DRV, to directory TARGET. TARGET must be an absolute directory name since that's what 'guix-register' expects. @@ -193,7 +193,7 @@ the ownership of '~a' may be incorrect!~%") (populate os-dir target) (mwhen grub? - (install-grub* grub.cfg device target))))) + (install-bootloader* grub grub.cfg device target))))) ;;; @@ -598,13 +598,15 @@ building anything." (mbegin %store-monad (switch-to-system os) (mwhen grub? - (install-grub* (derivation->output-path grub.cfg) - device "/")))) + (install-bootloader* (derivation->output-path grub) + (derivation->output-path grub.cfg) + device "/")))) ((init) (newline) (format #t (_ "initializing operating system under '~a'...~%") target) (install sys (canonicalize-path target) + #:grub grub #:grub? grub? #:grub.cfg (derivation->output-path grub.cfg) #:device device))