me/guix
Archived
1
0
Fork 0
Code Activity

vm: 'make-iso9660-image' no longer includes unreferenced store items.

Browse source 
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=…".
This commit is contained in:
Ludovic Courtès 2018-06-26 13:47:30 +02:00
parent a7751eeb57
commit 718d44cc9f
No known key found for this signature in database
GPG key ID: 090B11993D9AEBB5
1 changed files with 58 additions and 35 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

93
gnu/build/vm.scm
View file

@ -34,6 +34,7 @@
#:use-module (ice-9 format) #:use-module (ice-9 format)
#:use-module (ice-9 match) #:use-module (ice-9 match)
#:use-module (ice-9 regex) #:use-module (ice-9 regex)
#:use-module (ice-9 popen)
#:use-module (srfi srfi-1) #:use-module (srfi srfi-1)
#:use-module (srfi srfi-9) #:use-module (srfi srfi-9)
#:use-module (srfi srfi-26) #:use-module (srfi srfi-26)
@ -408,44 +409,66 @@ SYSTEM-DIRECTORY is the name of the directory of the 'system' derivation."
register-closures? (closures '())) register-closures? (closures '()))
"Given a GRUB package, creates an iso image as TARGET, using CONFIG-FILE as "Given a GRUB package, creates an iso image as TARGET, using CONFIG-FILE as
GRUB configuration and OS-DRV as the stuff in it." GRUB configuration and OS-DRV as the stuff in it."
(let ((grub-mkrescue (string-append grub "/bin/grub-mkrescue")) (define grub-mkrescue
(target-store (string-append "/tmp/root" (%store-directory)))) (string-append grub "/bin/grub-mkrescue"))
(populate-root-file-system os-drv "/tmp/root")
(mount (%store-directory) target-store "" MS_BIND) (define target-store
(string-append "/tmp/root" (%store-directory)))
(when register-closures? (define items
(display "registering closures...\n") ;; The store items to add to the image.
(for-each (lambda (closure) (delete-duplicates
(register-closure (append-map (lambda (closure)
"/tmp/root" (map store-info-item
(string-append "/xchg/" closure) (call-with-input-file (string-append "/xchg/" closure)
;; TARGET-STORE is a read-only bind-mount so we shouldn't try read-reference-graph)))
;; to modify it. closures)))
#:deduplicate? #f
#:reset-timestamps? #f))
closures))
(apply invoke (populate-root-file-system os-drv "/tmp/root")
`(,grub-mkrescue "-o" ,target (mount (%store-directory) target-store "" MS_BIND)
,(string-append "boot/grub/grub.cfg=" config-file)
,(string-append "gnu/store=" os-drv "/..") (when register-closures?
"etc=/tmp/root/etc" (display "registering closures...\n")
"var=/tmp/root/var" (for-each (lambda (closure)
"run=/tmp/root/run" (register-closure
;; /mnt is used as part of the installation "/tmp/root"
;; process, as the mount point for the target (string-append "/xchg/" closure)
;; file system, so create it.
"mnt=/tmp/root/mnt" ;; TARGET-STORE is a read-only bind-mount so we shouldn't try
"--" ;; to modify it.
"-volid" ,(string-upcase volume-id) #:deduplicate? #f
,@(if volume-uuid #:reset-timestamps? #f))
`("-volume_date" "uuid" closures))
,(string-filter (lambda (value)
(not (char=? #\- value))) (let ((pipe
(iso9660-uuid->string (apply open-pipe* OPEN_WRITE
volume-uuid))) 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 (define* (initialize-hard-disk device
#:key #:key