gnu/build/image.scm

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