me
/
guix
Archived
1
0
Fork 0
This repository has been archived on 2024-08-07. You can view files and clone it, but cannot push or open issues/pull-requests.
guix/gnu/build/image.scm

274 lines
11 KiB
Scheme
Raw Blame History

This file contains ambiguous Unicode characters!

This file contains ambiguous Unicode characters that may be confused with others in your current locale. If your use case is intentional and legitimate, you can safely ignore this warning. Use the Escape button to highlight these characters.

;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2016 Christopher Allan Webber <cwebber@dustycloud.org>
;;; Copyright © 2016, 2017 Leo Famulari <leo@famulari.name>
;;; Copyright © 2017 Marius Bakke <mbakke@fastmail.com>
;;; Copyright © 2020 Tobias Geerinckx-Rice <me@tobias.gr>
;;; Copyright © 2020 Mathieu Othacehe <m.othacehe@gmail.com>
;;;
;;; 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 (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
genimage
initialize-efi-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 label uuid)
(partition (size size)
(file-system file-system)
(label label)
(uuid uuid)))))
(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, evalute and return its size. As this doesn't
take the partition metadata size into account, take a 25% margin."
(* 1.25 (file-size root)))
(define* (make-ext4-image partition target root
#:key
(owner-uid 0)
(owner-gid 0))
"Handle the creation of EXT4 partition images. See 'make-partition-image'."
(let ((size (partition-size partition))
(label (partition-label partition))
(uuid (partition-uuid partition))
(options "lazy_itable_init=1,lazy_journal_init=1"))
(invoke "mke2fs" "-t" "ext4" "-d" root
"-L" label "-U" (uuid->string uuid)
"-E" (format #f "root_owner=~a:~a,~a"
owner-uid owner-gid options)
target
(format #f "~ak"
(size-in-kib
(if (eq? size 'guess)
(estimate-partition-size root)
size))))))
(define* (make-vfat-image partition target root)
"Handle the creation of VFAT partition images. See 'make-partition-image'."
(let ((size (partition-size partition))
(label (partition-label partition)))
(invoke "mkdosfs" "-n" label "-C" target "-F" "16" "-S" "1024"
(size-in-kib
(if (eq? size 'guess)
(estimate-partition-size root)
size)))
(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=? type "ext4")
(make-ext4-image partition target root))
((string=? type "vfat")
(make-vfat-image partition target root))
(else
(format (current-error-port)
"Unsupported partition type~%.")))))
(define* (genimage config target)
"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
"--outputpath" target))
(define* (register-closure prefix closure
#:key
(deduplicate? #t) (reset-timestamps? #t)
(schema (sql-schema)))
"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.. As a side effect, if RESET-TIMESTAMPS? is
true, reset timestamps on store files and, if DEDUPLICATE? is true,
deduplicates files common to CLOSURE and the rest of PREFIX."
(let ((items (call-with-input-file closure read-reference-graph)))
(register-items items
#:prefix prefix
#:deduplicate? deduplicate?
#:reset-timestamps? reset-timestamps?
#:registration-time %epoch
#:schema schema)))
(define* (initialize-efi-partition root
#:key
bootloader-package
#:allow-other-keys)
"Install in ROOT directory, an EFI loader using BOOTLOADER-PACKAGE."
(install-efi-loader bootloader-package root))
(define* (initialize-root-partition root
#:key
bootcfg
bootcfg-location
(deduplicate? #t)
references-graphs
(register-closures? #t)
system-directory
#:allow-other-keys)
"Initialize the given ROOT directory. Use BOOTCFG and BOOTCFG-LOCATION to
install the bootloader configuration.
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."
(populate-root-file-system system-directory root)
(populate-store references-graphs root)
(when register-closures?
(for-each (lambda (closure)
(register-closure root
closure
#:reset-timestamps? #t
#:deduplicate? deduplicate?))
references-graphs))
(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)))
'()))))