Re: wip v2 u-boot support

[Danny Milosavljevic <dannym@scratchpost.org>]

[-- Attachment #1: Type: text/plain, Size: 48 bytes --]

New wip patch attached - applies to git guix...

[-- Attachment #2: uboot.patch --]
[-- Type: text/x-patch, Size: 13543 bytes --]

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 45b46ca..a6b884f 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/mapped-devices.scm b/gnu/system/mapped-devices.scm
index 2ce35ea..9a9a8bb 100644
--- a/gnu/system/mapped-devices.scm
+++ b/gnu/system/mapped-devices.scm
@@ -105,7 +105,7 @@
                       #:select (find-partition-by-luks-uuid)))
 
         (zero? (system* (string-append #$cryptsetup "/sbin/cryptsetup")
-                        "open" "--type" "luks"
+                        "open" "--type" "luks" "-v" "--key-file=/dev/sdb3" "--keyfile-size=64"
 
                         ;; Note: We cannot use the "UUID=source" syntax here
                         ;; because 'cryptsetup' implements it by searching the
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)))))
 
 \f
 ;;;
@@ -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))