Hi David,
I thought I'd post a minimal version for U-Boot support without any renames
that aren't absolutely necessary. In this way, the patch is quite small.
I think I also figured out how to pass the name of the bootloader installation
executable - that's also included.
Let's see whether it works.
See attachement...
I assume that gnu/system/u-boot.scm already exists.
If it doesn't, I've also attached the latest version of it.
As you can see it's no big deal.
Note that the only reasons <u-boot-configuration> is distinct from
<grub-configuration> are:
- The field "board" which contains the board name is necessary in
<u-boot-configuration> but not <grub-configuration>.
- The system config's "operating-system" definition contains a "bootloader"
field that is actually a bootloader-configuration (rather than the actual
bootloader package or similar). Hence there would be no way to find out which
bootloader to install if the configuration wasn't a different data structure.
I'm not sure those are good enough reasons to justify distinguishing them.
It would also be possible to change the system config to something like
(operating-system
(bootloader grub (bootloader-configuration ...)))
and
(operating-system
(bootloader (make-u-boot-package "my_great_system") (bootloader-configuration
...)))
and then drop "board". In that case, <u-boot-configuration> would be the same
as <grub-configuration> - but grub-configuration supports theming which
u-boot-configuration doesn't. We could just ignore the theme parts in that
case, though.
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..24e4e15 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,13 @@ 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))
+ ((? u-boot-configuration? config)
+ (u-boot-configuration-package config))))
+
(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."
diff --git a/gnu/system/grub.scm b/gnu/system/grub.scm
index 45b46ca..4c9da8c 100644
--- a/gnu/system/grub.scm
+++ b/gnu/system/grub.scm
@@ -49,6 +49,7 @@
grub-configuration
grub-configuration?
+ grub-configuration-package
grub-configuration-device
menu-entry
@@ -141,6 +142,9 @@
(system* (string-append #$imagemagick "/bin/convert")
"-resize" #$size #$image #$output)))))
+(define (grub-configuration-package config)
+ 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
index acc529a..00a0165 100644
--- a/gnu/system/u-boot.scm
+++ b/gnu/system/u-boot.scm
@@ -35,7 +35,7 @@
#:export (u-boot-configuration
u-boot-configuration?
u-boot-configuration-board
- u-boot-configuration-u-boot
+ u-boot-configuration-package
u-boot-configuration-device
u-boot-configuration-file))
@@ -61,6 +61,10 @@
+(define (u-boot-configuration-package config)
+ (or (u-boot-configuration-u-boot config)
+ (make-u-boot-package (u-boot-configuration-board config))))
+
;;;
;;; Configuration file.
;;;
diff --git a/gnu/system/vm.scm b/gnu/system/vm.scm
index 4c53edc..e04d8fc 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 (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 (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))
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2016 Danny Milosavljevic <dan...@scratchpost.org>
;;; Copyright © 2016 David Craven <da...@craven.ch>
;;;
;;; 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 packages u-boot)
#:use-module (guix build-system gnu)
#:use-module (guix download)
#:use-module (guix packages)
#:use-module ((guix licenses) #:prefix license:)
#:use-module (gnu packages)
#:use-module ((gnu packages algebra) #:select (bc))
#:use-module (gnu packages bison)
#:use-module (gnu packages cross-base)
#:use-module (gnu packages flex)
#:use-module (gnu packages python))
(define-public dtc
(package
(name "dtc")
(version "1.4.2")
(source (origin
(method url-fetch)
(uri (string-append
"https://www.kernel.org/pub/software/utils/dtc/";
"dtc-" version ".tar.xz"))
(sha256
(base32
"1b7si8niyca4wxbfah3qw4p4wli81mc1qwfhaswvrfqahklnwi8k"))))
(build-system gnu-build-system)
(native-inputs
`(("bison" ,bison)
("flex" ,flex)))
(arguments
`(#:make-flags
(list "CC=gcc" (string-append "PREFIX=" (assoc-ref %outputs "out")))
#:phases
(modify-phases %standard-phases
(add-after 'unpack 'patch-paths
(lambda _
(substitute* "Makefile"
(("/usr/bin/install") "install"))
(substitute* "Makefile"
(("PREFIX = \\$\\(HOME\\)") ""))))
(delete 'configure))))
(home-page "https://www.devicetree.org";)
(synopsis "Compiles device tree source files")
(description "@command{dtc} compiles device tree source files to device
tree binary files. These are board description files used by Linux and BSD.")
(license license:gpl2+)))
(define u-boot
(package
(name "u-boot")
(version "2016.07")
(source (origin
(method url-fetch)
(uri (string-append
"ftp://ftp.denx.de/pub/u-boot/";
"u-boot-" version ".tar.bz2"))
(sha256
(base32
"0lqj4ckmfqiap8mc6z2d5albs3g2h5mzccbn60hsgxhabhibfkwp"))))
(native-inputs
`(("bc" ,bc)
("dtc" ,dtc)
("python-2" ,python-2)))
(build-system gnu-build-system)
(home-page "http://www.denx.de/wiki/U-Boot/";)
(synopsis "ARM bootloader")
(description "U-Boot is a bootloader used mostly for ARM boards. It
also initializes the boards (RAM etc).")
(license license:gpl2+)))
(define (make-u-boot-package board triplet)
"Returns a u-boot package for BOARD cross-compiled for TRIPLET."
(package
(inherit u-boot)
(name (string-append "u-boot-" (string-downcase board)))
(native-inputs
`(("cross-gcc" ,(cross-gcc triplet))
("cross-binutils" ,(cross-binutils triplet))
,@(package-native-inputs u-boot)))
(arguments
`(#:test-target "test"
#:make-flags
(list "HOSTCC=gcc" (string-append "CROSS_COMPILE=" ,triplet "-"))
#:phases
(modify-phases %standard-phases
(replace 'configure
(lambda* (#:key outputs make-flags #:allow-other-keys)
(let ((config-name (string-append ,board "_defconfig")))
(if (file-exists? (string-append "configs/" config-name))
(zero? (apply system* "make" `(,@make-flags ,config-name)))
(begin
(display "Invalid board name. Valid board names are:")
(let ((dir (opendir "configs"))
(suffix-length (string-length "_defconfig")))
(do ((file-name (readdir dir) (readdir dir)))
((eof-object? file-name))
(when (string-suffix? "_defconfig" file-name)
(format #t "- ~A\n"
(string-drop-right file-name suffix-length))))
(closedir dir))
#f)))))
(replace 'install
(lambda* (#:key outputs make-flags #:allow-other-keys)
(let* ((out (assoc-ref outputs "out"))
(libexec (string-append out "/libexec"))
(uboot-files (find-files "." ".*\\.(bin|efi|spl)$")))
(mkdir-p libexec)
(for-each
(lambda (file)
(let ((target-file (string-append libexec "/" file)))
(mkdir-p (dirname target-file))
(copy-file file target-file)))
uboot-files)))))))))
(define-public u-boot-vexpress_ca9x4
(make-u-boot-package "vexpress_ca9x4" "arm-linux-gnueabihf"))
(define-public u-boot-malta
(make-u-boot-package "malta" "mips64el-linux-gnuabi64"))
