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 diagnostics)
  22   #:use-module (guix discovery)
  23   #:use-module (guix gexp)
  24   #:use-module (guix modules)
  25   #:use-module (guix monads)
  26   #:use-module (guix records)
  27   #:use-module (guix store)
  28   #:use-module (guix ui)
  29   #:use-module (guix utils)
  30   #:use-module ((guix self) #:select (make-config.scm))
  31   #:use-module (gnu bootloader)
  32   #:use-module (gnu bootloader grub)
  33   #:use-module (gnu image)
  34   #:use-module (gnu services)
  35   #:use-module (gnu services base)
  36   #:use-module (gnu system)
  37   #:use-module (gnu system file-systems)
  38   #:use-module (gnu system uuid)
  39   #:use-module (gnu system vm)
  40   #:use-module (guix packages)
  41   #:use-module (gnu packages base)
  42   #:use-module (gnu packages bootloaders)
  43   #:use-module (gnu packages cdrom)
  44   #:use-module (gnu packages disk)
  45   #:use-module (gnu packages gawk)
  46   #:use-module (gnu packages genimage)
  47   #:use-module (gnu packages guile)
  48   #:autoload   (gnu packages gnupg) (guile-gcrypt)
  49   #:use-module (gnu packages hurd)
  50   #:use-module (gnu packages linux)
  51   #:use-module (gnu packages mtools)
  52   #:use-module (gnu packages virtualization)
  53   #:use-module ((srfi srfi-1) #:prefix srfi-1:)
  54   #:use-module (srfi srfi-11)
  55   #:use-module (srfi srfi-26)
  56   #:use-module (srfi srfi-34)
  57   #:use-module (srfi srfi-35)
  58   #:use-module (rnrs bytevectors)
  59   #:use-module (ice-9 format)
  60   #:use-module (ice-9 match)
  61   #:export (root-offset
  62             root-label
  63
  64             esp-partition
  65             root-partition
  66
  67             efi-disk-image
  68             iso9660-image
  69             arm32-disk-image
  70             arm64-disk-image
  71
  72             image-with-os
  73             efi-raw-image-type
  74             qcow2-image-type
  75             iso-image-type
  76             uncompressed-iso-image-type
  77             arm32-image-type
  78             arm64-image-type
  79
  80             image-with-label
  81             system-image
  82
  83             %image-types
  84             lookup-image-type-by-name))
  85
  86 \f
  87 ;;;
  88 ;;; Images definitions.
  89 ;;;
  90
  91 ;; This is the offset before the first partition. GRUB will install itself in
  92 ;; this post-MBR gap.
  93 (define root-offset (* 512 2048))
  94
  95 ;; Generic root partition label.
  96 (define root-label "Guix_image")
  97
  98 (define esp-partition
  99   (partition
 100    (size (* 40 (expt 2 20)))
 101    (offset root-offset)
 102    (label "GNU-ESP") ;cosmetic only
 103    ;; Use "vfat" here since this property is used when mounting.  The actual
 104    ;; FAT-ness is based on file system size (16 in this case).
 105    (file-system "vfat")
 106    (flags '(esp))
 107    (initializer (gexp initialize-efi-partition))))
 108
 109 (define root-partition
 110   (partition
 111    (size 'guess)
 112    (label root-label)
 113    (file-system "ext4")
 114    (flags '(boot))
 115    (initializer (gexp initialize-root-partition))))
 116
 117 (define efi-disk-image
 118   (image
 119    (format 'disk-image)
 120    (partitions (list esp-partition root-partition))))
 121
 122 (define iso9660-image
 123   (image
 124    (format 'iso9660)
 125    (partitions
 126     (list (partition
 127            (size 'guess)
 128            (label "GUIX_IMAGE")
 129            (flags '(boot)))))))
 130
 131 (define* (arm32-disk-image #:optional (offset root-offset))
 132   (image
 133    (format 'disk-image)
 134    (target "arm-linux-gnueabihf")
 135    (partitions
 136     (list (partition
 137            (inherit root-partition)
 138            (offset offset))))
 139    ;; FIXME: Deleting and creating "/var/run" and "/tmp" on the overlayfs
 140    ;; fails.
 141    (volatile-root? #f)))
 142
 143 (define* (arm64-disk-image #:optional (offset root-offset))
 144   (image
 145    (inherit (arm32-disk-image offset))
 146    (target "aarch64-linux-gnu")))
 147
 148 \f
 149 ;;;
 150 ;;; Images types.
 151 ;;;
 152
 153 (define-syntax-rule (image-with-os base-image os)
 154   "Return an image inheriting from BASE-IMAGE, with the operating-system field
 155 set to the given OS."
 156   (image
 157    (inherit base-image)
 158    (operating-system os)))
 159
 160 (define efi-raw-image-type
 161   (image-type
 162    (name 'efi-raw)
 163    (constructor (cut image-with-os efi-disk-image <>))))
 164
 165 (define qcow2-image-type
 166   (image-type
 167    (name 'qcow2)
 168    (constructor (cut image-with-os
 169                  (image
 170                   (inherit efi-disk-image)
 171                   (name 'image.qcow2)
 172                   (format 'compressed-qcow2))
 173                  <>))))
 174
 175 (define iso-image-type
 176   (image-type
 177    (name 'iso9660)
 178    (constructor (cut image-with-os iso9660-image <>))))
 179
 180 (define uncompressed-iso-image-type
 181   (image-type
 182    (name 'uncompressed-iso9660)
 183    (constructor (cut image-with-os
 184                  (image
 185                   (inherit iso9660-image)
 186                   (compression? #f))
 187                  <>))))
 188
 189 (define arm32-image-type
 190   (image-type
 191    (name 'arm32-raw)
 192    (constructor (cut image-with-os (arm32-disk-image) <>))))
 193
 194 (define arm64-image-type
 195   (image-type
 196    (name 'arm64-raw)
 197    (constructor (cut image-with-os (arm64-disk-image) <>))))
 198
 199 \f
 200 ;;
 201 ;; Helpers.
 202 ;;
 203
 204 (define not-config?
 205   ;; Select (guix …) and (gnu …) modules, except (guix config).
 206   (match-lambda
 207     (('guix 'config) #f)
 208     (('guix rest ...) #t)
 209     (('gnu rest ...) #t)
 210     (rest #f)))
 211
 212 (define (partition->gexp partition)
 213   "Turn PARTITION, a <partition> object, into a list-valued gexp suitable for
 214 'make-partition-image'."
 215   #~'(#$@(list (partition-size partition))
 216       #$(partition-file-system partition)
 217       #$(partition-file-system-options partition)
 218       #$(partition-label partition)
 219       #$(and=> (partition-uuid partition)
 220                uuid-bytevector)))
 221
 222 (define gcrypt-sqlite3&co
 223   ;; Guile-Gcrypt, Guile-SQLite3, and their propagated inputs.
 224   (srfi-1:append-map
 225    (lambda (package)
 226      (cons package
 227            (match (package-transitive-propagated-inputs package)
 228              (((labels packages) ...)
 229               packages))))
 230    (list guile-gcrypt guile-sqlite3)))
 231
 232 (define-syntax-rule (with-imported-modules* gexp* ...)
 233   (with-extensions gcrypt-sqlite3&co
 234     (with-imported-modules `(,@(source-module-closure
 235                                 '((gnu build vm)
 236                                   (gnu build image)
 237                                   (gnu build bootloader)
 238                                   (gnu build hurd-boot)
 239                                   (gnu build linux-boot)
 240                                   (guix store database))
 241                                 #:select? not-config?)
 242                              ((guix config) => ,(make-config.scm)))
 243       #~(begin
 244           (use-modules (gnu build vm)
 245                        (gnu build image)
 246                        (gnu build bootloader)
 247                        (gnu build hurd-boot)
 248                        (gnu build linux-boot)
 249                        (guix store database)
 250                        (guix build utils))
 251           gexp* ...))))
 252
 253 (define (root-partition? partition)
 254   "Return true if PARTITION is the root partition, false otherwise."
 255   (member 'boot (partition-flags partition)))
 256
 257 (define (find-root-partition image)
 258   "Return the root partition of the given IMAGE."
 259   (srfi-1:find root-partition? (image-partitions image)))
 260
 261 (define (root-partition-index image)
 262   "Return the index of the root partition of the given IMAGE."
 263   (1+ (srfi-1:list-index root-partition? (image-partitions image))))
 264
 265 \f
 266 ;;
 267 ;; Disk image.
 268 ;;
 269
 270 (define* (system-disk-image image
 271                             #:key
 272                             (name "disk-image")
 273                             bootcfg
 274                             bootloader
 275                             register-closures?
 276                             (inputs '()))
 277   "Return as a file-like object, the disk-image described by IMAGE.  Said
 278 image can be copied on a USB stick as is.  BOOTLOADER is the bootloader that
 279 will be installed and configured according to BOOTCFG parameter.
 280
 281 Raw images of the IMAGE partitions are first created.  Then, genimage is used
 282 to assemble the partition images into a disk-image without resorting to a
 283 virtual machine.
 284
 285 INPUTS is a list of inputs (as for packages).  When REGISTER-CLOSURES? is
 286 true, register INPUTS in the store database of the image so that Guix can be
 287 used in the image."
 288
 289   (define genimage-name "image")
 290
 291   (define (image->genimage-cfg image)
 292     ;; Return as a file-like object, the genimage configuration file
 293     ;; describing the given IMAGE.
 294     (define (format->image-type format)
 295       ;; Return the genimage format corresponding to FORMAT.  For now, only
 296       ;; the hdimage format (raw disk-image) is supported.
 297       (cond
 298        ((memq format '(disk-image compressed-qcow2)) "hdimage")
 299         (else
 300          (raise (condition
 301                  (&message
 302                   (message
 303                    (format #f (G_ "Unsupported image type ~a~%.") format))))))))
 304
 305     (define (partition->dos-type partition)
 306       ;; Return the MBR partition type corresponding to the given PARTITION.
 307       ;; See: https://en.wikipedia.org/wiki/Partition_type.
 308       (let ((flags (partition-flags partition)))
 309         (cond
 310          ((member 'esp flags) "0xEF")
 311          (else "0x83"))))
 312
 313     (define (partition-image partition)
 314       ;; Return as a file-like object, an image of the given PARTITION.  A
 315       ;; directory, filled by calling the PARTITION initializer procedure, is
 316       ;; first created within the store.  Then, an image of this directory is
 317       ;; created using tools such as 'mke2fs' or 'mkdosfs', depending on the
 318       ;; partition file-system type.
 319       (let* ((os (image-operating-system image))
 320              (schema (local-file (search-path %load-path
 321                                               "guix/store/schema.sql")))
 322              (graph (match inputs
 323                       (((names . _) ...)
 324                        names)))
 325              (type (partition-file-system partition))
 326              (image-builder
 327               (with-imported-modules*
 328                (let ((initializer #$(partition-initializer partition))
 329                      (inputs '#+(list e2fsprogs fakeroot dosfstools mtools))
 330                      (image-root "tmp-root"))
 331                  (sql-schema #$schema)
 332
 333                  (set-path-environment-variable "PATH" '("bin" "sbin") inputs)
 334
 335                  ;; Allow non-ASCII file names--e.g., 'nss-certs'--to be
 336                  ;; decoded.
 337                  (setenv "GUIX_LOCPATH"
 338                          #+(file-append glibc-utf8-locales "/lib/locale"))
 339                  (setlocale LC_ALL "en_US.utf8")
 340
 341                  (initializer image-root
 342                               #:references-graphs '#$graph
 343                               #:deduplicate? #f
 344                               #:system-directory #$os
 345                               #:grub-efi #+grub-efi
 346                               #:bootloader-package
 347                               #+(bootloader-package bootloader)
 348                               #:bootloader-installer
 349                               #+(bootloader-installer bootloader)
 350                               #:bootcfg #$bootcfg
 351                               #:bootcfg-location
 352                               #$(bootloader-configuration-file bootloader))
 353                  (make-partition-image #$(partition->gexp partition)
 354                                        #$output
 355                                        image-root)))))
 356         (computed-file "partition.img" image-builder
 357                        ;; Allow offloading so that this I/O-intensive process
 358                        ;; doesn't run on the build farm's head node.
 359                        #:local-build? #f
 360                        #:options `(#:references-graphs ,inputs))))
 361
 362     (define (partition->config partition)
 363       ;; Return the genimage partition configuration for PARTITION.
 364       (let ((label (partition-label partition))
 365             (dos-type (partition->dos-type partition))
 366             (image (partition-image partition))
 367             (offset (partition-offset partition)))
 368         #~(format #f "~/partition ~a {
 369 ~/~/partition-type = ~a
 370 ~/~/image = \"~a\"
 371 ~/~/offset = \"~a\"
 372 ~/}"
 373                   #$label
 374                   #$dos-type
 375                   #$image
 376                   #$offset)))
 377
 378     (let* ((format (image-format image))
 379            (image-type (format->image-type format))
 380            (partitions (image-partitions image))
 381            (partitions-config (map partition->config partitions))
 382            (builder
 383             #~(begin
 384                 (let ((format (@ (ice-9 format) format)))
 385                   (call-with-output-file #$output
 386                     (lambda (port)
 387                       (format port
 388                               "\
 389 image ~a {
 390 ~/~a {}
 391 ~{~a~^~%~}
 392 }~%" #$genimage-name #$image-type (list #$@partitions-config))))))))
 393       (computed-file "genimage.cfg" builder)))
 394
 395   (let* ((image-name (image-name image))
 396          (name (if image-name
 397                    (symbol->string image-name)
 398                    name))
 399          (format (image-format image))
 400          (substitutable? (image-substitutable? image))
 401          (builder
 402           (with-imported-modules*
 403            (let ((inputs '#+(list genimage coreutils findutils qemu-minimal))
 404                  (bootloader-installer
 405                   #+(bootloader-disk-image-installer bootloader))
 406                  (out-image (string-append "images/" #$genimage-name)))
 407              (set-path-environment-variable "PATH" '("bin" "sbin") inputs)
 408              (genimage #$(image->genimage-cfg image))
 409              ;; Install the bootloader directly on the disk-image.
 410              (when bootloader-installer
 411                (bootloader-installer
 412                 #+(bootloader-package bootloader)
 413                 #$(root-partition-index image)
 414                 out-image))
 415              (convert-disk-image out-image '#$format #$output)))))
 416     (computed-file name builder
 417                    #:local-build? #f              ;too I/O-intensive
 418                    #:options `(#:substitutable? ,substitutable?))))
 419
 420 \f
 421 ;;
 422 ;; ISO9660 image.
 423 ;;
 424
 425 (define (has-guix-service-type? os)
 426   "Return true if OS contains a service of the type GUIX-SERVICE-TYPE."
 427   (not (not (srfi-1:find (lambda (service)
 428                            (eq? (service-kind service) guix-service-type))
 429                          (operating-system-services os)))))
 430
 431 (define* (system-iso9660-image image
 432                                #:key
 433                                (name "image.iso")
 434                                bootcfg
 435                                bootloader
 436                                register-closures?
 437                                (inputs '())
 438                                (grub-mkrescue-environment '()))
 439   "Return as a file-like object a bootable, stand-alone iso9660 image.
 440
 441 INPUTS is a list of inputs (as for packages).  When REGISTER-CLOSURES? is
 442 true, register INPUTS in the store database of the image so that Guix can be
 443 used in the image. "
 444   (define root-label
 445     (match (image-partitions image)
 446       ((partition)
 447        (partition-label partition))))
 448
 449   (define root-uuid
 450     (match (image-partitions image)
 451       ((partition)
 452        (uuid-bytevector (partition-uuid partition)))))
 453
 454   (let* ((os (image-operating-system image))
 455          (bootloader (bootloader-package bootloader))
 456          (compression? (image-compression? image))
 457          (substitutable? (image-substitutable? image))
 458          (schema (local-file (search-path %load-path
 459                                           "guix/store/schema.sql")))
 460          (graph (match inputs
 461                   (((names . _) ...)
 462                    names)))
 463          (builder
 464           (with-imported-modules*
 465            (let* ((inputs '#$(list parted e2fsprogs dosfstools xorriso
 466                                    sed grep coreutils findutils gawk))
 467                   (image-root "tmp-root"))
 468              (sql-schema #$schema)
 469
 470              ;; Allow non-ASCII file names--e.g., 'nss-certs'--to be decoded.
 471              (setenv "GUIX_LOCPATH"
 472                      #+(file-append glibc-utf8-locales "/lib/locale"))
 473
 474              (setlocale LC_ALL "en_US.utf8")
 475
 476              (set-path-environment-variable "PATH" '("bin" "sbin") inputs)
 477
 478              (initialize-root-partition image-root
 479                                         #:references-graphs '#$graph
 480                                         #:deduplicate? #f
 481                                         #:system-directory #$os)
 482              (make-iso9660-image #$xorriso
 483                                  '#$grub-mkrescue-environment
 484                                  #$bootloader
 485                                  #$bootcfg
 486                                  #$os
 487                                  image-root
 488                                  #$output
 489                                  #:references-graphs '#$graph
 490                                  #:register-closures? #$register-closures?
 491                                  #:compression? #$compression?
 492                                  #:volume-id #$root-label
 493                                  #:volume-uuid #$root-uuid)))))
 494     (computed-file name builder
 495                    ;; Allow offloading so that this I/O-intensive process
 496                    ;; doesn't run on the build farm's head node.
 497                    #:local-build? #f
 498                    #:options `(#:references-graphs ,inputs
 499                                #:substitutable? ,substitutable?))))
 500
 501 (define (image-with-label base-image label)
 502   "The volume ID of an ISO is the label of the first partition.  This procedure
 503 returns an image record where the first partition's label is set to <label>."
 504   (image
 505     (inherit base-image)
 506     (partitions
 507       (match (image-partitions base-image)
 508         ((boot others ...)
 509          (cons
 510            (partition
 511              (inherit boot)
 512              (label label))
 513            others))))))
 514
 515 \f
 516 ;;
 517 ;; Image creation.
 518 ;;
 519
 520 (define (image->root-file-system image)
 521   "Return the IMAGE root partition file-system type."
 522   (let ((format (image-format image)))
 523     (if (eq? format 'iso9660)
 524         "iso9660"
 525         (partition-file-system (find-root-partition image)))))
 526
 527 (define (root-size image)
 528   "Return the root partition size of IMAGE."
 529   (let* ((image-size (image-size image))
 530          (root-partition (find-root-partition image))
 531          (root-size (partition-size root-partition)))
 532     (cond
 533      ((and (eq? root-size 'guess) image-size)
 534       image-size)
 535      (else root-size))))
 536
 537 (define* (image-with-os* base-image os)
 538   "Return an image based on BASE-IMAGE but with the operating-system field set
 539 to OS.  Also set the UUID and the size of the root partition."
 540   (define root-file-system
 541     (srfi-1:find
 542      (lambda (fs)
 543        (string=? (file-system-mount-point fs) "/"))
 544      (operating-system-file-systems os)))
 545
 546   (image
 547    (inherit base-image)
 548    (operating-system os)
 549    (partitions
 550     (map (lambda (p)
 551            (if (root-partition? p)
 552                (partition
 553                 (inherit p)
 554                 (uuid (file-system-device root-file-system))
 555                 (size (root-size base-image)))
 556                p))
 557          (image-partitions base-image)))))
 558
 559 (define (operating-system-for-image image)
 560   "Return an operating-system based on the one specified in IMAGE, but
 561 suitable for image creation.  Assign an UUID to the root file-system, so that
 562 it can be used for bootloading."
 563   (define volatile-root? (if (eq? (image-format image) 'iso9660)
 564                              #t
 565                              (image-volatile-root? image)))
 566
 567   (define (root-uuid os)
 568     ;; UUID of the root file system, computed in a deterministic fashion.
 569     ;; This is what we use to locate the root file system so it has to be
 570     ;; different from the user's own file system UUIDs.
 571     (let ((type (if (eq? (image-format image) 'iso9660)
 572                     'iso9660
 573                     'dce)))
 574       (operating-system-uuid os type)))
 575
 576   (let* ((root-file-system-type (image->root-file-system image))
 577          (base-os (image-operating-system image))
 578          (file-systems-to-keep
 579           (srfi-1:remove
 580            (lambda (fs)
 581              (let ((mount-point (file-system-mount-point fs)))
 582                (or (string=? mount-point "/")
 583                    (string=? mount-point "/boot/efi"))))
 584            (operating-system-file-systems base-os)))
 585          (format (image-format image))
 586          (os
 587           (operating-system
 588             (inherit base-os)
 589             (initrd (lambda (file-systems . rest)
 590                       (apply (operating-system-initrd base-os)
 591                              file-systems
 592                              #:volatile-root? volatile-root?
 593                              rest)))
 594             (bootloader (if (eq? format 'iso9660)
 595                             (bootloader-configuration
 596                              (inherit
 597                               (operating-system-bootloader base-os))
 598                              (bootloader grub-mkrescue-bootloader))
 599                             (operating-system-bootloader base-os)))
 600             (file-systems (cons (file-system
 601                                   (mount-point "/")
 602                                   (device "/dev/placeholder")
 603                                   (type root-file-system-type))
 604                                 file-systems-to-keep))))
 605          (uuid (root-uuid os)))
 606     (operating-system
 607       (inherit os)
 608       (file-systems (cons (file-system
 609                             (mount-point "/")
 610                             (device uuid)
 611                             (type root-file-system-type))
 612                           file-systems-to-keep)))))
 613
 614 (define* (system-image image)
 615   "Return the derivation of IMAGE.  It can be a raw disk-image or an ISO9660
 616 image, depending on IMAGE format."
 617   (define substitutable? (image-substitutable? image))
 618   (define target (image-target image))
 619
 620   (with-parameters ((%current-target-system target))
 621     (let* ((os (operating-system-for-image image))
 622            (image* (image-with-os* image os))
 623            (image-format (image-format image))
 624            (register-closures? (has-guix-service-type? os))
 625            (bootcfg (operating-system-bootcfg os))
 626            (bootloader (bootloader-configuration-bootloader
 627                         (operating-system-bootloader os))))
 628       (cond
 629        ((memq image-format '(disk-image compressed-qcow2))
 630          (system-disk-image image*
 631                             #:bootcfg bootcfg
 632                             #:bootloader bootloader
 633                             #:register-closures? register-closures?
 634                             #:inputs `(("system" ,os)
 635                                        ("bootcfg" ,bootcfg))))
 636        ((memq image-format '(iso9660))
 637          (system-iso9660-image
 638           image*
 639           #:bootcfg bootcfg
 640           #:bootloader bootloader
 641           #:register-closures? register-closures?
 642           #:inputs `(("system" ,os)
 643                      ("bootcfg" ,bootcfg))
 644           ;; Make sure to use a mode that does no imply
 645           ;; HFS+ tree creation that may fail with:
 646           ;;
 647           ;; "libisofs: FAILURE : Too much files to mangle,
 648           ;; cannot guarantee unique file names"
 649           ;;
 650           ;; This happens if some limits are exceeded, see:
 651           ;; https://lists.gnu.org/archive/html/grub-devel/2020-06/msg00048.html
 652           #:grub-mkrescue-environment
 653           '(("MKRESCUE_SED_MODE" . "mbr_only"))))))))
 654
 655 \f
 656 ;;
 657 ;; Image detection.
 658 ;;
 659
 660 (define (image-modules)
 661   "Return the list of image modules."
 662   (cons (resolve-interface '(gnu system image))
 663         (all-modules (map (lambda (entry)
 664                             `(,entry . "gnu/system/images/"))
 665                           %load-path)
 666                      #:warn warn-about-load-error)))
 667
 668 (define %image-types
 669   ;; The list of publically-known image types.
 670   (delay (fold-module-public-variables (lambda (obj result)
 671                                          (if (image-type? obj)
 672                                              (cons obj result)
 673                                              result))
 674                                        '()
 675                                        (image-modules))))
 676
 677 (define (lookup-image-type-by-name name)
 678   "Return the image type called NAME."
 679   (or (srfi-1:find (lambda (image-type)
 680                      (eq? name (image-type-name image-type)))
 681                    (force %image-types))
 682       (raise
 683        (formatted-message (G_ "~a: no such image type") name))))
 684
 685 ;;; image.scm ends here