gnu/system/image.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2020 Mathieu Othacehe <m.othacehe@gmail.com>
   3 ;;; Copyright © 2020 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
   4 ;;;
   5 ;;; This file is part of GNU Guix.
   6 ;;;
   7 ;;; GNU Guix is free software; you can redistribute it and/or modify it
   8 ;;; under the terms of the GNU General Public License as published by
   9 ;;; the Free Software Foundation; either version 3 of the License, or (at
  10 ;;; your option) any later version.
  11 ;;;
  12 ;;; GNU Guix is distributed in the hope that it will be useful, but
  13 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  14 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  15 ;;; GNU General Public License for more details.
  16 ;;;
  17 ;;; You should have received a copy of the GNU General Public License
  18 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
  19
  20 (define-module (gnu system image)
  21   #:use-module (guix gexp)
  22   #:use-module (guix modules)
  23   #:use-module (guix monads)
  24   #:use-module (guix records)
  25   #:use-module (guix store)
  26   #:use-module (guix ui)
  27   #:use-module (guix utils)
  28   #:use-module ((guix self) #:select (make-config.scm))
  29   #:use-module (gnu bootloader)
  30   #:use-module (gnu bootloader grub)
  31   #:use-module (gnu image)
  32   #:use-module (gnu services)
  33   #:use-module (gnu services base)
  34   #:use-module (gnu system)
  35   #:use-module (gnu system file-systems)
  36   #:use-module (gnu system uuid)
  37   #:use-module (gnu system vm)
  38   #:use-module (guix packages)
  39   #:use-module (gnu packages base)
  40   #:use-module (gnu packages bootloaders)
  41   #:use-module (gnu packages cdrom)
  42   #:use-module (gnu packages disk)
  43   #:use-module (gnu packages gawk)
  44   #:use-module (gnu packages genimage)
  45   #:use-module (gnu packages guile)
  46   #:autoload   (gnu packages gnupg) (guile-gcrypt)
  47   #:use-module (gnu packages hurd)
  48   #:use-module (gnu packages linux)
  49   #:use-module (gnu packages mtools)
  50   #:use-module ((srfi srfi-1) #:prefix srfi-1:)
  51   #:use-module (srfi srfi-11)
  52   #:use-module (srfi srfi-26)
  53   #:use-module (srfi srfi-35)
  54   #:use-module (rnrs bytevectors)
  55   #:use-module (ice-9 match)
  56   #:export (root-offset
  57             root-label
  58
  59             esp-partition
  60             root-partition
  61
  62             efi-disk-image
  63             iso9660-image
  64
  65             find-image
  66             system-image))
  67
  68 \f
  69 ;;;
  70 ;;; Images definitions.
  71 ;;;
  72
  73 ;; This is the offset before the first partition. GRUB will install itself in
  74 ;; this post-MBR gap.
  75 (define root-offset (* 512 2048))
  76
  77 ;; Generic root partition label.
  78 (define root-label "Guix_image")
  79
  80 (define esp-partition
  81   (partition
  82    (size (* 40 (expt 2 20)))
  83    (offset root-offset)
  84    (label "GNU-ESP") ;cosmetic only
  85    ;; Use "vfat" here since this property is used when mounting.  The actual
  86    ;; FAT-ness is based on file system size (16 in this case).
  87    (file-system "vfat")
  88    (flags '(esp))
  89    (initializer (gexp initialize-efi-partition))))
  90
  91 (define root-partition
  92   (partition
  93    (size 'guess)
  94    (label root-label)
  95    (file-system "ext4")
  96    (flags '(boot))
  97    (initializer (gexp initialize-root-partition))))
  98
  99 (define hurd-initialize-root-partition
 100   #~(lambda* (#:rest args)
 101       (apply initialize-root-partition
 102              (append args
 103                      (list #:make-device-nodes
 104                            make-hurd-device-nodes)))))
 105
 106 (define efi-disk-image
 107   (image
 108    (format 'disk-image)
 109    (partitions (list esp-partition root-partition))))
 110
 111 (define iso9660-image
 112   (image
 113    (format 'iso9660)
 114    (partitions
 115     (list (partition
 116            (size 'guess)
 117            (label "GUIX_IMAGE")
 118            (flags '(boot)))))
 119    ;; XXX: Temporarily disable compression to speed-up the tests.
 120    (compression? #f)))
 121
 122 \f
 123 ;;
 124 ;; Helpers.
 125 ;;
 126
 127 (define not-config?
 128   ;; Select (guix …) and (gnu …) modules, except (guix config).
 129   (match-lambda
 130     (('guix 'config) #f)
 131     (('guix rest ...) #t)
 132     (('gnu rest ...) #t)
 133     (rest #f)))
 134
 135 (define (partition->gexp partition)
 136   "Turn PARTITION, a <partition> object, into a list-valued gexp suitable for
 137 'make-partition-image'."
 138   #~'(#$@(list (partition-size partition))
 139       #$(partition-file-system partition)
 140       #$(partition-file-system-options partition)
 141       #$(partition-label partition)
 142       #$(and=> (partition-uuid partition)
 143                uuid-bytevector)))
 144
 145 (define gcrypt-sqlite3&co
 146   ;; Guile-Gcrypt, Guile-SQLite3, and their propagated inputs.
 147   (srfi-1:append-map
 148    (lambda (package)
 149      (cons package
 150            (match (package-transitive-propagated-inputs package)
 151              (((labels packages) ...)
 152               packages))))
 153    (list guile-gcrypt guile-sqlite3)))
 154
 155 (define-syntax-rule (with-imported-modules* gexp* ...)
 156   (with-extensions gcrypt-sqlite3&co
 157     (with-imported-modules `(,@(source-module-closure
 158                                 '((gnu build vm)
 159                                   (gnu build image)
 160                                   (gnu build hurd-boot)
 161                                   (gnu build linux-boot)
 162                                   (guix store database))
 163                                 #:select? not-config?)
 164                              ((guix config) => ,(make-config.scm)))
 165       #~(begin
 166           (use-modules (gnu build vm)
 167                        (gnu build image)
 168                        (gnu build hurd-boot)
 169                        (gnu build linux-boot)
 170                        (guix store database)
 171                        (guix build utils))
 172           gexp* ...))))
 173
 174 (define (root-partition? partition)
 175   "Return true if PARTITION is the root partition, false otherwise."
 176   (member 'boot (partition-flags partition)))
 177
 178 (define (find-root-partition image)
 179   "Return the root partition of the given IMAGE."
 180   (srfi-1:find root-partition? (image-partitions image)))
 181
 182 (define (root-partition-index image)
 183   "Return the index of the root partition of the given IMAGE."
 184   (1+ (srfi-1:list-index root-partition? (image-partitions image))))
 185
 186 \f
 187 ;;
 188 ;; Disk image.
 189 ;;
 190
 191 (define* (system-disk-image image
 192                             #:key
 193                             (name "disk-image")
 194                             bootcfg
 195                             bootloader
 196                             register-closures?
 197                             (inputs '()))
 198   "Return as a file-like object, the disk-image described by IMAGE.  Said
 199 image can be copied on a USB stick as is.  BOOTLOADER is the bootloader that
 200 will be installed and configured according to BOOTCFG parameter.
 201
 202 Raw images of the IMAGE partitions are first created.  Then, genimage is used
 203 to assemble the partition images into a disk-image without resorting to a
 204 virtual machine.
 205
 206 INPUTS is a list of inputs (as for packages).  When REGISTER-CLOSURES? is
 207 true, register INPUTS in the store database of the image so that Guix can be
 208 used in the image."
 209
 210   (define genimage-name "image")
 211
 212   (define (image->genimage-cfg image)
 213     ;; Return as a file-like object, the genimage configuration file
 214     ;; describing the given IMAGE.
 215     (define (format->image-type format)
 216       ;; Return the genimage format corresponding to FORMAT.  For now, only
 217       ;; the hdimage format (raw disk-image) is supported.
 218       (case format
 219         ((disk-image) "hdimage")
 220         (else
 221          (raise (condition
 222                  (&message
 223                   (message
 224                    (format #f (G_ "Unsupported image type ~a~%.") format))))))))
 225
 226     (define (partition->dos-type partition)
 227       ;; Return the MBR partition type corresponding to the given PARTITION.
 228       ;; See: https://en.wikipedia.org/wiki/Partition_type.
 229       (let ((flags (partition-flags partition)))
 230         (cond
 231          ((member 'esp flags) "0xEF")
 232          (else "0x83"))))
 233
 234     (define (partition-image partition)
 235       ;; Return as a file-like object, an image of the given PARTITION.  A
 236       ;; directory, filled by calling the PARTITION initializer procedure, is
 237       ;; first created within the store.  Then, an image of this directory is
 238       ;; created using tools such as 'mke2fs' or 'mkdosfs', depending on the
 239       ;; partition file-system type.
 240       (let* ((os (image-operating-system image))
 241              (schema (local-file (search-path %load-path
 242                                               "guix/store/schema.sql")))
 243              (graph (match inputs
 244                       (((names . _) ...)
 245                        names)))
 246              (type (partition-file-system partition))
 247              (image-builder
 248               (with-imported-modules*
 249                (let ((initializer #$(partition-initializer partition))
 250                      (inputs '#+(list e2fsprogs fakeroot dosfstools mtools))
 251                      (image-root "tmp-root"))
 252                  (sql-schema #$schema)
 253
 254                  (set-path-environment-variable "PATH" '("bin" "sbin") inputs)
 255
 256                  ;; Allow non-ASCII file names--e.g., 'nss-certs'--to be
 257                  ;; decoded.
 258                  (setenv "GUIX_LOCPATH"
 259                          #+(file-append glibc-utf8-locales "/lib/locale"))
 260                  (setlocale LC_ALL "en_US.utf8")
 261
 262                  (initializer image-root
 263                               #:references-graphs '#$graph
 264                               #:deduplicate? #f
 265                               #:system-directory #$os
 266                               #:grub-efi #+grub-efi
 267                               #:bootloader-package
 268                               #+(bootloader-package bootloader)
 269                               #:bootloader-installer
 270                               #+(bootloader-installer bootloader)
 271                               #:bootcfg #$bootcfg
 272                               #:bootcfg-location
 273                               #$(bootloader-configuration-file bootloader))
 274                  (make-partition-image #$(partition->gexp partition)
 275                                        #$output
 276                                        image-root)))))
 277         (computed-file "partition.img" image-builder
 278                        #:options `(#:references-graphs ,inputs))))
 279
 280     (define (partition->config partition)
 281       ;; Return the genimage partition configuration for PARTITION.
 282       (let ((label (partition-label partition))
 283             (dos-type (partition->dos-type partition))
 284             (image (partition-image partition))
 285             (offset (partition-offset partition)))
 286         #~(format #f "~/partition ~a {
 287 ~/~/partition-type = ~a
 288 ~/~/image = \"~a\"
 289 ~/~/offset = \"~a\"
 290 ~/}"
 291                   #$label
 292                   #$dos-type
 293                   #$image
 294                   #$offset)))
 295
 296     (let* ((format (image-format image))
 297            (image-type (format->image-type format))
 298            (partitions (image-partitions image))
 299            (partitions-config (map partition->config partitions))
 300            (builder
 301             #~(begin
 302                 (let ((format (@ (ice-9 format) format)))
 303                   (call-with-output-file #$output
 304                     (lambda (port)
 305                       (format port
 306                               "\
 307 image ~a {
 308 ~/~a {}
 309 ~{~a~^~%~}
 310 }~%" #$genimage-name #$image-type (list #$@partitions-config))))))))
 311       (computed-file "genimage.cfg" builder)))
 312
 313   (let* ((substitutable? (image-substitutable? image))
 314          (builder
 315           (with-imported-modules*
 316            (let ((inputs '#+(list genimage coreutils findutils))
 317                  (bootloader-installer
 318                   #+(bootloader-disk-image-installer bootloader)))
 319              (set-path-environment-variable "PATH" '("bin" "sbin") inputs)
 320              (genimage #$(image->genimage-cfg image) #$output)
 321              ;; Install the bootloader directly on the disk-image.
 322              (when bootloader-installer
 323                (bootloader-installer
 324                 #+(bootloader-package bootloader)
 325                 #$(root-partition-index image)
 326                 (string-append #$output "/" #$genimage-name))))))
 327          (image-dir (computed-file "image-dir" builder)))
 328     (computed-file name
 329                    #~(symlink
 330                       (string-append #$image-dir "/" #$genimage-name)
 331                       #$output)
 332                    #:options `(#:substitutable? ,substitutable?))))
 333
 334 \f
 335 ;;
 336 ;; ISO9660 image.
 337 ;;
 338
 339 (define (has-guix-service-type? os)
 340   "Return true if OS contains a service of the type GUIX-SERVICE-TYPE."
 341   (not (not (srfi-1:find (lambda (service)
 342                            (eq? (service-kind service) guix-service-type))
 343                          (operating-system-services os)))))
 344
 345 (define* (system-iso9660-image image
 346                                #:key
 347                                (name "iso9660-image")
 348                                bootcfg
 349                                bootloader
 350                                register-closures?
 351                                (inputs '())
 352                                (grub-mkrescue-environment '()))
 353   "Return as a file-like object a bootable, stand-alone iso9660 image.
 354
 355 INPUTS is a list of inputs (as for packages).  When REGISTER-CLOSURES? is
 356 true, register INPUTS in the store database of the image so that Guix can be
 357 used in the image. "
 358   (define root-label
 359     (match (image-partitions image)
 360       ((partition)
 361        (partition-label partition))))
 362
 363   (define root-uuid
 364     (match (image-partitions image)
 365       ((partition)
 366        (uuid-bytevector (partition-uuid partition)))))
 367
 368   (let* ((os (image-operating-system image))
 369          (bootloader (bootloader-package bootloader))
 370          (compression? (image-compression? image))
 371          (substitutable? (image-substitutable? image))
 372          (schema (local-file (search-path %load-path
 373                                           "guix/store/schema.sql")))
 374          (graph (match inputs
 375                   (((names . _) ...)
 376                    names)))
 377          (builder
 378           (with-imported-modules*
 379            (let* ((inputs '#$(list parted e2fsprogs dosfstools xorriso
 380                                    sed grep coreutils findutils gawk))
 381                   (image-root "tmp-root"))
 382              (sql-schema #$schema)
 383
 384              ;; Allow non-ASCII file names--e.g., 'nss-certs'--to be decoded.
 385              (setenv "GUIX_LOCPATH"
 386                      #+(file-append glibc-utf8-locales "/lib/locale"))
 387
 388              (setlocale LC_ALL "en_US.utf8")
 389
 390              (set-path-environment-variable "PATH" '("bin" "sbin") inputs)
 391
 392              (initialize-root-partition image-root
 393                                         #:references-graphs '#$graph
 394                                         #:deduplicate? #f
 395                                         #:system-directory #$os)
 396              (make-iso9660-image #$xorriso
 397                                  '#$grub-mkrescue-environment
 398                                  #$bootloader
 399                                  #$bootcfg
 400                                  #$os
 401                                  image-root
 402                                  #$output
 403                                  #:references-graphs '#$graph
 404                                  #:register-closures? #$register-closures?
 405                                  #:compression? #$compression?
 406                                  #:volume-id #$root-label
 407                                  #:volume-uuid #$root-uuid)))))
 408     (computed-file name builder
 409                    #:options `(#:references-graphs ,inputs
 410                                #:substitutable? ,substitutable?))))
 411
 412 \f
 413 ;;
 414 ;; Image creation.
 415 ;;
 416
 417 (define (image->root-file-system image)
 418   "Return the IMAGE root partition file-system type."
 419   (let ((format (image-format image)))
 420     (if (eq? format 'iso9660)
 421         "iso9660"
 422         (partition-file-system (find-root-partition image)))))
 423
 424 (define (root-size image)
 425   "Return the root partition size of IMAGE."
 426   (let* ((image-size (image-size image))
 427          (root-partition (find-root-partition image))
 428          (root-size (partition-size root-partition)))
 429     (cond
 430      ((and (eq? root-size 'guess) image-size)
 431       image-size)
 432      (else root-size))))
 433
 434 (define* (image-with-os base-image os)
 435   "Return an image based on BASE-IMAGE but with the operating-system field set
 436 to OS.  Also set the UUID and the size of the root partition."
 437   (define root-file-system
 438     (srfi-1:find
 439      (lambda (fs)
 440        (string=? (file-system-mount-point fs) "/"))
 441      (operating-system-file-systems os)))
 442
 443   (image
 444    (inherit base-image)
 445    (operating-system os)
 446    (partitions
 447     (map (lambda (p)
 448            (if (root-partition? p)
 449                (partition
 450                 (inherit p)
 451                 (uuid (file-system-device root-file-system))
 452                 (size (root-size base-image)))
 453                p))
 454          (image-partitions base-image)))))
 455
 456 (define (operating-system-for-image image)
 457   "Return an operating-system based on the one specified in IMAGE, but
 458 suitable for image creation.  Assign an UUID to the root file-system, so that
 459 it can be used for bootloading."
 460   (define volatile-root? (image-volatile-root? image))
 461
 462   (define (root-uuid os)
 463     ;; UUID of the root file system, computed in a deterministic fashion.
 464     ;; This is what we use to locate the root file system so it has to be
 465     ;; different from the user's own file system UUIDs.
 466     (let ((type (if (eq? (image-format image) 'iso9660)
 467                     'iso9660
 468                     'dce)))
 469       (operating-system-uuid os type)))
 470
 471   (let* ((root-file-system-type (image->root-file-system image))
 472          (base-os (image-operating-system image))
 473          (file-systems-to-keep
 474           (srfi-1:remove
 475            (lambda (fs)
 476              (string=? (file-system-mount-point fs) "/"))
 477            (operating-system-file-systems base-os)))
 478          (format (image-format image))
 479          (os
 480           (operating-system
 481             (inherit base-os)
 482             (initrd (lambda (file-systems . rest)
 483                       (apply (operating-system-initrd base-os)
 484                              file-systems
 485                              #:volatile-root? volatile-root?
 486                              rest)))
 487             (bootloader (if (eq? format 'iso9660)
 488                             (bootloader-configuration
 489                              (inherit
 490                               (operating-system-bootloader base-os))
 491                              (bootloader grub-mkrescue-bootloader))
 492                             (operating-system-bootloader base-os)))
 493             (file-systems (cons (file-system
 494                                   (mount-point "/")
 495                                   (device "/dev/placeholder")
 496                                   (type root-file-system-type))
 497                                 file-systems-to-keep))))
 498          (uuid (root-uuid os)))
 499     (operating-system
 500       (inherit os)
 501       (file-systems (cons (file-system
 502                             (mount-point "/")
 503                             (device uuid)
 504                             (type root-file-system-type))
 505                           file-systems-to-keep)))))
 506
 507 (define* (system-image image)
 508   "Return the derivation of IMAGE.  It can be a raw disk-image or an ISO9660
 509 image, depending on IMAGE format."
 510   (define substitutable? (image-substitutable? image))
 511   (define target (image-target image))
 512
 513   (with-parameters ((%current-target-system target))
 514     (let* ((os (operating-system-for-image image))
 515            (image* (image-with-os image os))
 516            (register-closures? (has-guix-service-type? os))
 517            (bootcfg (operating-system-bootcfg os))
 518            (bootloader (bootloader-configuration-bootloader
 519                         (operating-system-bootloader os))))
 520       (case (image-format image)
 521         ((disk-image)
 522          (system-disk-image image*
 523                             #:bootcfg bootcfg
 524                             #:bootloader bootloader
 525                             #:register-closures? register-closures?
 526                             #:inputs `(("system" ,os)
 527                                        ("bootcfg" ,bootcfg))))
 528         ((iso9660)
 529          (system-iso9660-image
 530           image*
 531           #:bootcfg bootcfg
 532           #:bootloader bootloader
 533           #:register-closures? register-closures?
 534           #:inputs `(("system" ,os)
 535                      ("bootcfg" ,bootcfg))
 536           ;; Make sure to use a mode that does no imply
 537           ;; HFS+ tree creation that may fail with:
 538           ;;
 539           ;; "libisofs: FAILURE : Too much files to mangle,
 540           ;; cannot guarantee unique file names"
 541           ;;
 542           ;; This happens if some limits are exceeded, see:
 543           ;; https://lists.gnu.org/archive/html/grub-devel/2020-06/msg00048.html
 544           #:grub-mkrescue-environment
 545           '(("MKRESCUE_SED_MODE" . "mbr_only"))))))))
 546
 547 (define (find-image file-system-type target)
 548   "Find and return an image built that could match the given FILE-SYSTEM-TYPE,
 549 built for TARGET.  This is useful to adapt to interfaces written before the
 550 addition of the <image> record."
 551   (match file-system-type
 552     ("iso9660" iso9660-image)
 553     (_ (cond
 554         ((and target
 555               (hurd-triplet? target))
 556          (module-ref (resolve-interface '(gnu system images hurd))
 557                      'hurd-disk-image))
 558         (else
 559          efi-disk-image)))))
 560
 561 ;;; image.scm ends here