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