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