diff options
Diffstat (limited to 'gnu/build/vm.scm')
| -rw-r--r-- | gnu/build/vm.scm | 104 |
1 files changed, 66 insertions, 38 deletions
diff --git a/gnu/build/vm.scm b/gnu/build/vm.scm index fa3ce7790d..abecc8c470 100644 --- a/gnu/build/vm.scm +++ b/gnu/build/vm.scm @@ -25,6 +25,7 @@ #:use-module (guix build utils) #:use-module (guix build store-copy) #:use-module (guix build syscalls) + #:use-module ((guix store database) #:select (reset-timestamps)) #:use-module (gnu build linux-boot) #:use-module (gnu build install) #:use-module (gnu system uuid) @@ -33,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) @@ -345,7 +347,7 @@ SYSTEM-DIRECTORY is the name of the directory of the 'system' derivation." ;; Optionally, register the inputs in the image's store. (when register-closures? (unless copy-closures? - ;; XXX: 'guix-register' wants to palpate the things it registers, so + ;; XXX: 'register-closure' wants to palpate the things it registers, so ;; bind-mount the store on the target. (mkdir-p target-store) (mount (%store-directory) target-store "" MS_BIND)) @@ -354,6 +356,7 @@ SYSTEM-DIRECTORY is the name of the directory of the 'system' derivation." (for-each (lambda (closure) (register-closure target (string-append "/xchg/" closure) + #:reset-timestamps? copy-closures? #:deduplicate? deduplicate?)) closures) (unless copy-closures? @@ -363,7 +366,7 @@ SYSTEM-DIRECTORY is the name of the directory of the 'system' derivation." (display "populating...\n") (populate-root-file-system system-directory target) - ;; 'guix-register' resets timestamps and everything, so no need to do it + ;; 'register-closure' resets timestamps and everything, so no need to do it ;; once more in that case. (unless register-closures? (reset-timestamps target)))) @@ -406,42 +409,67 @@ 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) - ;; XXX: Using deduplication causes cross device link errors. - #:deduplicate? #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) + (register-bootcfg-root "/tmp/root" config-file)) + + (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 |