gnu/system/image.scm

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