summaryrefslogtreecommitdiff
path: root/gnu/build
diff options
context:
space:
mode:
authorLudovic Courtès <ludo@gnu.org>2018-06-26 13:47:30 +0200
committerLudovic Courtès <ludo@gnu.org>2018-06-26 14:27:57 +0200
commit718d44cc9ff1a7e97b4e4ce028cc273c2e20cf93 (patch)
tree56e164ea5a6abdb6b98f926fd284e7102eff7fd0 /gnu/build
parenta7751eeb574e92b7d629e00f71a4207a52a3a62e (diff)
downloadpatches-718d44cc9ff1a7e97b4e4ce028cc273c2e20cf93.tar
patches-718d44cc9ff1a7e97b4e4ce028cc273c2e20cf93.tar.gz
vm: 'make-iso9660-image' no longer includes unreferenced store items.
Fixes <https://bugs.gnu.org/31757>. * gnu/build/vm.scm (make-iso9660-image): Invoke 'grub-mkrescue' in 'open-pipe*'. Use '-path-list -' instead of passing "gnu/store=…".
Diffstat (limited to 'gnu/build')
-rw-r--r--gnu/build/vm.scm99
1 files changed, 61 insertions, 38 deletions
diff --git a/gnu/build/vm.scm b/gnu/build/vm.scm
index 312500de88..a835c4204a 100644
--- a/gnu/build/vm.scm
+++ b/gnu/build/vm.scm
@@ -34,6 +34,7 @@
#:use-module (ice-9 format)
#:use-module (ice-9 match)
#:use-module (ice-9 regex)
+ #:use-module (ice-9 popen)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-9)
#:use-module (srfi srfi-26)
@@ -408,44 +409,66 @@ SYSTEM-DIRECTORY is the name of the directory of the 'system' derivation."
register-closures? (closures '()))
"Given a GRUB package, creates an iso image as TARGET, using CONFIG-FILE as
GRUB configuration and OS-DRV as the stuff in it."
- (let ((grub-mkrescue (string-append grub "/bin/grub-mkrescue"))
- (target-store (string-append "/tmp/root" (%store-directory))))
- (populate-root-file-system os-drv "/tmp/root")
-
- (mount (%store-directory) target-store "" MS_BIND)
-
- (when register-closures?
- (display "registering closures...\n")
- (for-each (lambda (closure)
- (register-closure
- "/tmp/root"
- (string-append "/xchg/" closure)
- ;; TARGET-STORE is a read-only bind-mount so we shouldn't try
- ;; to modify it.
- #:deduplicate? #f
- #:reset-timestamps? #f))
- closures))
-
- (apply invoke
- `(,grub-mkrescue "-o" ,target
- ,(string-append "boot/grub/grub.cfg=" config-file)
- ,(string-append "gnu/store=" os-drv "/..")
- "etc=/tmp/root/etc"
- "var=/tmp/root/var"
- "run=/tmp/root/run"
- ;; /mnt is used as part of the installation
- ;; process, as the mount point for the target
- ;; file system, so create it.
- "mnt=/tmp/root/mnt"
- "--"
- "-volid" ,(string-upcase volume-id)
- ,@(if volume-uuid
- `("-volume_date" "uuid"
- ,(string-filter (lambda (value)
- (not (char=? #\- value)))
- (iso9660-uuid->string
- volume-uuid)))
- `())))))
+ (define grub-mkrescue
+ (string-append grub "/bin/grub-mkrescue"))
+
+ (define target-store
+ (string-append "/tmp/root" (%store-directory)))
+
+ (define items
+ ;; The store items to add to the image.
+ (delete-duplicates
+ (append-map (lambda (closure)
+ (map store-info-item
+ (call-with-input-file (string-append "/xchg/" closure)
+ read-reference-graph)))
+ closures)))
+
+ (populate-root-file-system os-drv "/tmp/root")
+ (mount (%store-directory) target-store "" MS_BIND)
+
+ (when register-closures?
+ (display "registering closures...\n")
+ (for-each (lambda (closure)
+ (register-closure
+ "/tmp/root"
+ (string-append "/xchg/" closure)
+
+ ;; TARGET-STORE is a read-only bind-mount so we shouldn't try
+ ;; to modify it.
+ #:deduplicate? #f
+ #:reset-timestamps? #f))
+ closures))
+
+ (let ((pipe
+ (apply open-pipe* OPEN_WRITE
+ grub-mkrescue "-o" target
+ (string-append "boot/grub/grub.cfg=" config-file)
+ "etc=/tmp/root/etc"
+ "var=/tmp/root/var"
+ "run=/tmp/root/run"
+ ;; /mnt is used as part of the installation
+ ;; process, as the mount point for the target
+ ;; file system, so create it.
+ "mnt=/tmp/root/mnt"
+ "-path-list" "-"
+ "--"
+ "-volid" (string-upcase volume-id)
+ (if volume-uuid
+ `("-volume_date" "uuid"
+ ,(string-filter (lambda (value)
+ (not (char=? #\- value)))
+ (iso9660-uuid->string
+ volume-uuid)))
+ `()))))
+ ;; Pass lines like 'gnu/store/…-x=/gnu/store/…-x' corresponding to the
+ ;; '-path-list -' option.
+ (for-each (lambda (item)
+ (format pipe "~a=~a~%"
+ (string-drop item 1) item))
+ items)
+ (unless (zero? (close-pipe pipe))
+ (error "oh, my! grub-mkrescue failed" grub-mkrescue))))
(define* (initialize-hard-disk device
#:key