16/17: vm: Support arbitrary partition flags.

[Ludovic Courtès]

civodul pushed a commit to branch version-0.13.0
in repository guix.

commit fd5a30ab7b999f9b1095426054b5fcdfdacddc6f
Author: Marius Bakke <address@hidden>
Date:   Tue Apr 11 10:47:38 2017 +0200

    vm: Support arbitrary partition flags.
    
    * gnu/build/vm.scm (<partition>): Change BOOTABLE? to FLAGS.
    (initialize-partition-table): Pass each flag to parted.
    (initialize-hard-disk): Locate boot partition.
    * gnu/system/vm.scm (qemu-image): Adjust partition flags.
---
 gnu/build/vm.scm  | 17 ++++++++++++-----
 gnu/system/vm.scm |  2 +-
 2 files changed, 13 insertions(+), 6 deletions(-)

diff --git a/gnu/build/vm.scm b/gnu/build/vm.scm
index 1eb9a4c..00d625c 100644
--- a/gnu/build/vm.scm
+++ b/gnu/build/vm.scm
@@ -3,6 +3,7 @@
 ;;; Copyright © 2016 Christopher Allan Webber <address@hidden>
 ;;; Copyright © 2016 Leo Famulari <address@hidden>
 ;;; Copyright © 2017 Mathieu Othacehe <address@hidden>
+;;; Copyright © 2017 Marius Bakke <address@hidden>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -41,7 +42,7 @@
             partition-size
             partition-file-system
             partition-label
-            partition-bootable?
+            partition-flags
             partition-initializer
 
             root-partition-initializer
@@ -141,7 +142,7 @@ the #:references-graphs parameter of 'derivation'."
   (size        partition-size)
   (file-system partition-file-system (default "ext4"))
   (label       partition-label (default #f))
-  (bootable?   partition-bootable? (default #f))
+  (flags       partition-flags (default '()))
   (initializer partition-initializer (default (const #t))))
 
 (define (fold2 proc seed1 seed2 lst)              ;TODO: factorize
@@ -168,9 +169,10 @@ actual /dev name based on DEVICE."
     (cons* "mkpart" "primary" "ext2"
            (format #f "~aB" offset)
            (format #f "~aB" (+ offset (partition-size part)))
-           (if (partition-bootable? part)
-               `("set" ,(number->string index) "boot" "on")
-               '())))
+           (append-map (lambda (flag)
+                         (list "set" (number->string index)
+                               (symbol->string flag) "on"))
+                       (partition-flags part))))
 
   (define (options partitions offset)
     (let loop ((partitions partitions)
@@ -300,6 +302,11 @@ in PARTITIONS, and using BOOTCFG as its bootloader 
configuration file.
 
 Each partition is initialized by calling its 'initializer' procedure,
 passing it a directory name where it is mounted."
+
+  (define (partition-bootable? partition)
+    "Return the first partition found with the boot flag set."
+    (member 'boot (partition-flags partition)))
+
   (let* ((partitions (initialize-partition-table device partitions))
          (root       (find partition-bootable? partitions))
          (target     "/fs"))
diff --git a/gnu/system/vm.scm b/gnu/system/vm.scm
index 2c8b954..71bc55d 100644
--- a/gnu/system/vm.scm
+++ b/gnu/system/vm.scm
@@ -229,7 +229,7 @@ the image."
                                                 (* 10 (expt 2 20))))
                                      (label #$file-system-label)
                                      (file-system #$file-system-type)
-                                     (bootable? #t)
+                                     (flags '(boot))
                                      (initializer initialize)))))
              (initialize-hard-disk "/dev/vda"
                                    #:partitions partitions