- (define target-directory
- "/fs")
-
- (define partition
- (string-append device "1"))
-
- (initialize-partition-table device
- (- disk-image-size (* 5 (expt 2 20)))
- #:bootable? bootable?)
-
- (format-partition partition file-system-type
- #:label file-system-label)
-
- (display "mounting partition...\n")
- (mkdir target-directory)
- (mount partition target-directory file-system-type)
-
- (initialize-root-partition target-directory
- #:system-directory system-directory
- #:copy-closures? copy-closures?
- #:register-closures? register-closures?
- #:closures closures)
-
- (install-grub grub.cfg device target-directory)
-
- ;; Register GRUB.CFG as a GC root.
- (register-grub.cfg-root target-directory grub.cfg)
-
- ;; 'guix-register' resets timestamps and everything, so no need to do it
- ;; once more in that case.
- (unless register-closures?
- (reset-timestamps target-directory))
+ (lambda (target)
+ (define target-store
+ (string-append target (%store-directory)))
+
+ (when copy-closures?
+ ;; Populate the store.
+ (populate-store (map (cut string-append "/xchg/" <>) closures)
+ target))
+
+ ;; Populate /dev.
+ (make-essential-device-nodes #:root target)
+
+ ;; 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
+ ;; bind-mount the store on the target.
+ (mkdir-p target-store)
+ (mount (%store-directory) target-store "" MS_BIND))
+
+ (display "registering closures...\n")
+ (for-each (lambda (closure)
+ (register-closure target
+ (string-append "/xchg/" closure)))
+ closures)
+ (unless copy-closures?
+ (umount target-store)))
+
+ ;; Add the non-store directories and files.
+ (display "populating...\n")
+ (populate-root-file-system system-directory target)
+
+ ;; 'guix-register' resets timestamps and everything, so no need to do it
+ ;; once more in that case.
+ (unless register-closures?
+ (reset-timestamps target))))
+
+(define (register-bootcfg-root target bootcfg)
+ "On file system TARGET, register BOOTCFG as a GC root."
+ (let ((directory (string-append target "/var/guix/gcroots")))
+ (mkdir-p directory)
+ (symlink bootcfg (string-append directory "/bootcfg"))))
+
+(define (install-efi grub esp config-file)
+ "Write a self-contained GRUB EFI loader to the mounted ESP using CONFIG-FILE."
+ (let* ((system %host-type)
+ ;; Hard code the output location to a well-known path recognized by
+ ;; compliant firmware. See "3.5.1.1 Removable Media Boot Behaviour":
+ ;; http://www.uefi.org/sites/default/files/resources/UEFI%20Spec%202_6.pdf
+ (grub-mkstandalone (string-append grub "/bin/grub-mkstandalone"))
+ (efi-directory (string-append esp "/EFI/BOOT"))
+ ;; Map grub target names to boot file names.
+ (efi-targets (cond ((string-prefix? "x86_64" system)
+ '("x86_64-efi" . "BOOTX64.EFI"))
+ ((string-prefix? "i686" system)
+ '("i386-efi" . "BOOTIA32.EFI"))
+ ((string-prefix? "armhf" system)
+ '("arm-efi" . "BOOTARM.EFI"))
+ ((string-prefix? "aarch64" system)
+ '("arm64-efi" . "BOOTAA64.EFI")))))
+ ;; grub-mkstandalone requires a TMPDIR to prepare the firmware image.
+ (setenv "TMPDIR" esp)
+
+ (mkdir-p efi-directory)
+ (unless (zero? (system* grub-mkstandalone "-O" (car efi-targets)
+ "-o" (string-append efi-directory "/"
+ (cdr efi-targets))
+ ;; Graft the configuration file onto the image.
+ (string-append "boot/grub/grub.cfg=" config-file)))
+ (error "failed to create GRUB EFI image"))))
+
+(define* (make-iso9660-image grub config-file os-drv target
+ #:key (volume-id "GuixSD"))
+ "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")))
+ (mkdir-p "/tmp/root/var/run")
+ (mkdir-p "/tmp/root/run")
+ (unless (zero? (system* grub-mkrescue "-o" target
+ (string-append "boot/grub/grub.cfg=" config-file)
+ (string-append "gnu/store=" os-drv "/..")
+ "var=/tmp/root/var"
+ "run=/tmp/root/run"
+ "--" "-volid" (string-upcase volume-id)))
+ (error "failed to create ISO image"))))