[jackhill/guix/guix.git] / gnu / build / image.scm

;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2016 Christine Lemmer-Webber <cwebber@dustycloud.org>
;;; Copyright © 2016, 2017 Leo Famulari <leo@famulari.name>
;;; Copyright © 2017 Marius Bakke <mbakke@fastmail.com>
;;; Copyright © 2020, 2022 Tobias Geerinckx-Rice <me@tobias.gr>
;;; Copyright © 2020 Mathieu Othacehe <m.othacehe@gmail.com>
;;; Copyright © 2022 Pavel Shlyak <p.shlyak@pantherx.org>
;;; Copyright © 2022 Denis 'GNUtoo' Carikli <GNUtoo@cyberdimension.org>
;;;
;;; This file is part of GNU Guix.
;;;
;;; GNU Guix is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; GNU Guix is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.

(define-module (gnu build image)
  #:use-module (guix build store-copy)
  #:use-module (guix build syscalls)
  #:use-module (guix build utils)
  #:use-module (guix store database)
  #:use-module (guix utils)
  #:use-module (gnu build bootloader)
  #:use-module (gnu build install)
  #:use-module (gnu build linux-boot)
  #:use-module (gnu image)
  #:use-module (gnu system uuid)
  #:use-module (ice-9 ftw)
  #:use-module (ice-9 match)
  #:use-module (srfi srfi-19)
  #:use-module (srfi srfi-34)
  #:use-module (srfi srfi-35)
  #:export (make-partition-image
            convert-disk-image
            genimage
            initialize-efi-partition
            initialize-efi32-partition
            initialize-root-partition

            make-iso9660-image))

(define (sexp->partition sexp)
  "Take SEXP, a tuple as returned by 'partition->gexp', and turn it into a
<partition> record."
  (match sexp
    ((size file-system file-system-options label uuid flags)
     (partition (size size)
                (file-system file-system)
                (file-system-options file-system-options)
                (label label)
                (uuid uuid)
                (flags flags)))))

(define (size-in-kib size)
  "Convert SIZE expressed in bytes, to kilobytes and return it as a string."
  (number->string
   (inexact->exact (ceiling (/ size 1024)))))

(define (estimate-partition-size root)
  "Given the ROOT directory, evaluate and return its size.  As this doesn't
take the partition metadata size into account, take a 25% margin.  As this in
turn doesn't take any constant overhead into account, force a 1-MiB minimum."
  (max (ash 1 20)
       (* 1.25 (file-size root))))

(define* (make-ext-image partition target root
                         #:key
                         (owner-uid 0)
                         (owner-gid 0))
  "Handle the creation of EXT2/3/4 partition images. See
'make-partition-image'."
  (let ((size (partition-size partition))
        (fs (partition-file-system partition))
        (fs-options (partition-file-system-options partition))
        (label (partition-label partition))
        (uuid (partition-uuid partition))
        (journal-options "lazy_itable_init=1,lazy_journal_init=1"))
    (apply invoke
           `("fakeroot" "mke2fs" "-t" ,fs "-d" ,root
             "-L" ,label
             ,@(if uuid
                   `("-U" ,(uuid->string uuid))
                   '())
             "-E" ,(format #f "root_owner=~a:~a,~a"
                           owner-uid owner-gid journal-options)
             ,@fs-options
             ,target
             ,(format #f "~ak"
                      (size-in-kib
                       (if (eq? size 'guess)
                           (estimate-partition-size root)
                           size)))))))

(define* (make-vfat-image partition target root fs-bits)
  "Handle the creation of VFAT partition images.  See 'make-partition-image'."
  (let ((size (partition-size partition))
        (label (partition-label partition))
        (flags (partition-flags partition)))
    (apply invoke "fakeroot" "mkdosfs" "-n" label "-C" target
                          "-F" (number->string fs-bits)
                          (size-in-kib
                           (if (eq? size 'guess)
                               (estimate-partition-size root)
                               size))
                    (if (member 'esp flags) (list "-S" "1024") '()))
    (for-each (lambda (file)
                (unless (member file '("." ".."))
                  (invoke "mcopy" "-bsp" "-i" target
                          (string-append root "/" file)
                          (string-append "::" file))))
              (scandir root))))

(define* (make-partition-image partition-sexp target root)
  "Create and return the image of PARTITION-SEXP as TARGET.  Use the given
ROOT directory to populate the image."
  (let* ((partition (sexp->partition partition-sexp))
         (type (partition-file-system partition)))
    (cond
     ((string-prefix? "ext" type)
      (make-ext-image partition target root))
     ((or (string=? type "vfat") (string=? type "fat16"))
      (make-vfat-image partition target root 16))
     ((string=? type "fat32")
      (make-vfat-image partition target root 32))
     (else
      (raise (condition
              (&message
               (message "unsupported partition type"))))))))

(define (convert-disk-image image format output)
  "Convert IMAGE to OUTPUT according to the given FORMAT."
  (case format
    ((compressed-qcow2)
     (invoke "qemu-img" "convert" "-c" "-f" "raw"
             "-O" "qcow2" image output))
    (else
     (copy-file image output))))

(define* (genimage config)
  "Use genimage to generate in TARGET directory, the image described in the
given CONFIG file."
  ;; genimage needs a 'root' directory.
  (mkdir "root")
  (invoke "genimage" "--config" config))

(define* (register-closure prefix closure
                           #:key
                           (schema (sql-schema))
                           (wal-mode? #t))
  "Register CLOSURE in PREFIX, where PREFIX is the directory name of the
target store and CLOSURE is the name of a file containing a reference graph as
produced by #:references-graphs.  Pass WAL-MODE? to call-with-database."
  (let ((items (call-with-input-file closure read-reference-graph)))
    (parameterize ((sql-schema schema))
      (with-database (store-database-file #:prefix prefix) db
       #:wal-mode? wal-mode?
       (register-items db items
                       #:prefix prefix
                       #:registration-time %epoch)))))

(define* (initialize-efi-partition root
                                   #:key
                                   grub-efi
                                   #:allow-other-keys)
  "Install in ROOT directory, an EFI loader using GRUB-EFI."
  (install-efi-loader grub-efi root))

(define* (initialize-efi32-partition root
                                     #:key
                                     grub-efi32
                                     #:allow-other-keys)
  "Install in ROOT directory, an EFI 32bit loader using GRUB-EFI32."
  (install-efi-loader grub-efi32 root
                      #:targets (cond ((target-x86?)
                                       '("i386-efi" . "BOOTIA32.EFI"))
                                      ((target-arm?)
                                       '("arm-efi" . "BOOTARM.EFI")))))

(define* (initialize-root-partition root
                                    #:key
                                    bootcfg
                                    bootcfg-location
                                    bootloader-package
                                    bootloader-installer
                                    (copy-closures? #t)
                                    (deduplicate? #t)
                                    references-graphs
                                    (register-closures? #t)
                                    system-directory
                                    make-device-nodes
                                    (wal-mode? #t)
                                    #:allow-other-keys)
  "Initialize the given ROOT directory. Use BOOTCFG and BOOTCFG-LOCATION to
install the bootloader configuration.

If COPY-CLOSURES? is true, copy all of REFERENCES-GRAPHS to the partition.  If
REGISTER-CLOSURES? is true, register REFERENCES-GRAPHS in the store.  If
DEDUPLICATE? is true, then also deduplicate files common to CLOSURES and the
rest of the store when registering the closures.  SYSTEM-DIRECTORY is the name
of the directory of the 'system' derivation.  Pass WAL-MODE? to
register-closure."
  (define root-store
    (string-append root (%store-directory)))

  (define tmp-store ".tmp-store")

  (populate-root-file-system system-directory root)

  (when copy-closures?
    (populate-store references-graphs root
                    #:deduplicate? deduplicate?))

  ;; Populate /dev.
  (when make-device-nodes
    (make-device-nodes root))

  (when register-closures?
    (unless copy-closures?
      ;; XXX: 'register-closure' wants to palpate the things it registers, so
      ;; create a symlink to the store.
      (rename-file root-store tmp-store)
      (symlink (%store-directory) root-store))

    (for-each (lambda (closure)
                (register-closure root closure
                                  #:wal-mode? wal-mode?))
              references-graphs)

    (unless copy-closures?
      (delete-file root-store)
      (rename-file tmp-store root-store)))

  ;; There's no point installing a bootloader if we do not populate the store.
  (when copy-closures?
    (when bootloader-installer
      (display "installing bootloader...\n")
      (bootloader-installer bootloader-package #f root))
    (when bootcfg
      (install-boot-config bootcfg bootcfg-location root))))

(define* (make-iso9660-image xorriso grub-mkrescue-environment
                             grub bootcfg system-directory root target
                             #:key (volume-id "Guix_image") (volume-uuid #f)
                             register-closures? (references-graphs '())
                             (compression? #t))
  "Given a GRUB package, creates an iso image as TARGET, using BOOTCFG as
GRUB configuration and OS-DRV as the stuff in it."
  (define grub-mkrescue
    (string-append grub "/bin/grub-mkrescue"))

  (define grub-mkrescue-sed.sh
    (string-append (getcwd) "/" "grub-mkrescue-sed.sh"))

  ;; Use a modified version of grub-mkrescue-sed.sh, see below.
  (copy-file (string-append xorriso
                            "/bin/grub-mkrescue-sed.sh")
             grub-mkrescue-sed.sh)

  ;; Force grub-mkrescue-sed.sh to use the build directory instead of /tmp
  ;; that is read-only inside the build container.
  (substitute* grub-mkrescue-sed.sh
    (("/tmp/") (string-append (getcwd) "/"))
    (("MKRESCUE_SED_XORRISO_ARGS \\$x")
     (format #f "MKRESCUE_SED_XORRISO_ARGS $(echo $x | sed \"s|/tmp|~a|\")"
             (getcwd))))

  ;; 'grub-mkrescue' calls out to mtools programs to create 'efi.img', a FAT
  ;; file system image, and mtools honors SOURCE_DATE_EPOCH for the mtime of
  ;; those files.  The epoch for FAT is Jan. 1st 1980, not 1970, so choose
  ;; that.
  (setenv "SOURCE_DATE_EPOCH"
          (number->string
           (time-second
            (date->time-utc (make-date 0 0 0 0 1 1 1980 0)))))

  ;; Our patched 'grub-mkrescue' honors this environment variable and passes
  ;; it to 'mformat', which makes it the serial number of 'efi.img'.  This
  ;; allows for deterministic builds.
  (setenv "GRUB_FAT_SERIAL_NUMBER"
          (number->string (if volume-uuid

                              ;; On 32-bit systems the 2nd argument must be
                              ;; lower than 2^32.
                              (string-hash (iso9660-uuid->string volume-uuid)
                                           (- (expt 2 32) 1))

                              #x77777777)
                          16))

  (setenv "MKRESCUE_SED_MODE" "original")
  (setenv "MKRESCUE_SED_XORRISO" (string-append xorriso "/bin/xorriso"))
  (setenv "MKRESCUE_SED_IN_EFI_NO_PT" "yes")

  (for-each (match-lambda
              ((name . value) (setenv name value)))
            grub-mkrescue-environment)

  (apply invoke grub-mkrescue
         (string-append "--xorriso=" grub-mkrescue-sed.sh)
         "-o" target
         (string-append "boot/grub/grub.cfg=" bootcfg)
         root
         "--"
         ;; Set all timestamps to 1.
         "-volume_date" "all_file_dates" "=1"

         `(,@(if compression?
                 '(;; ‘zisofs’ compression reduces the total image size by
                   ;; ~60%.
                   "-zisofs" "level=9:block_size=128k" ; highest compression
                   ;; It's transparent to our Linux-Libre kernel but not to
                   ;; GRUB.  Don't compress the kernel, initrd, and other
                   ;; files read by grub.cfg, as well as common
                   ;; already-compressed file names.
                   "-find" "/" "-type" "f"
                   ;; XXX Even after "--" above, and despite documentation
                   ;; claiming otherwise, "-or" is stolen by grub-mkrescue
                   ;; which then chokes on it (as ‘-o …’) and dies.  Don't use
                   ;; "-or".
                   "-not" "-wholename" "/boot/*"
                   "-not" "-wholename" "/System/*"
                   "-not" "-name" "unicode.pf2"
                   "-not" "-name" "bzImage"
                   "-not" "-name" "*.gz"   ; initrd & all man pages
                   "-not" "-name" "*.png"  ; includes grub-image.png
                   "-exec" "set_filter" "--zisofs"
                   "--")
                 '())
           "-volid" ,(string-upcase volume-id)
           ,@(if volume-uuid
             `("-volume_date" "uuid"
               ,(string-filter (lambda (value)
                                 (not (char=? #\- value)))
                               (iso9660-uuid->string
                                volume-uuid)))
             '()))))
Commit	Line	Data
f19cf27c MO	1	;;; GNU Guix --- Functional package management for GNU
f19cf27c MO	2	;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
94551439	3	;;; Copyright © 2016 Christine Lemmer-Webber <cwebber@dustycloud.org>
f19cf27c MO	4	;;; Copyright © 2016, 2017 Leo Famulari <leo@famulari.name>
f19cf27c MO	5	;;; Copyright © 2017 Marius Bakke <mbakke@fastmail.com>
472680a2	6	;;; Copyright © 2020, 2022 Tobias Geerinckx-Rice <me@tobias.gr>
f19cf27c	7	;;; Copyright © 2020 Mathieu Othacehe <m.othacehe@gmail.com>
bb662d71	8	;;; Copyright © 2022 Pavel Shlyak <p.shlyak@pantherx.org>
62c86c83	9	;;; Copyright © 2022 Denis 'GNUtoo' Carikli <GNUtoo@cyberdimension.org>
f19cf27c MO	10	;;;
	11	;;; This file is part of GNU Guix.
	12	;;;
	13	;;; GNU Guix is free software; you can redistribute it and/or modify it
	14	;;; under the terms of the GNU General Public License as published by
	15	;;; the Free Software Foundation; either version 3 of the License, or (at
	16	;;; your option) any later version.
	17	;;;
	18	;;; GNU Guix is distributed in the hope that it will be useful, but
	19	;;; WITHOUT ANY WARRANTY; without even the implied warranty of
	20	;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
	21	;;; GNU General Public License for more details.
	22	;;;
	23	;;; You should have received a copy of the GNU General Public License
	24	;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
	25
	26	(define-module (gnu build image)
	27	#:use-module (guix build store-copy)
	28	#:use-module (guix build syscalls)
	29	#:use-module (guix build utils)
	30	#:use-module (guix store database)
62c86c83	31	#:use-module (guix utils)
f19cf27c MO	32	#:use-module (gnu build bootloader)
	33	#:use-module (gnu build install)
	34	#:use-module (gnu build linux-boot)
	35	#:use-module (gnu image)
	36	#:use-module (gnu system uuid)
	37	#:use-module (ice-9 ftw)
	38	#:use-module (ice-9 match)
	39	#:use-module (srfi srfi-19)
	40	#:use-module (srfi srfi-34)
	41	#:use-module (srfi srfi-35)
	42	#:export (make-partition-image
f441e3e8	43	convert-disk-image
f19cf27c MO	44	genimage
f19cf27c MO	45	initialize-efi-partition
62c86c83	46	initialize-efi32-partition
f19cf27c MO	47	initialize-root-partition
	48
	49	make-iso9660-image))
	50
	51	(define (sexp->partition sexp)
	52	"Take SEXP, a tuple as returned by 'partition->gexp', and turn it into a
	53	<partition> record."
	54	(match sexp
bb662d71	55	((size file-system file-system-options label uuid flags)
f19cf27c MO	56	(partition (size size)
f19cf27c MO	57	(file-system file-system)
bd3716f6	58	(file-system-options file-system-options)
f19cf27c	59	(label label)
bb662d71 PS	60	(uuid uuid)
bb662d71 PS	61	(flags flags)))))
f19cf27c MO	62
	63	(define (size-in-kib size)
	64	"Convert SIZE expressed in bytes, to kilobytes and return it as a string."
	65	(number->string
	66	(inexact->exact (ceiling (/ size 1024)))))
	67
	68	(define (estimate-partition-size root)
65b86c71	69	"Given the ROOT directory, evaluate and return its size. As this doesn't
472680a2 TGR	70	take the partition metadata size into account, take a 25% margin. As this in
	71	turn doesn't take any constant overhead into account, force a 1-MiB minimum."
	72	(max (ash 1 20)
	73	(* 1.25 (file-size root))))
f19cf27c	74
16f9124d MO	75	(define* (make-ext-image partition target root
	76	#:key
	77	(owner-uid 0)
	78	(owner-gid 0))
	79	"Handle the creation of EXT2/3/4 partition images. See
	80	'make-partition-image'."
f19cf27c	81	(let ((size (partition-size partition))
16f9124d	82	(fs (partition-file-system partition))
bd3716f6	83	(fs-options (partition-file-system-options partition))
f19cf27c MO	84	(label (partition-label partition))
f19cf27c MO	85	(uuid (partition-uuid partition))
bd3716f6 MO	86	(journal-options "lazy_itable_init=1,lazy_journal_init=1"))
bd3716f6 MO	87	(apply invoke
7f75a7ec	88	`("fakeroot" "mke2fs" "-t" ,fs "-d" ,root
192b7d0c MO	89	"-L" ,label
	90	,@(if uuid
	91	`("-U" ,(uuid->string uuid))
	92	'())
bd3716f6 MO	93	"-E" ,(format #f "root_owner=~a:~a,~a"
	94	owner-uid owner-gid journal-options)
	95	,@fs-options
	96	,target
	97	,(format #f "~ak"
	98	(size-in-kib
	99	(if (eq? size 'guess)
	100	(estimate-partition-size root)
	101	size)))))))
f19cf27c	102
8b680b00	103	(define* (make-vfat-image partition target root fs-bits)
f19cf27c MO	104	"Handle the creation of VFAT partition images. See 'make-partition-image'."
f19cf27c MO	105	(let ((size (partition-size partition))
8b680b00 PS	106	(label (partition-label partition))
	107	(flags (partition-flags partition)))
	108	(apply invoke "fakeroot" "mkdosfs" "-n" label "-C" target
	109	"-F" (number->string fs-bits)
	110	(size-in-kib
	111	(if (eq? size 'guess)
	112	(estimate-partition-size root)
	113	size))
	114	(if (member 'esp flags) (list "-S" "1024") '()))
f19cf27c MO	115	(for-each (lambda (file)
	116	(unless (member file '("." ".."))
	117	(invoke "mcopy" "-bsp" "-i" target
	118	(string-append root "/" file)
	119	(string-append "::" file))))
	120	(scandir root))))
	121
	122	(define* (make-partition-image partition-sexp target root)
	123	"Create and return the image of PARTITION-SEXP as TARGET. Use the given
	124	ROOT directory to populate the image."
	125	(let* ((partition (sexp->partition partition-sexp))
	126	(type (partition-file-system partition)))
	127	(cond
16f9124d MO	128	((string-prefix? "ext" type)
16f9124d MO	129	(make-ext-image partition target root))
8b680b00 PS	130	((or (string=? type "vfat") (string=? type "fat16"))
	131	(make-vfat-image partition target root 16))
	132	((string=? type "fat32")
	133	(make-vfat-image partition target root 32))
f19cf27c	134	(else
61d9c445 LC	135	(raise (condition
	136	(&message
	137	(message "unsupported partition type"))))))))
f19cf27c	138
f441e3e8 MO	139	(define (convert-disk-image image format output)
	140	"Convert IMAGE to OUTPUT according to the given FORMAT."
	141	(case format
	142	((compressed-qcow2)
61d9c445 LC	143	(invoke "qemu-img" "convert" "-c" "-f" "raw"
61d9c445 LC	144	"-O" "qcow2" image output))
f441e3e8 MO	145	(else
	146	(copy-file image output))))
	147
	148	(define* (genimage config)
f19cf27c MO	149	"Use genimage to generate in TARGET directory, the image described in the
	150	given CONFIG file."
	151	;; genimage needs a 'root' directory.
	152	(mkdir "root")
f441e3e8	153	(invoke "genimage" "--config" config))
f19cf27c MO	154
	155	(define* (register-closure prefix closure
	156	#:key
4b9eecd3 JN	157	(schema (sql-schema))
4b9eecd3 JN	158	(wal-mode? #t))
f19cf27c MO	159	"Register CLOSURE in PREFIX, where PREFIX is the directory name of the
f19cf27c MO	160	target store and CLOSURE is the name of a file containing a reference graph as
2aa512ec	161	produced by #:references-graphs. Pass WAL-MODE? to call-with-database."
f19cf27c	162	(let ((items (call-with-input-file closure read-reference-graph)))
97a46055 LC	163	(parameterize ((sql-schema schema))
97a46055 LC	164	(with-database (store-database-file #:prefix prefix) db
4b9eecd3 JN	165	#:wal-mode? wal-mode?
	166	(register-items db items
	167	#:prefix prefix
4b9eecd3	168	#:registration-time %epoch)))))
f19cf27c MO	169
	170	(define* (initialize-efi-partition root
	171	#:key
05f37c16	172	grub-efi
f19cf27c	173	#:allow-other-keys)
72d1562a	174	"Install in ROOT directory, an EFI loader using GRUB-EFI."
05f37c16	175	(install-efi-loader grub-efi root))
f19cf27c	176
62c86c83 DGC	177	(define* (initialize-efi32-partition root
	178	#:key
	179	grub-efi32
	180	#:allow-other-keys)
	181	"Install in ROOT directory, an EFI 32bit loader using GRUB-EFI32."
	182	(install-efi-loader grub-efi32 root
	183	#:targets (cond ((target-x86?)
	184	'("i386-efi" . "BOOTIA32.EFI"))
	185	((target-arm?)
	186	'("arm-efi" . "BOOTARM.EFI")))))
	187
f19cf27c MO	188	(define* (initialize-root-partition root
	189	#:key
	190	bootcfg
	191	bootcfg-location
9c1adb24 MO	192	bootloader-package
9c1adb24 MO	193	bootloader-installer
cc4e8a84	194	(copy-closures? #t)
f19cf27c MO	195	(deduplicate? #t)
	196	references-graphs
	197	(register-closures? #t)
	198	system-directory
8423c2d3	199	make-device-nodes
4b9eecd3	200	(wal-mode? #t)
f19cf27c MO	201	#:allow-other-keys)
	202	"Initialize the given ROOT directory. Use BOOTCFG and BOOTCFG-LOCATION to
	203	install the bootloader configuration.
	204
cc4e8a84 MO	205	If COPY-CLOSURES? is true, copy all of REFERENCES-GRAPHS to the partition. If
cc4e8a84 MO	206	REGISTER-CLOSURES? is true, register REFERENCES-GRAPHS in the store. If
f19cf27c	207	DEDUPLICATE? is true, then also deduplicate files common to CLOSURES and the
4b9eecd3 JN	208	rest of the store when registering the closures. SYSTEM-DIRECTORY is the name
	209	of the directory of the 'system' derivation. Pass WAL-MODE? to
	210	register-closure."
cc4e8a84 MO	211	(define root-store
	212	(string-append root (%store-directory)))
	213
	214	(define tmp-store ".tmp-store")
	215
f19cf27c	216	(populate-root-file-system system-directory root)
cc4e8a84 MO	217
	218	(when copy-closures?
	219	(populate-store references-graphs root
	220	#:deduplicate? deduplicate?))
f19cf27c	221
c77b9285	222	;; Populate /dev.
8423c2d3 MO	223	(when make-device-nodes
8423c2d3 MO	224	(make-device-nodes root))
c77b9285	225
f19cf27c	226	(when register-closures?
cc4e8a84 MO	227	(unless copy-closures?
	228	;; XXX: 'register-closure' wants to palpate the things it registers, so
	229	;; create a symlink to the store.
	230	(rename-file root-store tmp-store)
	231	(symlink (%store-directory) root-store))
	232
f19cf27c	233	(for-each (lambda (closure)
7b8d239e	234	(register-closure root closure
4b9eecd3	235	#:wal-mode? wal-mode?))
cc4e8a84 MO	236	references-graphs)
	237
	238	(unless copy-closures?
	239	(delete-file root-store)
	240	(rename-file tmp-store root-store)))
	241
	242	;; There's no point installing a bootloader if we do not populate the store.
	243	(when copy-closures?
	244	(when bootloader-installer
	245	(display "installing bootloader...\n")
	246	(bootloader-installer bootloader-package #f root))
	247	(when bootcfg
	248	(install-boot-config bootcfg bootcfg-location root))))
f19cf27c MO	249
	250	(define* (make-iso9660-image xorriso grub-mkrescue-environment
	251	grub bootcfg system-directory root target
	252	#:key (volume-id "Guix_image") (volume-uuid #f)
	253	register-closures? (references-graphs '())
	254	(compression? #t))
	255	"Given a GRUB package, creates an iso image as TARGET, using BOOTCFG as
	256	GRUB configuration and OS-DRV as the stuff in it."
	257	(define grub-mkrescue
	258	(string-append grub "/bin/grub-mkrescue"))
	259
	260	(define grub-mkrescue-sed.sh
	261	(string-append (getcwd) "/" "grub-mkrescue-sed.sh"))
	262
	263	;; Use a modified version of grub-mkrescue-sed.sh, see below.
	264	(copy-file (string-append xorriso
	265	"/bin/grub-mkrescue-sed.sh")
	266	grub-mkrescue-sed.sh)
	267
	268	;; Force grub-mkrescue-sed.sh to use the build directory instead of /tmp
	269	;; that is read-only inside the build container.
	270	(substitute* grub-mkrescue-sed.sh
	271	(("/tmp/") (string-append (getcwd) "/"))
	272	(("MKRESCUE_SED_XORRISO_ARGS \\$x")
	273	(format #f "MKRESCUE_SED_XORRISO_ARGS $(echo $x \| sed \"s\|/tmp\|~a\|\")"
	274	(getcwd))))
	275
	276	;; 'grub-mkrescue' calls out to mtools programs to create 'efi.img', a FAT
	277	;; file system image, and mtools honors SOURCE_DATE_EPOCH for the mtime of
	278	;; those files. The epoch for FAT is Jan. 1st 1980, not 1970, so choose
	279	;; that.
	280	(setenv "SOURCE_DATE_EPOCH"
	281	(number->string
	282	(time-second
	283	(date->time-utc (make-date 0 0 0 0 1 1 1980 0)))))
	284
	285	;; Our patched 'grub-mkrescue' honors this environment variable and passes
	286	;; it to 'mformat', which makes it the serial number of 'efi.img'. This
	287	;; allows for deterministic builds.
	288	(setenv "GRUB_FAT_SERIAL_NUMBER"
	289	(number->string (if volume-uuid
	290
	291	;; On 32-bit systems the 2nd argument must be
	292	;; lower than 2^32.
	293	(string-hash (iso9660-uuid->string volume-uuid)
	294	(- (expt 2 32) 1))
	295
	296	#x77777777)
	297	16))
	298
	299	(setenv "MKRESCUE_SED_MODE" "original")
	300	(setenv "MKRESCUE_SED_XORRISO" (string-append xorriso "/bin/xorriso"))
	301	(setenv "MKRESCUE_SED_IN_EFI_NO_PT" "yes")
	302
	303	(for-each (match-lambda
	304	((name . value) (setenv name value)))
	305	grub-mkrescue-environment)
	306
	307	(apply invoke grub-mkrescue
	308	(string-append "--xorriso=" grub-mkrescue-sed.sh)
	309	"-o" target
	310	(string-append "boot/grub/grub.cfg=" bootcfg)
	311	root
	312	"--"
313	;; Set all timestamps to 1.
314	"-volume_date" "all_file_dates" "=1"
315
316	`(,@(if compression?
317	'(;; ‘zisofs’ compression reduces the total image size by
318	;; ~60%.
319	"-zisofs" "level=9:block_size=128k" ; highest compression
320	;; It's transparent to our Linux-Libre kernel but not to
321	;; GRUB. Don't compress the kernel, initrd, and other
322	;; files read by grub.cfg, as well as common
323	;; already-compressed file names.
324	"-find" "/" "-type" "f"
325	;; XXX Even after "--" above, and despite documentation
326	;; claiming otherwise, "-or" is stolen by grub-mkrescue
327	;; which then chokes on it (as ‘-o …’) and dies. Don't use
328	;; "-or".
329	"-not" "-wholename" "/boot/*"
330	"-not" "-wholename" "/System/*"
331	"-not" "-name" "unicode.pf2"
332	"-not" "-name" "bzImage"
333	"-not" "-name" "*.gz" ; initrd & all man pages
334	"-not" "-name" "*.png" ; includes grub-image.png
335	"-exec" "set_filter" "--zisofs"
336	"--")
337	'())
338	"-volid" ,(string-upcase volume-id)
339	,@(if volume-uuid
340	`("-volume_date" "uuid"
341	,(string-filter (lambda (value)
342	(not (char=? #\- value)))
343	(iso9660-uuid->string
344	volume-uuid)))
345	'()))))