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 Christine Lemmer-Webber <cwebber@dustycloud.org>
   4 ;;; Copyright © 2016, 2017 Leo Famulari <leo@famulari.name>
   5 ;;; Copyright © 2017 Marius Bakke <mbakke@fastmail.com>
   6 ;;; Copyright © 2020, 2022 Tobias Geerinckx-Rice <me@tobias.gr>
   7 ;;; Copyright © 2020 Mathieu Othacehe <m.othacehe@gmail.com>
   8 ;;; Copyright © 2022 Pavel Shlyak <p.shlyak@pantherx.org>
   9 ;;; Copyright © 2022 Denis 'GNUtoo' Carikli <GNUtoo@cyberdimension.org>
  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)
  31   #:use-module (guix utils)
  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
  43             convert-disk-image
  44             genimage
  45             initialize-efi-partition
  46             initialize-efi32-partition
  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
  55     ((size file-system file-system-options label uuid flags)
  56      (partition (size size)
  57                 (file-system file-system)
  58                 (file-system-options file-system-options)
  59                 (label label)
  60                 (uuid uuid)
  61                 (flags flags)))))
  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)
  69   "Given the ROOT directory, evaluate and return its size.  As this doesn't
  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))))
  74
  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'."
  81   (let ((size (partition-size partition))
  82         (fs (partition-file-system partition))
  83         (fs-options (partition-file-system-options partition))
  84         (label (partition-label partition))
  85         (uuid (partition-uuid partition))
  86         (journal-options "lazy_itable_init=1,lazy_journal_init=1"))
  87     (apply invoke
  88            `("fakeroot" "mke2fs" "-t" ,fs "-d" ,root
  89              "-L" ,label
  90              ,@(if uuid
  91                    `("-U" ,(uuid->string uuid))
  92                    '())
  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)))))))
 102
 103 (define* (make-vfat-image partition target root fs-bits)
 104   "Handle the creation of VFAT partition images.  See 'make-partition-image'."
 105   (let ((size (partition-size partition))
 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") '()))
 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
 128      ((string-prefix? "ext" type)
 129       (make-ext-image partition target root))
 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))
 134      (else
 135       (raise (condition
 136               (&message
 137                (message "unsupported partition type"))))))))
 138
 139 (define (convert-disk-image image format output)
 140   "Convert IMAGE to OUTPUT according to the given FORMAT."
 141   (case format
 142     ((compressed-qcow2)
 143      (invoke "qemu-img" "convert" "-c" "-f" "raw"
 144              "-O" "qcow2" image output))
 145     (else
 146      (copy-file image output))))
 147
 148 (define* (genimage config)
 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")
 153   (invoke "genimage" "--config" config))
 154
 155 (define* (register-closure prefix closure
 156                            #:key
 157                            (schema (sql-schema))
 158                            (wal-mode? #t))
 159   "Register CLOSURE in PREFIX, where PREFIX is the directory name of the
 160 target store and CLOSURE is the name of a file containing a reference graph as
 161 produced by #:references-graphs.  Pass WAL-MODE? to call-with-database."
 162   (let ((items (call-with-input-file closure read-reference-graph)))
 163     (parameterize ((sql-schema schema))
 164       (with-database (store-database-file #:prefix prefix) db
 165        #:wal-mode? wal-mode?
 166        (register-items db items
 167                        #:prefix prefix
 168                        #:registration-time %epoch)))))
 169
 170 (define* (initialize-efi-partition root
 171                                    #:key
 172                                    grub-efi
 173                                    #:allow-other-keys)
 174   "Install in ROOT directory, an EFI loader using GRUB-EFI."
 175   (install-efi-loader grub-efi root))
 176
 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
 188 (define* (initialize-root-partition root
 189                                     #:key
 190                                     bootcfg
 191                                     bootcfg-location
 192                                     bootloader-package
 193                                     bootloader-installer
 194                                     (copy-closures? #t)
 195                                     (deduplicate? #t)
 196                                     references-graphs
 197                                     (register-closures? #t)
 198                                     system-directory
 199                                     make-device-nodes
 200                                     (wal-mode? #t)
 201                                     #:allow-other-keys)
 202   "Initialize the given ROOT directory. Use BOOTCFG and BOOTCFG-LOCATION to
 203 install the bootloader configuration.
 204
 205 If COPY-CLOSURES? is true, copy all of REFERENCES-GRAPHS to the partition.  If
 206 REGISTER-CLOSURES? is true, register REFERENCES-GRAPHS in the store.  If
 207 DEDUPLICATE? is true, then also deduplicate files common to CLOSURES and the
 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."
 211   (define root-store
 212     (string-append root (%store-directory)))
 213
 214   (define tmp-store ".tmp-store")
 215
 216   (populate-root-file-system system-directory root)
 217
 218   (when copy-closures?
 219     (populate-store references-graphs root
 220                     #:deduplicate? deduplicate?))
 221
 222   ;; Populate /dev.
 223   (when make-device-nodes
 224     (make-device-nodes root))
 225
 226   (when register-closures?
 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
 233     (for-each (lambda (closure)
 234                 (register-closure root closure
 235                                   #:wal-mode? wal-mode?))
 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))))
 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              '()))))