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 diagnostics)
  22   #:use-module (guix discovery)
  23   #:use-module (guix gexp)
  24   #:use-module (guix modules)
  25   #:use-module (guix monads)
  26   #:use-module (guix records)
  27   #:use-module (guix store)
  28   #:use-module (guix ui)
  29   #:use-module (guix utils)
  30   #:use-module ((guix self) #:select (make-config.scm))
  31   #:use-module (gnu bootloader)
  32   #:use-module (gnu bootloader grub)
  33   #:use-module (gnu image)
  34   #:use-module (gnu services)
  35   #:use-module (gnu services base)
  36   #:use-module (gnu system)
  37   #:use-module (gnu system file-systems)
  38   #:use-module (gnu system uuid)
  39   #:use-module (gnu system vm)
  40   #:use-module (guix packages)
  41   #:use-module (gnu packages base)
  42   #:use-module (gnu packages bootloaders)
  43   #:use-module (gnu packages cdrom)
  44   #:use-module (gnu packages disk)
  45   #:use-module (gnu packages gawk)
  46   #:use-module (gnu packages genimage)
  47   #:use-module (gnu packages guile)
  48   #:autoload   (gnu packages gnupg) (guile-gcrypt)
  49   #:use-module (gnu packages hurd)
  50   #:use-module (gnu packages linux)
  51   #:use-module (gnu packages mtools)
  52   #:use-module (gnu packages virtualization)
  53   #:use-module ((srfi srfi-1) #:prefix srfi-1:)
  54   #:use-module (srfi srfi-11)
  55   #:use-module (srfi srfi-26)
  56   #:use-module (srfi srfi-34)
  57   #:use-module (srfi srfi-35)
  58   #:use-module (rnrs bytevectors)
  59   #:use-module (ice-9 format)
  60   #:use-module (ice-9 match)
  61   #:export (root-offset
  62             root-label
  63
  64             esp-partition
  65             root-partition
  66
  67             efi-disk-image
  68             iso9660-image
  69             arm32-disk-image
  70             arm64-disk-image
  71
  72             image-with-os
  73             raw-image-type
  74             qcow2-image-type
  75             iso-image-type
  76             uncompressed-iso-image-type
  77             arm32-image-type
  78             arm64-image-type
  79
  80             image-with-label
  81             system-image
  82
  83             %image-types
  84             lookup-image-type-by-name))
  85
  86 \f
  87 ;;;
  88 ;;; Images definitions.
  89 ;;;
  90
  91 ;; This is the offset before the first partition. GRUB will install itself in
  92 ;; this post-MBR gap.
  93 (define root-offset (* 512 2048))
  94
  95 ;; Generic root partition label.
  96 (define root-label "Guix_image")
  97
  98 (define esp-partition
  99   (partition
 100    (size (* 40 (expt 2 20)))
 101    (offset root-offset)
 102    (label "GNU-ESP") ;cosmetic only
 103    ;; Use "vfat" here since this property is used when mounting.  The actual
 104    ;; FAT-ness is based on file system size (16 in this case).
 105    (file-system "vfat")
 106    (flags '(esp))
 107    (initializer (gexp initialize-efi-partition))))
 108
 109 (define root-partition
 110   (partition
 111    (size 'guess)
 112    (label root-label)
 113    (file-system "ext4")
 114    (flags '(boot))
 115    (initializer (gexp initialize-root-partition))))
 116
 117 (define efi-disk-image
 118   (image
 119    (format 'disk-image)
 120    (partitions (list esp-partition root-partition))))
 121
 122 (define iso9660-image
 123   (image
 124    (format 'iso9660)
 125    (partitions
 126     (list (partition
 127            (size 'guess)
 128            (label "GUIX_IMAGE")
 129            (flags '(boot)))))))
 130
 131 (define arm32-disk-image
 132   (image
 133    (format 'disk-image)
 134    (target "arm-linux-gnueabihf")
 135    (partitions
 136     (list (partition
 137            (inherit root-partition)
 138            (offset root-offset))))
 139    ;; FIXME: Deleting and creating "/var/run" and "/tmp" on the overlayfs
 140    ;; fails.
 141    (volatile-root? #f)))
 142
 143 (define arm64-disk-image
 144   (image
 145    (inherit arm32-disk-image)
 146    (target "aarch64-linux-gnu")))
 147
 148 \f
 149 ;;;
 150 ;;; Images types.
 151 ;;;
 152
 153 (define-syntax-rule (image-with-os base-image os)
 154   "Return an image inheriting from BASE-IMAGE, with the operating-system field
 155 set to the given OS."
 156   (image
 157    (inherit base-image)
 158    (operating-system os)))
 159
 160 (define raw-image-type
 161   (image-type
 162    (name 'raw)
 163    (constructor (cut image-with-os efi-disk-image <>))))
 164
 165 (define qcow2-image-type
 166   (image-type
 167    (name 'qcow2)
 168    (constructor (cut image-with-os
 169                  (image
 170                   (inherit efi-disk-image)
 171                   (name 'image.qcow2)
 172                   (format 'compressed-qcow2))
 173                  <>))))
 174
 175 (define iso-image-type
 176   (image-type
 177    (name 'iso9660)
 178    (constructor (cut image-with-os iso9660-image <>))))
 179
 180 (define uncompressed-iso-image-type
 181   (image-type
 182    (name 'uncompressed-iso9660)
 183    (constructor (cut image-with-os
 184                  (image
 185                   (inherit iso9660-image)
 186                   (compression? #f))
 187                  <>))))
 188
 189 (define arm32-image-type
 190   (image-type
 191    (name 'arm32-raw)
 192    (constructor (cut image-with-os arm32-disk-image <>))))
 193
 194 (define arm64-image-type
 195   (image-type
 196    (name 'arm64-raw)
 197    (constructor (cut image-with-os arm64-disk-image <>))))
 198
 199 \f
 200 ;;
 201 ;; Helpers.
 202 ;;
 203
 204 (define not-config?
 205   ;; Select (guix …) and (gnu …) modules, except (guix config).
 206   (match-lambda
 207     (('guix 'config) #f)
 208     (('guix rest ...) #t)
 209     (('gnu rest ...) #t)
 210     (rest #f)))
 211
 212 (define (partition->gexp partition)
 213   "Turn PARTITION, a <partition> object, into a list-valued gexp suitable for
 214 'make-partition-image'."
 215   #~'(#$@(list (partition-size partition))
 216       #$(partition-file-system partition)
 217       #$(partition-file-system-options partition)
 218       #$(partition-label partition)
 219       #$(and=> (partition-uuid partition)
 220                uuid-bytevector)))
 221
 222 (define gcrypt-sqlite3&co
 223   ;; Guile-Gcrypt, Guile-SQLite3, and their propagated inputs.
 224   (srfi-1:append-map
 225    (lambda (package)
 226      (cons package
 227            (match (package-transitive-propagated-inputs package)
 228              (((labels packages) ...)
 229               packages))))
 230    (list guile-gcrypt guile-sqlite3)))
 231
 232 (define-syntax-rule (with-imported-modules* gexp* ...)
 233   (with-extensions gcrypt-sqlite3&co
 234     (with-imported-modules `(,@(source-module-closure
 235                                 '((gnu build vm)
 236                                   (gnu build image)
 237                                   (gnu build bootloader)
 238                                   (gnu build hurd-boot)
 239                                   (gnu build linux-boot)
 240                                   (guix store database))
 241                                 #:select? not-config?)
 242                              ((guix config) => ,(make-config.scm)))
 243       #~(begin
 244           (use-modules (gnu build vm)
 245                        (gnu build image)
 246                        (gnu build bootloader)
 247                        (gnu build hurd-boot)
 248                        (gnu build linux-boot)
 249                        (guix store database)
 250                        (guix build utils))
 251           gexp* ...))))
 252
 253 (define (root-partition? partition)
 254   "Return true if PARTITION is the root partition, false otherwise."
 255   (member 'boot (partition-flags partition)))
 256
 257 (define (find-root-partition image)
 258   "Return the root partition of the given IMAGE."
 259   (srfi-1:find root-partition? (image-partitions image)))
 260
 261 (define (root-partition-index image)
 262   "Return the index of the root partition of the given IMAGE."
 263   (1+ (srfi-1:list-index root-partition? (image-partitions image))))
 264
 265 \f
 266 ;;
 267 ;; Disk image.
 268 ;;
 269
 270 (define* (system-disk-image image
 271                             #:key
 272                             (name "disk-image")
 273                             bootcfg
 274                             bootloader
 275                             register-closures?
 276                             (inputs '()))
 277   "Return as a file-like object, the disk-image described by IMAGE.  Said
 278 image can be copied on a USB stick as is.  BOOTLOADER is the bootloader that
 279 will be installed and configured according to BOOTCFG parameter.
 280
 281 Raw images of the IMAGE partitions are first created.  Then, genimage is used
 282 to assemble the partition images into a disk-image without resorting to a
 283 virtual machine.
 284
 285 INPUTS is a list of inputs (as for packages).  When REGISTER-CLOSURES? is
 286 true, register INPUTS in the store database of the image so that Guix can be
 287 used in the image."
 288
 289   (define genimage-name "image")
 290
 291   (define (image->genimage-cfg image)
 292     ;; Return as a file-like object, the genimage configuration file
 293     ;; describing the given IMAGE.
 294     (define (format->image-type format)
 295       ;; Return the genimage format corresponding to FORMAT.  For now, only
 296       ;; the hdimage format (raw disk-image) is supported.
 297       (cond
 298        ((memq format '(disk-image compressed-qcow2)) "hdimage")
 299         (else
 300          (raise (condition
 301                  (&message
 302                   (message
 303                    (format #f (G_ "Unsupported image type ~a~%.") format))))))))
 304
 305     (define (partition->dos-type partition)
 306       ;; Return the MBR partition type corresponding to the given PARTITION.
 307       ;; See: https://en.wikipedia.org/wiki/Partition_type.
 308       (let ((flags (partition-flags partition)))
 309         (cond
 310          ((member 'esp flags) "0xEF")
 311          (else "0x83"))))
 312
 313     (define (partition-image partition)
 314       ;; Return as a file-like object, an image of the given PARTITION.  A
 315       ;; directory, filled by calling the PARTITION initializer procedure, is
 316       ;; first created within the store.  Then, an image of this directory is
 317       ;; created using tools such as 'mke2fs' or 'mkdosfs', depending on the
 318       ;; partition file-system type.
 319       (let* ((os (image-operating-system image))
 320              (schema (local-file (search-path %load-path
 321                                               "guix/store/schema.sql")))
 322              (graph (match inputs
 323                       (((names . _) ...)
 324                        names)))
 325              (type (partition-file-system partition))
 326              (image-builder
 327               (with-imported-modules*
 328                (let ((initializer #$(partition-initializer partition))
 329                      (inputs '#+(list e2fsprogs fakeroot dosfstools mtools))
 330                      (image-root "tmp-root"))
 331                  (sql-schema #$schema)
 332
 333                  (set-path-environment-variable "PATH" '("bin" "sbin") inputs)
 334
 335                  ;; Allow non-ASCII file names--e.g., 'nss-certs'--to be
 336                  ;; decoded.
 337                  (setenv "GUIX_LOCPATH"
 338                          #+(file-append glibc-utf8-locales "/lib/locale"))
 339                  (setlocale LC_ALL "en_US.utf8")
 340
 341                  (initializer image-root
 342                               #:references-graphs '#$graph
 343                               #:deduplicate? #f
 344                               #:system-directory #$os
 345                               #:grub-efi #+grub-efi
 346                               #:bootloader-package
 347                               #+(bootloader-package bootloader)
 348                               #:bootloader-installer
 349                               #+(bootloader-installer bootloader)
 350                               #:bootcfg #$bootcfg
 351                               #:bootcfg-location
 352                               #$(bootloader-configuration-file bootloader))
 353                  (make-partition-image #$(partition->gexp partition)
 354                                        #$output
 355                                        image-root)))))
 356         (computed-file "partition.img" image-builder
 357                        #:options `(#:references-graphs ,inputs))))
 358
 359     (define (partition->config partition)
 360       ;; Return the genimage partition configuration for PARTITION.
 361       (let ((label (partition-label partition))
 362             (dos-type (partition->dos-type partition))
 363             (image (partition-image partition))
 364             (offset (partition-offset partition)))
 365         #~(format #f "~/partition ~a {
 366 ~/~/partition-type = ~a
 367 ~/~/image = \"~a\"
 368 ~/~/offset = \"~a\"
 369 ~/}"
 370                   #$label
 371                   #$dos-type
 372                   #$image
 373                   #$offset)))
 374
 375     (let* ((format (image-format image))
 376            (image-type (format->image-type format))
 377            (partitions (image-partitions image))
 378            (partitions-config (map partition->config partitions))
 379            (builder
 380             #~(begin
 381                 (let ((format (@ (ice-9 format) format)))
 382                   (call-with-output-file #$output
 383                     (lambda (port)
 384                       (format port
 385                               "\
 386 image ~a {
 387 ~/~a {}
 388 ~{~a~^~%~}
 389 }~%" #$genimage-name #$image-type (list #$@partitions-config))))))))
 390       (computed-file "genimage.cfg" builder)))
 391
 392   (let* ((image-name (image-name image))
 393          (name (if image-name
 394                    (symbol->string image-name)
 395                    name))
 396          (format (image-format image))
 397          (substitutable? (image-substitutable? image))
 398          (builder
 399           (with-imported-modules*
 400            (let ((inputs '#+(list genimage coreutils findutils qemu-minimal))
 401                  (bootloader-installer
 402                   #+(bootloader-disk-image-installer bootloader))
 403                  (out-image (string-append "images/" #$genimage-name)))
 404              (set-path-environment-variable "PATH" '("bin" "sbin") inputs)
 405              (genimage #$(image->genimage-cfg image))
 406              ;; Install the bootloader directly on the disk-image.
 407              (when bootloader-installer
 408                (bootloader-installer
 409                 #+(bootloader-package bootloader)
 410                 #$(root-partition-index image)
 411                 out-image))
 412              (convert-disk-image out-image '#$format #$output)))))
 413     (computed-file name builder
 414                    #:options `(#:substitutable? ,substitutable?))))
 415
 416 \f
 417 ;;
 418 ;; ISO9660 image.
 419 ;;
 420
 421 (define (has-guix-service-type? os)
 422   "Return true if OS contains a service of the type GUIX-SERVICE-TYPE."
 423   (not (not (srfi-1:find (lambda (service)
 424                            (eq? (service-kind service) guix-service-type))
 425                          (operating-system-services os)))))
 426
 427 (define* (system-iso9660-image image
 428                                #:key
 429                                (name "image.iso")
 430                                bootcfg
 431                                bootloader
 432                                register-closures?
 433                                (inputs '())
 434                                (grub-mkrescue-environment '()))
 435   "Return as a file-like object a bootable, stand-alone iso9660 image.
 436
 437 INPUTS is a list of inputs (as for packages).  When REGISTER-CLOSURES? is
 438 true, register INPUTS in the store database of the image so that Guix can be
 439 used in the image. "
 440   (define root-label
 441     (match (image-partitions image)
 442       ((partition)
 443        (partition-label partition))))
 444
 445   (define root-uuid
 446     (match (image-partitions image)
 447       ((partition)
 448        (uuid-bytevector (partition-uuid partition)))))
 449
 450   (let* ((os (image-operating-system image))
 451          (bootloader (bootloader-package bootloader))
 452          (compression? (image-compression? image))
 453          (substitutable? (image-substitutable? image))
 454          (schema (local-file (search-path %load-path
 455                                           "guix/store/schema.sql")))
 456          (graph (match inputs
 457                   (((names . _) ...)
 458                    names)))
 459          (builder
 460           (with-imported-modules*
 461            (let* ((inputs '#$(list parted e2fsprogs dosfstools xorriso
 462                                    sed grep coreutils findutils gawk))
 463                   (image-root "tmp-root"))
 464              (sql-schema #$schema)
 465
 466              ;; Allow non-ASCII file names--e.g., 'nss-certs'--to be decoded.
 467              (setenv "GUIX_LOCPATH"
 468                      #+(file-append glibc-utf8-locales "/lib/locale"))
 469
 470              (setlocale LC_ALL "en_US.utf8")
 471
 472              (set-path-environment-variable "PATH" '("bin" "sbin") inputs)
 473
 474              (initialize-root-partition image-root
 475                                         #:references-graphs '#$graph
 476                                         #:deduplicate? #f
 477                                         #:system-directory #$os)
 478              (make-iso9660-image #$xorriso
 479                                  '#$grub-mkrescue-environment
 480                                  #$bootloader
 481                                  #$bootcfg
 482                                  #$os
 483                                  image-root
 484                                  #$output
 485                                  #:references-graphs '#$graph
 486                                  #:register-closures? #$register-closures?
 487                                  #:compression? #$compression?
 488                                  #:volume-id #$root-label
 489                                  #:volume-uuid #$root-uuid)))))
 490     (computed-file name builder
 491                    #:options `(#:references-graphs ,inputs
 492                                #:substitutable? ,substitutable?))))
 493
 494 (define (image-with-label base-image label)
 495   "The volume ID of an ISO is the label of the first partition.  This procedure
 496 returns an image record where the first partition's label is set to <label>."
 497   (image
 498     (inherit base-image)
 499     (partitions
 500       (match (image-partitions base-image)
 501         ((boot others ...)
 502          (cons
 503            (partition
 504              (inherit boot)
 505              (label label))
 506            others))))))
 507
 508 \f
 509 ;;
 510 ;; Image creation.
 511 ;;
 512
 513 (define (image->root-file-system image)
 514   "Return the IMAGE root partition file-system type."
 515   (let ((format (image-format image)))
 516     (if (eq? format 'iso9660)
 517         "iso9660"
 518         (partition-file-system (find-root-partition image)))))
 519
 520 (define (root-size image)
 521   "Return the root partition size of IMAGE."
 522   (let* ((image-size (image-size image))
 523          (root-partition (find-root-partition image))
 524          (root-size (partition-size root-partition)))
 525     (cond
 526      ((and (eq? root-size 'guess) image-size)
 527       image-size)
 528      (else root-size))))
 529
 530 (define* (image-with-os* base-image os)
 531   "Return an image based on BASE-IMAGE but with the operating-system field set
 532 to OS.  Also set the UUID and the size of the root partition."
 533   (define root-file-system
 534     (srfi-1:find
 535      (lambda (fs)
 536        (string=? (file-system-mount-point fs) "/"))
 537      (operating-system-file-systems os)))
 538
 539   (image
 540    (inherit base-image)
 541    (operating-system os)
 542    (partitions
 543     (map (lambda (p)
 544            (if (root-partition? p)
 545                (partition
 546                 (inherit p)
 547                 (uuid (file-system-device root-file-system))
 548                 (size (root-size base-image)))
 549                p))
 550          (image-partitions base-image)))))
 551
 552 (define (operating-system-for-image image)
 553   "Return an operating-system based on the one specified in IMAGE, but
 554 suitable for image creation.  Assign an UUID to the root file-system, so that
 555 it can be used for bootloading."
 556   (define volatile-root? (image-volatile-root? image))
 557
 558   (define (root-uuid os)
 559     ;; UUID of the root file system, computed in a deterministic fashion.
 560     ;; This is what we use to locate the root file system so it has to be
 561     ;; different from the user's own file system UUIDs.
 562     (let ((type (if (eq? (image-format image) 'iso9660)
 563                     'iso9660
 564                     'dce)))
 565       (operating-system-uuid os type)))
 566
 567   (let* ((root-file-system-type (image->root-file-system image))
 568          (base-os (image-operating-system image))
 569          (file-systems-to-keep
 570           (srfi-1:remove
 571            (lambda (fs)
 572              (string=? (file-system-mount-point fs) "/"))
 573            (operating-system-file-systems base-os)))
 574          (format (image-format image))
 575          (os
 576           (operating-system
 577             (inherit base-os)
 578             (initrd (lambda (file-systems . rest)
 579                       (apply (operating-system-initrd base-os)
 580                              file-systems
 581                              #:volatile-root? volatile-root?
 582                              rest)))
 583             (bootloader (if (eq? format 'iso9660)
 584                             (bootloader-configuration
 585                              (inherit
 586                               (operating-system-bootloader base-os))
 587                              (bootloader grub-mkrescue-bootloader))
 588                             (operating-system-bootloader base-os)))
 589             (file-systems (cons (file-system
 590                                   (mount-point "/")
 591                                   (device "/dev/placeholder")
 592                                   (type root-file-system-type))
 593                                 file-systems-to-keep))))
 594          (uuid (root-uuid os)))
 595     (operating-system
 596       (inherit os)
 597       (file-systems (cons (file-system
 598                             (mount-point "/")
 599                             (device uuid)
 600                             (type root-file-system-type))
 601                           file-systems-to-keep)))))
 602
 603 (define* (system-image image)
 604   "Return the derivation of IMAGE.  It can be a raw disk-image or an ISO9660
 605 image, depending on IMAGE format."
 606   (define substitutable? (image-substitutable? image))
 607   (define target (image-target image))
 608
 609   (with-parameters ((%current-target-system target))
 610     (let* ((os (operating-system-for-image image))
 611            (image* (image-with-os* image os))
 612            (image-format (image-format image))
 613            (register-closures? (has-guix-service-type? os))
 614            (bootcfg (operating-system-bootcfg os))
 615            (bootloader (bootloader-configuration-bootloader
 616                         (operating-system-bootloader os))))
 617       (cond
 618        ((memq image-format '(disk-image compressed-qcow2))
 619          (system-disk-image image*
 620                             #:bootcfg bootcfg
 621                             #:bootloader bootloader
 622                             #:register-closures? register-closures?
 623                             #:inputs `(("system" ,os)
 624                                        ("bootcfg" ,bootcfg))))
 625        ((memq image-format '(iso9660))
 626          (system-iso9660-image
 627           image*
 628           #:bootcfg bootcfg
 629           #:bootloader bootloader
 630           #:register-closures? register-closures?
 631           #:inputs `(("system" ,os)
 632                      ("bootcfg" ,bootcfg))
 633           ;; Make sure to use a mode that does no imply
 634           ;; HFS+ tree creation that may fail with:
 635           ;;
 636           ;; "libisofs: FAILURE : Too much files to mangle,
 637           ;; cannot guarantee unique file names"
 638           ;;
 639           ;; This happens if some limits are exceeded, see:
 640           ;; https://lists.gnu.org/archive/html/grub-devel/2020-06/msg00048.html
 641           #:grub-mkrescue-environment
 642           '(("MKRESCUE_SED_MODE" . "mbr_only"))))))))
 643
 644 \f
 645 ;;
 646 ;; Image detection.
 647 ;;
 648
 649 (define (image-modules)
 650   "Return the list of image modules."
 651   (cons (resolve-interface '(gnu system image))
 652         (all-modules (map (lambda (entry)
 653                             `(,entry . "gnu/system/images/"))
 654                           %load-path)
 655                      #:warn warn-about-load-error)))
 656
 657 (define %image-types
 658   ;; The list of publically-known image types.
 659   (delay (fold-module-public-variables (lambda (obj result)
 660                                          (if (image-type? obj)
 661                                              (cons obj result)
 662                                              result))
 663                                        '()
 664                                        (image-modules))))
 665
 666 (define (lookup-image-type-by-name name)
 667   "Return the image type called NAME."
 668   (or (srfi-1:find (lambda (image-type)
 669                      (eq? name (image-type-name image-type)))
 670                    (force %image-types))
 671       (raise
 672        (formatted-message (G_ "~a: no such image type") name))))
 673
 674 ;;; image.scm ends here