123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235 |
- (define-module (gnu image)
- #:use-module (guix platform)
- #:use-module (guix records)
- #:use-module (guix diagnostics)
- #:use-module (guix i18n)
- #:use-module (srfi srfi-1)
- #:use-module (srfi srfi-34)
- #:use-module (srfi srfi-35)
- #:export (partition
- partition?
- partition-device
- partition-size
- partition-offset
- partition-file-system
- partition-file-system-options
- partition-label
- partition-uuid
- partition-flags
- partition-initializer
- image
- image?
- image-name
- image-format
- image-platform
- image-size
- image-operating-system
- image-partition-table-type
- image-partitions
- image-compression?
- image-volatile-root?
- image-shared-store?
- image-shared-network?
- image-substitutable?
- image-type
- image-type?
- image-type-name
- image-type-constructor
- os->image
- os+platform->image))
- (define-with-syntax-properties (validate-size (value properties))
- (unless (and value
- (or (eq? value 'guess) (integer? value)))
- (raise
- (make-compound-condition
- (condition
- (&error-location
- (location (source-properties->location properties))))
- (formatted-message
- (G_ "size (~a) can only be 'guess or a numeric expression ~%")
- value 'field))))
- value)
- (define-with-syntax-properties (validate-partition-offset (value properties))
- (unless (and value (integer? value))
- (raise
- (make-compound-condition
- (condition
- (&error-location
- (location (source-properties->location properties))))
- (formatted-message
- (G_ "the partition offset (~a) can only be a \
- numeric expression ~%") value 'field))))
- value)
- (define-with-syntax-properties (validate-partition-flags (value properties))
- (let ((bad-flags (lset-difference eq? value '(boot esp))))
- (unless (and (list? value) (null? bad-flags))
- (raise
- (make-compound-condition
- (condition
- (&error-location
- (location (source-properties->location properties))))
- (formatted-message
- (G_ "unsupported partition flag(s): ~a ~%") bad-flags)))))
- value)
- (define-record-type* <partition> partition make-partition
- partition?
- (size partition-size
- (default 'guess)
- (sanitize validate-size))
- (offset partition-offset
- (default 0)
- (sanitize validate-partition-offset))
- (file-system partition-file-system
- (default "ext4"))
- (file-system-options partition-file-system-options
- (default '()))
- (label partition-label)
- (uuid partition-uuid
- (default #false))
- (flags partition-flags
- (default '())
- (sanitize validate-partition-flags))
- (initializer partition-initializer
- (default #false)))
- (define-syntax-rule (define-set-sanitizer name field set)
- "Define NAME as a procedure or macro that raises an error if passed a value
- that is not in SET, mentioning FIELD in the error message."
- (define-with-syntax-properties (name (value properties))
- (unless (memq value 'set)
- (raise
- (make-compound-condition
- (condition
- (&error-location
- (location (source-properties->location properties))))
- (formatted-message (G_ "~s: invalid '~a' value") value 'field))))
- value))
- (define-set-sanitizer validate-image-format format
- (disk-image compressed-qcow2 docker iso9660 tarball wsl2))
- (define-set-sanitizer validate-partition-table-type partition-table-type
- (mbr gpt))
- (define-record-type* <image>
- image make-image
- image?
- (name image-name
- (default #false))
- (format image-format
- (sanitize validate-image-format))
- (platform image-platform
- (default #false))
- (size image-size
- (default 'guess)
- (sanitize validate-size))
- (operating-system image-operating-system)
- (partition-table-type image-partition-table-type
- (default 'mbr)
- (sanitize validate-partition-table-type))
- (partitions image-partitions
- (default '()))
- (compression? image-compression?
- (default #true))
- (volatile-root? image-volatile-root?
- (default #true))
- (shared-store? image-shared-store?
- (default #false))
- (shared-network? image-shared-network?
- (default #false))
- (substitutable? image-substitutable?
- (default #true)))
- (define-record-type* <image-type>
- image-type make-image-type
- image-type?
- (name image-type-name)
- (constructor image-type-constructor))
- (define* (os->image os #:key type)
- "Use the image constructor from TYPE, an <image-type> record to turn the
- given OS, an <operating-system> record into an image and return it."
- (let ((constructor (image-type-constructor type)))
- (constructor os)))
- (define* (os+platform->image os platform #:key type)
- "Use the image constructor from TYPE, an <image-type> record to turn the
- given OS, an <operating-system> record into an image targeting PLATFORM, a
- <platform> record and return it."
- (image
- (inherit (os->image os #:type type))
- (platform platform)))
|