---
gnu.scm | 1 +
gnu/build/install.scm | 45 +++++++++++++-----
gnu/build/vm.scm | 3 +-
gnu/system.scm | 20 +++++++-
gnu/system/grub.scm | 5 ++
gnu/system/u-boot.scm | 124 ++++++++++++++++++++++++++++++++++++++++++++++++
gnu/system/vm.scm | 7 +++
guix/scripts/system.scm | 14 +++---
8 files changed, 199 insertions(+), 20 deletions(-)
create mode 100644 gnu/system/u-boot.scm
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 <partition> 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
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 <l...@gnu.org>
+;;; Copyright © 2016 Danny Milosavljevic <danny...@scratchpost.org>
+;;;
+;;; 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 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) ; <menu-entry>
+ #: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>
+ 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
+<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 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
+ (($ <menu-entry> 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 #$@arguments))))))
+
+ (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))
