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