gnu/system/image.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2020, 2021, 2022 Mathieu Othacehe <othacehe@gnu.org>
   3 ;;; Copyright © 2020 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
   4 ;;; Copyright © 2022 Pavel Shlyak <p.shlyak@pantherx.org>
   5 ;;; Copyright © 2022 Denis 'GNUtoo' Carikli <GNUtoo@cyberdimension.org>
   6 ;;; Copyright © 2022 Alex Griffin <a@ajgrf.com>
   7 ;;;
   8 ;;; This file is part of GNU Guix.
   9 ;;;
  10 ;;; GNU Guix is free software; you can redistribute it and/or modify it
  11 ;;; under the terms of the GNU General Public License as published by
  12 ;;; the Free Software Foundation; either version 3 of the License, or (at
  13 ;;; your option) any later version.
  14 ;;;
  15 ;;; GNU Guix is distributed in the hope that it will be useful, but
  16 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  17 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  18 ;;; GNU General Public License for more details.
  19 ;;;
  20 ;;; You should have received a copy of the GNU General Public License
  21 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
  22
  23 (define-module (gnu system image)
  24   #:use-module (guix diagnostics)
  25   #:use-module (guix discovery)
  26   #:use-module (guix gexp)
  27   #:use-module (guix modules)
  28   #:use-module (guix monads)
  29   #:use-module (guix records)
  30   #:use-module (guix store)
  31   #:use-module (guix ui)
  32   #:use-module (guix utils)
  33   #:use-module ((guix self) #:select (make-config.scm))
  34   #:use-module (gnu bootloader)
  35   #:use-module (gnu bootloader grub)
  36   #:use-module (gnu compression)
  37   #:use-module (gnu image)
  38   #:use-module (guix platform)
  39   #:use-module (gnu services)
  40   #:use-module (gnu services base)
  41   #:use-module (gnu system)
  42   #:use-module (gnu system accounts)
  43   #:use-module (gnu system file-systems)
  44   #:use-module (gnu system linux-container)
  45   #:use-module (gnu system uuid)
  46   #:use-module (gnu system vm)
  47   #:use-module (guix packages)
  48   #:use-module (gnu packages base)
  49   #:use-module (gnu packages bash)
  50   #:use-module (gnu packages bootloaders)
  51   #:use-module (gnu packages cdrom)
  52   #:use-module (gnu packages compression)
  53   #:use-module (gnu packages disk)
  54   #:use-module (gnu packages gawk)
  55   #:use-module (gnu packages genimage)
  56   #:use-module (gnu packages guile)
  57   #:autoload   (gnu packages gnupg) (guile-gcrypt)
  58   #:use-module (gnu packages hurd)
  59   #:use-module (gnu packages linux)
  60   #:use-module (gnu packages mtools)
  61   #:use-module (gnu packages virtualization)
  62   #:use-module ((srfi srfi-1) #:prefix srfi-1:)
  63   #:use-module (srfi srfi-11)
  64   #:use-module (srfi srfi-26)
  65   #:use-module (srfi srfi-34)
  66   #:use-module (srfi srfi-35)
  67   #:use-module (rnrs bytevectors)
  68   #:use-module (ice-9 format)
  69   #:use-module (ice-9 match)
  70   #:export (root-offset
  71             root-label
  72             image-without-os
  73
  74             esp-partition
  75             esp32-partition
  76             root-partition
  77
  78             efi-disk-image
  79             iso9660-image
  80             docker-image
  81             tarball-image
  82             wsl2-image
  83             raw-with-offset-disk-image
  84
  85             image-with-os
  86             efi-raw-image-type
  87             efi32-raw-image-type
  88             qcow2-image-type
  89             iso-image-type
  90             uncompressed-iso-image-type
  91             docker-image-type
  92             tarball-image-type
  93             wsl2-image-type
  94             raw-with-offset-image-type
  95
  96             image-with-label
  97             system-image
  98
  99             %image-types
 100             lookup-image-type-by-name))
 101
 102 \f
 103 ;;;
 104 ;;; Images definitions.
 105 ;;;
 106
 107 ;; This is the offset before the first partition. GRUB will install itself in
 108 ;; this post-MBR gap.
 109 (define root-offset (* 512 2048))
 110
 111 ;; Generic root partition label.
 112 (define root-label "Guix_image")
 113
 114 (define-syntax-rule (image-without-os . fields)
 115     "Return an image record with the mandatory operating-system field set to
 116 #false.  This is useful when creating an image record that will serve as a
 117 parent image record."
 118    (image (operating-system #false) . fields))
 119
 120 (define esp-partition
 121   (partition
 122    (size (* 40 (expt 2 20)))
 123    (offset root-offset)
 124    (label "GNU-ESP") ;cosmetic only
 125    ;; Use "vfat" here since this property is used when mounting.  The actual
 126    ;; FAT-ness is based on file system size (16 in this case).
 127    (file-system "vfat")
 128    (flags '(esp))
 129    (initializer (gexp initialize-efi-partition))))
 130
 131 (define esp32-partition
 132   (partition
 133    (inherit esp-partition)
 134    (initializer (gexp initialize-efi32-partition))))
 135
 136 (define root-partition
 137   (partition
 138    (size 'guess)
 139    (label root-label)
 140    (file-system "ext4")
 141    (flags '(boot))
 142    (initializer (gexp initialize-root-partition))))
 143
 144 (define efi-disk-image
 145   (image-without-os
 146    (format 'disk-image)
 147    (partitions (list esp-partition root-partition))))
 148
 149 (define efi32-disk-image
 150   (image-without-os
 151    (format 'disk-image)
 152    (partitions (list esp32-partition root-partition))))
 153
 154 (define iso9660-image
 155   (image-without-os
 156    (format 'iso9660)
 157    (partitions
 158     (list (partition
 159            (size 'guess)
 160            (label "GUIX_IMAGE")
 161            (flags '(boot)))))))
 162
 163 (define docker-image
 164   (image-without-os
 165    (format 'docker)))
 166
 167 (define tarball-image
 168   (image-without-os
 169    (format 'tarball)))
 170
 171 (define wsl2-image
 172   (image-without-os
 173    (format 'wsl2)))
 174
 175 (define* (raw-with-offset-disk-image #:optional (offset root-offset))
 176   (image-without-os
 177    (format 'disk-image)
 178    (partitions
 179     (list (partition
 180            (inherit root-partition)
 181            (offset offset))))
 182    ;; FIXME: Deleting and creating "/var/run" and "/tmp" on the overlayfs
 183    ;; fails.
 184    (volatile-root? #f)))
 185
 186 \f
 187 ;;;
 188 ;;; Images types.
 189 ;;;
 190
 191 (define-syntax-rule (image-with-os base-image os)
 192   "Return an image inheriting from BASE-IMAGE, with the operating-system field
 193 set to the given OS."
 194   (image
 195    (inherit base-image)
 196    (operating-system os)))
 197
 198 (define efi-raw-image-type
 199   (image-type
 200    (name 'efi-raw)
 201    (constructor (cut image-with-os efi-disk-image <>))))
 202
 203 (define efi32-raw-image-type
 204   (image-type
 205    (name 'efi32-raw)
 206    (constructor (cut image-with-os efi32-disk-image <>))))
 207
 208 (define qcow2-image-type
 209   (image-type
 210    (name 'qcow2)
 211    (constructor (cut image-with-os
 212                  (image
 213                   (inherit efi-disk-image)
 214                   (name 'image.qcow2)
 215                   (format 'compressed-qcow2))
 216                  <>))))
 217
 218 (define iso-image-type
 219   (image-type
 220    (name 'iso9660)
 221    (constructor (cut image-with-os iso9660-image <>))))
 222
 223 (define uncompressed-iso-image-type
 224   (image-type
 225    (name 'uncompressed-iso9660)
 226    (constructor (cut image-with-os
 227                  (image
 228                   (inherit iso9660-image)
 229                   (compression? #f))
 230                  <>))))
 231
 232 (define docker-image-type
 233   (image-type
 234    (name 'docker)
 235    (constructor (cut image-with-os docker-image <>))))
 236
 237 (define tarball-image-type
 238   (image-type
 239    (name 'tarball)
 240    (constructor (cut image-with-os tarball-image <>))))
 241
 242 (define wsl2-image-type
 243   (image-type
 244    (name 'wsl2)
 245    (constructor (cut image-with-os wsl2-image <>))))
 246
 247 (define raw-with-offset-image-type
 248   (image-type
 249    (name 'raw-with-offset)
 250    (constructor (cut image-with-os (raw-with-offset-disk-image) <>))))
 251
 252 \f
 253 ;;
 254 ;; Helpers.
 255 ;;
 256
 257 (define not-config?
 258   ;; Select (guix …) and (gnu …) modules, except (guix config).
 259   (match-lambda
 260     (('guix 'config) #f)
 261     (('guix rest ...) #t)
 262     (('gnu rest ...) #t)
 263     (rest #f)))
 264
 265 (define (partition->gexp partition)
 266   "Turn PARTITION, a <partition> object, into a list-valued gexp suitable for
 267 'make-partition-image'."
 268   #~'(#$@(list (partition-size partition))
 269       #$(partition-file-system partition)
 270       #$(partition-file-system-options partition)
 271       #$(partition-label partition)
 272       #$(and=> (partition-uuid partition)
 273                uuid-bytevector)
 274       #$(partition-flags partition)))
 275
 276 (define gcrypt-sqlite3&co
 277   ;; Guile-Gcrypt, Guile-SQLite3, and their propagated inputs.
 278   (srfi-1:append-map
 279    (lambda (package)
 280      (cons package
 281            (match (package-transitive-propagated-inputs package)
 282              (((labels packages) ...)
 283               packages))))
 284    (list guile-gcrypt guile-sqlite3)))
 285
 286 (define-syntax-rule (with-imported-modules* gexp* ...)
 287   (with-extensions gcrypt-sqlite3&co
 288     (with-imported-modules `(,@(source-module-closure
 289                                 '((gnu build image)
 290                                   (gnu build bootloader)
 291                                   (gnu build hurd-boot)
 292                                   (gnu build linux-boot)
 293                                   (guix store database))
 294                                 #:select? not-config?)
 295                              ((guix config) => ,(make-config.scm)))
 296       #~(begin
 297           (use-modules (gnu build image)
 298                        (gnu build bootloader)
 299                        (gnu build hurd-boot)
 300                        (gnu build linux-boot)
 301                        (guix store database)
 302                        (guix build utils))
 303           gexp* ...))))
 304
 305 (define (root-partition? partition)
 306   "Return true if PARTITION is the root partition, false otherwise."
 307   (member 'boot (partition-flags partition)))
 308
 309 (define (find-root-partition image)
 310   "Return the root partition of the given IMAGE."
 311   (or (srfi-1:find root-partition? (image-partitions image))
 312       (raise (formatted-message
 313               (G_ "image lacks a partition with the 'boot' flag")))))
 314
 315 (define (root-partition-index image)
 316   "Return the index of the root partition of the given IMAGE."
 317   (1+ (srfi-1:list-index root-partition? (image-partitions image))))
 318
 319 \f
 320 ;;
 321 ;; Disk image.
 322 ;;
 323
 324 (define* (system-disk-image image
 325                             #:key
 326                             (name "disk-image")
 327                             bootcfg
 328                             bootloader
 329                             register-closures?
 330                             (inputs '()))
 331   "Return as a file-like object, the disk-image described by IMAGE.  Said
 332 image can be copied on a USB stick as is.  BOOTLOADER is the bootloader that
 333 will be installed and configured according to BOOTCFG parameter.
 334
 335 Raw images of the IMAGE partitions are first created.  Then, genimage is used
 336 to assemble the partition images into a disk-image without resorting to a
 337 virtual machine.
 338
 339 INPUTS is a list of inputs (as for packages).  When REGISTER-CLOSURES? is
 340 true, register INPUTS in the store database of the image so that Guix can be
 341 used in the image."
 342
 343   (define genimage-name "image")
 344
 345   (define (image->genimage-cfg image)
 346     ;; Return as a file-like object, the genimage configuration file
 347     ;; describing the given IMAGE.
 348     (define (format->image-type format)
 349       ;; Return the genimage format corresponding to FORMAT.  For now, only
 350       ;; the hdimage format (raw disk-image) is supported.
 351       (cond
 352        ((memq format '(disk-image compressed-qcow2)) "hdimage")
 353        (else
 354         (raise (condition
 355                 (&message
 356                  (message
 357                   (format #f (G_ "unsupported image type: ~a")
 358                           format))))))))
 359
 360     (define (partition->dos-type partition)
 361       ;; Return the MBR partition type corresponding to the given PARTITION.
 362       ;; See: https://en.wikipedia.org/wiki/Partition_type.
 363       (let ((flags (partition-flags partition))
 364             (file-system (partition-file-system partition)))
 365         (cond
 366          ((member 'esp flags) "0xEF")
 367          ((string-prefix? "ext" file-system) "0x83")
 368          ((or (string=? file-system "vfat")
 369               (string=? file-system "fat16")) "0x0E")
 370          ((string=? file-system "fat32") "0x0C")
 371          (else
 372           (raise (condition
 373                   (&message
 374                    (message
 375                     (format #f (G_ "unsupported partition type: ~a")
 376                             file-system)))))))))
 377
 378     (define (partition->gpt-type partition)
 379       ;; Return the genimage GPT partition type code corresponding to the
 380       ;; given PARTITION.  See:
 381       ;; https://github.com/pengutronix/genimage/blob/master/README.rst
 382       (let ((flags (partition-flags partition))
 383             (file-system (partition-file-system partition)))
 384         (cond
 385          ((member 'esp flags) "U")
 386          ((string-prefix? "ext" file-system) "L")
 387          ((or (string=? file-system "vfat")
 388               (string=? file-system "fat16")
 389               (string=? file-system "fat32")) "F")
 390          (else
 391           (raise (condition
 392                   (&message
 393                    (message
 394                     (format #f (G_ "unsupported partition type: ~a")
 395                             file-system)))))))))
 396
 397     (define (partition-image partition)
 398       ;; Return as a file-like object, an image of the given PARTITION.  A
 399       ;; directory, filled by calling the PARTITION initializer procedure, is
 400       ;; first created within the store.  Then, an image of this directory is
 401       ;; created using tools such as 'mke2fs' or 'mkdosfs', depending on the
 402       ;; partition file-system type.
 403       (let* ((os (image-operating-system image))
 404              (schema (local-file (search-path %load-path
 405                                               "guix/store/schema.sql")))
 406              (graph (match inputs
 407                       (((names . _) ...)
 408                        names)))
 409              (type (partition-file-system partition))
 410              (image-builder
 411               (with-imported-modules*
 412                (let ((initializer (or #$(partition-initializer partition)
 413                                       initialize-root-partition))
 414                      (inputs '#+(list e2fsprogs fakeroot dosfstools mtools))
 415                      (image-root "tmp-root"))
 416                  (sql-schema #$schema)
 417
 418                  (set-path-environment-variable "PATH" '("bin" "sbin") inputs)
 419
 420                  ;; Allow non-ASCII file names--e.g., 'nss-certs'--to be
 421                  ;; decoded.
 422                  (setenv "GUIX_LOCPATH"
 423                          #+(file-append glibc-utf8-locales "/lib/locale"))
 424                  (setlocale LC_ALL "en_US.utf8")
 425
 426                  (initializer image-root
 427                               #:references-graphs '#$graph
 428                               #:deduplicate? #f
 429                               #:copy-closures? (not
 430                                                 #$(image-shared-store? image))
 431                               #:system-directory #$os
 432                               #:grub-efi #+grub-efi
 433                               #:grub-efi32 #+grub-efi32
 434                               #:bootloader-package
 435                               #+(bootloader-package bootloader)
 436                               #:bootloader-installer
 437                               #+(bootloader-installer bootloader)
 438                               #:bootcfg #$bootcfg
 439                               #:bootcfg-location
 440                               #$(bootloader-configuration-file bootloader))
 441                  (make-partition-image #$(partition->gexp partition)
 442                                        #$output
 443                                        image-root)))))
 444         (computed-file "partition.img" image-builder
 445                        ;; Allow offloading so that this I/O-intensive process
 446                        ;; doesn't run on the build farm's head node.
 447                        #:local-build? #f
 448                        #:options `(#:references-graphs ,inputs))))
 449
 450     (define (gpt-image? image)
 451       (eq? 'gpt (image-partition-table-type image)))
 452
 453     (define (partition-type-values image partition)
 454       (if (gpt-image? image)
 455           (values "partition-type-uuid" (partition->gpt-type partition))
 456           (values "partition-type" (partition->dos-type partition))))
 457
 458     (define (partition->config image partition)
 459       ;; Return the genimage partition configuration for PARTITION.
 460       (let-values (((partition-type-attribute partition-type-value)
 461                     (partition-type-values image partition)))
 462         (let ((label (partition-label partition))
 463               (image (partition-image partition))
 464               (offset (partition-offset partition))
 465               (bootable (if (memq 'boot (partition-flags partition))
 466                             "true" "false" )))
 467           #~(format #f "~/partition ~a {
 468   ~/~/~a = ~a
 469   ~/~/image = \"~a\"
 470   ~/~/offset = \"~a\"
 471   ~/~/bootable = \"~a\"
 472   ~/}"
 473                     #$label
 474                     #$partition-type-attribute
 475                     #$partition-type-value
 476                     #$image
 477                     #$offset
 478                     #$bootable))))
 479
 480     (define (genimage-type-options image-type image)
 481       (cond
 482        ((equal? image-type "hdimage")
 483         (format #f "~%~/~/partition-table-type = \"~a\"~%~/"
 484                 (image-partition-table-type image)))
 485        (else "")))
 486
 487     (let* ((format (image-format image))
 488            (image-type (format->image-type format))
 489            (image-type-options (genimage-type-options image-type image))
 490            (partitions (image-partitions image))
 491            (partitions-config (map (cut partition->config image <>) partitions))
 492            (builder
 493             #~(begin
 494                 (let ((format (@ (ice-9 format) format)))
 495                   (call-with-output-file #$output
 496                     (lambda (port)
 497                       (format port
 498                               "\
 499 image ~a {
 500 ~/~a {~a}
 501 ~{~a~^~%~}
 502 }~%" #$genimage-name #$image-type #$image-type-options
 503  (list #$@partitions-config))))))))
 504       (computed-file "genimage.cfg" builder)))
 505
 506   (let* ((image-name (image-name image))
 507          (name (if image-name
 508                    (symbol->string image-name)
 509                    name))
 510          (format (image-format image))
 511          (substitutable? (image-substitutable? image))
 512          (builder
 513           (with-imported-modules*
 514            (let ((inputs '#+(list genimage coreutils findutils qemu-minimal))
 515                  (bootloader-installer
 516                   #+(bootloader-disk-image-installer bootloader))
 517                  (out-image (string-append "images/" #$genimage-name)))
 518              (set-path-environment-variable "PATH" '("bin" "sbin") inputs)
 519              (genimage #$(image->genimage-cfg image))
 520              ;; Install the bootloader directly on the disk-image.
 521              (when bootloader-installer
 522                (bootloader-installer
 523                 #+(bootloader-package bootloader)
 524                 #$(root-partition-index image)
 525                 out-image))
 526              (convert-disk-image out-image '#$format #$output)))))
 527     (computed-file name builder
 528                    #:local-build? #f              ;too I/O-intensive
 529                    #:options `(#:substitutable? ,substitutable?))))
 530
 531 \f
 532 ;;
 533 ;; ISO9660 image.
 534 ;;
 535
 536 (define (has-guix-service-type? os)
 537   "Return true if OS contains a service of the type GUIX-SERVICE-TYPE."
 538   (not (not (srfi-1:find (lambda (service)
 539                            (eq? (service-kind service) guix-service-type))
 540                          (operating-system-services os)))))
 541
 542 (define* (system-iso9660-image image
 543                                #:key
 544                                (name "image.iso")
 545                                bootcfg
 546                                bootloader
 547                                register-closures?
 548                                (inputs '())
 549                                (grub-mkrescue-environment '()))
 550   "Return as a file-like object a bootable, stand-alone iso9660 image.
 551
 552 INPUTS is a list of inputs (as for packages).  When REGISTER-CLOSURES? is
 553 true, register INPUTS in the store database of the image so that Guix can be
 554 used in the image. "
 555   (define root-label
 556     (match (image-partitions image)
 557       ((partition)
 558        (partition-label partition))))
 559
 560   (define root-uuid
 561     (match (image-partitions image)
 562       ((partition)
 563        (uuid-bytevector (partition-uuid partition)))))
 564
 565   (let* ((os (image-operating-system image))
 566          (bootloader (bootloader-package bootloader))
 567          (compression? (image-compression? image))
 568          (substitutable? (image-substitutable? image))
 569          (schema (local-file (search-path %load-path
 570                                           "guix/store/schema.sql")))
 571          (graph (match inputs
 572                   (((names . _) ...)
 573                    names)))
 574          (builder
 575           (with-imported-modules*
 576            (let* ((inputs '#$(list parted e2fsprogs dosfstools xorriso
 577                                    sed grep coreutils findutils gawk))
 578                   (image-root "tmp-root"))
 579              (sql-schema #$schema)
 580
 581              ;; Allow non-ASCII file names--e.g., 'nss-certs'--to be decoded.
 582              (setenv "GUIX_LOCPATH"
 583                      #+(file-append glibc-utf8-locales "/lib/locale"))
 584
 585              (setlocale LC_ALL "en_US.utf8")
 586
 587              (set-path-environment-variable "PATH" '("bin" "sbin") inputs)
 588
 589              (initialize-root-partition image-root
 590                                         #:references-graphs '#$graph
 591                                         #:deduplicate? #f
 592                                         #:system-directory #$os)
 593              (make-iso9660-image #$xorriso
 594                                  '#$grub-mkrescue-environment
 595                                  #$bootloader
 596                                  #$bootcfg
 597                                  #$os
 598                                  image-root
 599                                  #$output
 600                                  #:references-graphs '#$graph
 601                                  #:register-closures? #$register-closures?
 602                                  #:compression? #$compression?
 603                                  #:volume-id #$root-label
 604                                  #:volume-uuid #$root-uuid)))))
 605     (computed-file name builder
 606                    ;; Allow offloading so that this I/O-intensive process
 607                    ;; doesn't run on the build farm's head node.
 608                    #:local-build? #f
 609                    #:options `(#:references-graphs ,inputs
 610                                #:substitutable? ,substitutable?))))
 611
 612 (define (image-with-label base-image label)
 613   "The volume ID of an ISO is the label of the first partition.  This procedure
 614 returns an image record where the first partition's label is set to <label>."
 615   (image
 616     (inherit base-image)
 617     (partitions
 618       (match (image-partitions base-image)
 619         ((boot others ...)
 620          (cons
 621            (partition
 622              (inherit boot)
 623              (label label))
 624            others))))))
 625
 626 \f
 627 ;;
 628 ;; Docker image.
 629 ;;
 630
 631 (define* (system-docker-image image
 632                               #:key
 633                               (name "docker-image"))
 634   "Build a docker image for IMAGE.  NAME is the base name to use for the
 635 output file."
 636   (define boot-program
 637     ;; Program that runs the boot script of OS, which in turn starts shepherd.
 638     (program-file "boot-program"
 639                   #~(let ((system (cadr (command-line))))
 640                       (setenv "GUIX_NEW_SYSTEM" system)
 641                       (execl #$(file-append guile-3.0 "/bin/guile")
 642                              "guile" "--no-auto-compile"
 643                              (string-append system "/boot")))))
 644
 645   (define shared-network?
 646     (image-shared-network? image))
 647
 648   (let* ((os (operating-system-with-gc-roots
 649               (containerized-operating-system
 650                (image-operating-system image) '()
 651                #:shared-network?
 652                shared-network?)
 653               (list boot-program)))
 654          (substitutable? (image-substitutable? image))
 655          (image-target (or (%current-target-system)
 656                            (nix-system->gnu-triplet)))
 657          (register-closures? (has-guix-service-type? os))
 658          (schema (and register-closures?
 659                       (local-file (search-path %load-path
 660                                                "guix/store/schema.sql"))))
 661          (name (string-append name ".tar.gz"))
 662          (graph "system-graph"))
 663     (define builder
 664       (with-extensions (cons guile-json-3         ;for (guix docker)
 665                              gcrypt-sqlite3&co)   ;for (guix store database)
 666         (with-imported-modules `(,@(source-module-closure
 667                                     '((guix docker)
 668                                       (guix store database)
 669                                       (guix build utils)
 670                                       (guix build store-copy)
 671                                       (gnu build image))
 672                                     #:select? not-config?)
 673                                  ((guix config) => ,(make-config.scm)))
 674           #~(begin
 675               (use-modules (guix docker)
 676                            (guix build utils)
 677                            (gnu build image)
 678                            (srfi srfi-19)
 679                            (guix build store-copy)
 680                            (guix store database))
 681
 682               ;; Set the SQL schema location.
 683               (sql-schema #$schema)
 684
 685               ;; Allow non-ASCII file names--e.g., 'nss-certs'--to be decoded.
 686               (setenv "GUIX_LOCPATH"
 687                       #+(file-append glibc-utf8-locales "/lib/locale"))
 688               (setlocale LC_ALL "en_US.utf8")
 689
 690               (set-path-environment-variable "PATH" '("bin" "sbin") '(#+tar))
 691
 692               (let ((image-root (string-append (getcwd) "/tmp-root")))
 693                 (mkdir-p image-root)
 694                 (initialize-root-partition image-root
 695                                            #:references-graphs '(#$graph)
 696                                            #:copy-closures? #f
 697                                            #:register-closures? #$register-closures?
 698                                            #:deduplicate? #f
 699                                            #:system-directory #$os)
 700                 (build-docker-image
 701                  #$output
 702                  (cons* image-root
 703                         (map store-info-item
 704                              (call-with-input-file #$graph
 705                                read-reference-graph)))
 706                  #$os
 707                  #:entry-point '(#$boot-program #$os)
 708                  #:compressor '(#+(file-append gzip "/bin/gzip") "-9n")
 709                  #:creation-time (make-time time-utc 0 1)
 710                  #:system #$image-target
 711                  #:transformations `((,image-root -> ""))))))))
 712
 713     (computed-file name builder
 714                    ;; Allow offloading so that this I/O-intensive process
 715                    ;; doesn't run on the build farm's head node.
 716                    #:local-build? #f
 717                    #:options `(#:references-graphs ((,graph ,os))
 718                                #:substitutable? ,substitutable?))))
 719
 720 \f
 721 ;;;
 722 ;;; Tarball image.
 723 ;;;
 724
 725 ;; TODO: Some bits can be factorized with (guix scripts pack).
 726 (define* (system-tarball-image image
 727                                #:key
 728                                (name "image")
 729                                (compressor (srfi-1:first %compressors))
 730                                (wsl? #f))
 731   "Build a tarball of IMAGE.  NAME is the base name to use for the
 732 output file."
 733   (let* ((os (image-operating-system image))
 734          (substitutable? (image-substitutable? image))
 735          (schema (local-file (search-path %load-path
 736                                           "guix/store/schema.sql")))
 737          (name (string-append name ".tar" (compressor-extension compressor)))
 738          (graph "system-graph")
 739          (root (srfi-1:find (lambda (user)
 740                               (and=> (user-account-uid user) zero?))
 741                             (operating-system-users os)))
 742          (root-shell (or (and=> root user-account-shell)
 743                          (file-append bash "/bin/bash"))))
 744     (define builder
 745       (with-extensions gcrypt-sqlite3&co          ;for (guix store database)
 746         (with-imported-modules `(,@(source-module-closure
 747                                     '((guix build pack)
 748                                       (guix build store-copy)
 749                                       (guix build utils)
 750                                       (guix store database)
 751                                       (gnu build image))
 752                                     #:select? not-config?)
 753                                  ((guix config) => ,(make-config.scm)))
 754           #~(begin
 755               (use-modules (guix build pack)
 756                            (guix build store-copy)
 757                            (guix build utils)
 758                            (guix store database)
 759                            (gnu build image))
 760
 761               ;; Set the SQL schema location.
 762               (sql-schema #$schema)
 763
 764               ;; Allow non-ASCII file names--e.g., 'nss-certs'--to be decoded.
 765               (setenv "GUIX_LOCPATH"
 766                       #+(file-append glibc-utf8-locales "/lib/locale"))
 767               (setlocale LC_ALL "en_US.utf8")
 768
 769               (let ((image-root (string-append (getcwd) "/tmp-root"))
 770                     (tar #+(file-append tar "/bin/tar")))
 771
 772                 (mkdir-p image-root)
 773                 (initialize-root-partition image-root
 774                                            #:references-graphs '(#$graph)
 775                                            #:deduplicate? #f
 776                                            #:system-directory #$os)
 777
 778                 (with-directory-excursion image-root
 779                   #$@(if wsl?
 780                          #~(;; WSL requires /bin/sh.  Will be overwritten by
 781                             ;; system activation.
 782                             (symlink #$root-shell "./bin/sh")
 783
 784                             ;; WSL requires /bin/mount to access the host fs.
 785                             (symlink #$(file-append util-linux "/bin/mount")
 786                                      "./bin/mount"))
 787                          #~())
 788
 789                   (apply invoke tar "-cvf" #$output "."
 790                          (tar-base-options
 791                           #:tar tar
 792                           #:compressor
 793                           #+(and=> compressor compressor-command)))))))))
 794
 795     (computed-file name builder
 796                    ;; Allow offloading so that this I/O-intensive process
 797                    ;; doesn't run on the build farm's head node.
 798                    #:local-build? #f
 799                    #:options `(#:references-graphs ((,graph ,os))
 800                                #:substitutable? ,substitutable?))))
 801
 802 \f
 803 ;;
 804 ;; Image creation.
 805 ;;
 806
 807 (define (image->root-file-system image)
 808   "Return the IMAGE root partition file-system type."
 809   (case (image-format image)
 810     ((iso9660) "iso9660")
 811     ((docker tarball wsl2) "dummy")
 812     (else
 813      (partition-file-system (find-root-partition image)))))
 814
 815 (define (root-size image)
 816   "Return the root partition size of IMAGE."
 817   (let* ((image-size (image-size image))
 818          (root-partition (find-root-partition image))
 819          (root-size (partition-size root-partition)))
 820     (cond
 821      ((and (eq? root-size 'guess) image-size)
 822       image-size)
 823      (else root-size))))
 824
 825 (define* (image-with-os* base-image os)
 826   "Return an image based on BASE-IMAGE but with the operating-system field set
 827 to OS.  Also set the UUID and the size of the root partition."
 828   (define root-file-system
 829     (srfi-1:find
 830      (lambda (fs)
 831        (string=? (file-system-mount-point fs) "/"))
 832      (operating-system-file-systems os)))
 833
 834   (image
 835    (inherit base-image)
 836    (operating-system os)
 837    (partitions
 838     (map (lambda (p)
 839            (if (root-partition? p)
 840                (partition
 841                 (inherit p)
 842                 (uuid (file-system-device root-file-system))
 843                 (size (root-size base-image)))
 844                p))
 845          (image-partitions base-image)))))
 846
 847 (define (operating-system-for-image image)
 848   "Return an operating-system based on the one specified in IMAGE, but
 849 suitable for image creation.  Assign an UUID to the root file-system, so that
 850 it can be used for bootloading."
 851   (define volatile-root? (if (eq? (image-format image) 'iso9660)
 852                              #t
 853                              (image-volatile-root? image)))
 854
 855   (define (root-uuid os)
 856     ;; UUID of the root file system, computed in a deterministic fashion.
 857     ;; This is what we use to locate the root file system so it has to be
 858     ;; different from the user's own file system UUIDs.
 859     (let ((type (if (eq? (image-format image) 'iso9660)
 860                     'iso9660
 861                     'dce)))
 862       (operating-system-uuid os type)))
 863
 864   (let* ((root-file-system-type (image->root-file-system image))
 865          (base-os (image-operating-system image))
 866          (file-systems-to-keep
 867           (srfi-1:remove
 868            (lambda (fs)
 869              (let ((mount-point (file-system-mount-point fs)))
 870                (or (string=? mount-point "/")
 871                    (string=? mount-point "/boot/efi"))))
 872            (operating-system-file-systems base-os)))
 873          (format (image-format image))
 874          (os
 875           (operating-system
 876             (inherit base-os)
 877             (initrd (lambda (file-systems . rest)
 878                       (apply (operating-system-initrd base-os)
 879                              file-systems
 880                              #:volatile-root? volatile-root?
 881                              rest)))
 882             (bootloader (if (eq? format 'iso9660)
 883                             (bootloader-configuration
 884                              (inherit
 885                               (operating-system-bootloader base-os))
 886                              (bootloader grub-mkrescue-bootloader))
 887                             (operating-system-bootloader base-os)))
 888             (file-systems (cons (file-system
 889                                   (mount-point "/")
 890                                   (device "/dev/placeholder")
 891                                   (type root-file-system-type))
 892                                 file-systems-to-keep))))
 893          (uuid (root-uuid os)))
 894     (operating-system
 895       (inherit os)
 896       (file-systems (cons (file-system
 897                             (mount-point "/")
 898                             (device uuid)
 899                             (type root-file-system-type))
 900                           file-systems-to-keep)))))
 901
 902 (define* (system-image image)
 903   "Return the derivation of IMAGE.  It can be a raw disk-image or an ISO9660
 904 image, depending on IMAGE format."
 905   (define platform (image-platform image))
 906
 907   ;; The image platform definition may provide the appropriate "system"
 908   ;; architecture for the image.  If we are already running on this system,
 909   ;; the image can be built natively.  If we are running on a different
 910   ;; system, then we need to cross-compile, using the "target" provided by the
 911   ;; image definition.
 912   (define system (and=> platform platform-system))
 913   (define target (cond
 914                   ;; No defined platform, let's use the user defined
 915                   ;; system/target parameters.
 916                   ((not platform)
 917                    (%current-target-system))
 918                   ;; The current system is the same as the platform system, no
 919                   ;; need to cross-compile.
 920                   ((and system
 921                         (string=? system (%current-system)))
 922                    #f)
 923                   ;; If there is a user defined target let's override the
 924                   ;; platform target. Otherwise, we can cross-compile to the
 925                   ;; platform target.
 926                   (else
 927                    (or (%current-target-system)
 928                        (and=> platform platform-target)))))
 929
 930   (with-parameters ((%current-target-system target))
 931     (let* ((os (operating-system-for-image image))
 932            (image* (image-with-os* image os))
 933            (image-format (image-format image))
 934            (register-closures? (has-guix-service-type? os))
 935            (bootcfg (operating-system-bootcfg os))
 936            (bootloader (bootloader-configuration-bootloader
 937                         (operating-system-bootloader os))))
 938       (cond
 939        ((memq image-format '(disk-image compressed-qcow2))
 940          (system-disk-image image*
 941                             #:bootcfg bootcfg
 942                             #:bootloader bootloader
 943                             #:register-closures? register-closures?
 944                             #:inputs `(("system" ,os)
 945                                        ("bootcfg" ,bootcfg))))
 946        ((memq image-format '(docker))
 947         (system-docker-image image*))
 948        ((memq image-format '(tarball))
 949         (system-tarball-image image*))
 950        ((memq image-format '(wsl2))
 951         (system-tarball-image image* #:wsl? #t))
 952        ((memq image-format '(iso9660))
 953          (system-iso9660-image
 954           image*
 955           #:bootcfg bootcfg
 956           #:bootloader bootloader
 957           #:register-closures? register-closures?
 958           #:inputs `(("system" ,os)
 959                      ("bootcfg" ,bootcfg))
 960           ;; Make sure to use a mode that does no imply
 961           ;; HFS+ tree creation that may fail with:
 962           ;;
 963           ;; "libisofs: FAILURE : Too much files to mangle,
 964           ;; cannot guarantee unique file names"
 965           ;;
 966           ;; This happens if some limits are exceeded, see:
 967           ;; https://lists.gnu.org/archive/html/grub-devel/2020-06/msg00048.html
 968           #:grub-mkrescue-environment
 969           '(("MKRESCUE_SED_MODE" . "mbr_only"))))
 970        (else
 971         (raise (formatted-message
 972                 (G_ "~a: unsupported image format") image-format)))))))
 973
 974 \f
 975 ;;
 976 ;; Image detection.
 977 ;;
 978
 979 (define (image-modules)
 980   "Return the list of image modules."
 981   (cons (resolve-interface '(gnu system image))
 982         (all-modules (map (lambda (entry)
 983                             `(,entry . "gnu/system/images/"))
 984                           %load-path)
 985                      #:warn warn-about-load-error)))
 986
 987 (define %image-types
 988   ;; The list of publically-known image types.
 989   (delay (fold-module-public-variables (lambda (obj result)
 990                                          (if (image-type? obj)
 991                                              (cons obj result)
 992                                              result))
 993                                        '()
 994                                        (image-modules))))
 995
 996 (define (lookup-image-type-by-name name)
 997   "Return the image type called NAME."
 998   (or (srfi-1:find (lambda (image-type)
 999                      (eq? name (image-type-name image-type)))
1000                    (force %image-types))
1001       (raise
1002        (formatted-message (G_ "~a: no such image type") name))))
1003
1004 ;;; image.scm ends here