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