mirror of
https://git.in.rschanz.org/ryan77627/guix.git
synced 2024-11-07 07:26:13 -05:00
gnu: system: image: Reduce subprocedure indentation.
* gnu/system/image.scm (system-disk-image): Reduce indentation. Change-Id: I9cf59d3a61d0c6e7e90009e62661f74f774f090a
This commit is contained in:
Herman Rimm
parent
689cca0c75
commit
a95413d299
GPG key ID:
81B0E222A3E2308E
1 changed files with 59 additions and 56 deletions
|
|
@ -448,63 +448,66 @@ (define (partition->gpt-type partition)
|
||||||
(format #f (G_ "unsupported partition type: ~a")
|
(format #f (G_ "unsupported partition type: ~a")
|
||||||
file-system)))))))))
|
file-system)))))))))
|
||||||
|
|
||||||
|
(define (image-builder partition)
|
||||||
|
"A directory, filled by calling the PARTITION initializer
|
||||||
|
procedure, is first created within the store. Then, an image of this
|
||||||
|
directory is created using tools such as 'mke2fs' or 'mkdosfs',
|
||||||
|
depending on the partition file-system type."
|
||||||
|
(let ((os (image-operating-system image))
|
||||||
|
(schema (local-file (search-path %load-path
|
||||||
|
"guix/store/schema.sql")))
|
||||||
|
(graph (match inputs
|
||||||
|
(((names . _) ...)
|
||||||
|
names)))
|
||||||
|
(type (partition-file-system partition)))
|
||||||
|
(with-imported-modules*
|
||||||
|
(let ((initializer (or #$(partition-initializer partition)
|
||||||
|
initialize-root-partition))
|
||||||
|
(inputs '#+(cond
|
||||||
|
((string-prefix? "ext" type)
|
||||||
|
(list e2fsprogs fakeroot))
|
||||||
|
((or (string=? type "vfat")
|
||||||
|
(string-prefix? "fat" type))
|
||||||
|
(list dosfstools fakeroot mtools))
|
||||||
|
(else
|
||||||
|
'())))
|
||||||
|
(image-root (string-append (getcwd) "/tmp-root"))
|
||||||
|
(copy-closures? (not #$(image-shared-store? image))))
|
||||||
|
(sql-schema #$schema)
|
||||||
|
|
||||||
|
(set-path-environment-variable "PATH" '("bin" "sbin") inputs)
|
||||||
|
|
||||||
|
;; Allow non-ASCII file names--e.g., 'nss-certs'--to be
|
||||||
|
;; decoded.
|
||||||
|
(setenv "GUIX_LOCPATH"
|
||||||
|
#+(file-append (libc-utf8-locales-for-target
|
||||||
|
(%current-system))
|
||||||
|
"/lib/locale"))
|
||||||
|
(setlocale LC_ALL "en_US.utf8")
|
||||||
|
|
||||||
|
(initializer image-root
|
||||||
|
#:references-graphs '#$graph
|
||||||
|
#:deduplicate? #f
|
||||||
|
#:copy-closures? copy-closures?
|
||||||
|
#:system-directory #$os)
|
||||||
|
;; There's no point installing a bootloader if we do not
|
||||||
|
;; populate the store.
|
||||||
|
(when copy-closures?
|
||||||
|
;; Root-offset isn't necessary: we override 'root.
|
||||||
|
#$(bootloader-configurations->gexp
|
||||||
|
bootloader-config bootmeta
|
||||||
|
#:overrides (targets partition)))
|
||||||
|
(make-partition-image #$(partition->gexp partition)
|
||||||
|
#$output
|
||||||
|
image-root)))))
|
||||||
|
|
||||||
(define (partition-image partition)
|
(define (partition-image partition)
|
||||||
;; Return as a file-like object, an image of the given PARTITION. A
|
"Return as a file-like object, an image of the given PARTITION."
|
||||||
;; directory, filled by calling the PARTITION initializer procedure, is
|
(computed-file "partition.img" (image-builder partition)
|
||||||
;; first created within the store. Then, an image of this directory is
|
;; Allow offloading so that this I/O-intensive process
|
||||||
;; created using tools such as 'mke2fs' or 'mkdosfs', depending on the
|
;; doesn't run on the build farm's head node.
|
||||||
;; partition file-system type.
|
#:local-build? #f
|
||||||
(let* ((os (image-operating-system image))
|
#:options `(#:references-graphs ,inputs)))
|
||||||
(schema (local-file (search-path %load-path
|
|
||||||
"guix/store/schema.sql")))
|
|
||||||
(graph (match inputs
|
|
||||||
(((names . _) ...)
|
|
||||||
names)))
|
|
||||||
(type (partition-file-system partition))
|
|
||||||
(image-builder
|
|
||||||
(with-imported-modules*
|
|
||||||
(let ((initializer (or #$(partition-initializer partition)
|
|
||||||
initialize-root-partition))
|
|
||||||
(inputs '#+(cond
|
|
||||||
((string-prefix? "ext" type)
|
|
||||||
(list e2fsprogs fakeroot))
|
|
||||||
((or (string=? type "vfat")
|
|
||||||
(string-prefix? "fat" type))
|
|
||||||
(list dosfstools fakeroot mtools))
|
|
||||||
(else
|
|
||||||
'())))
|
|
||||||
(image-root (string-append (getcwd) "/tmp-root"))
|
|
||||||
(copy-closures? (not #$(image-shared-store? image))))
|
|
||||||
(sql-schema #$schema)
|
|
||||||
|
|
||||||
(set-path-environment-variable "PATH" '("bin" "sbin") inputs)
|
|
||||||
|
|
||||||
;; Allow non-ASCII file names--e.g., 'nss-certs'--to be
|
|
||||||
;; decoded.
|
|
||||||
(setenv "GUIX_LOCPATH"
|
|
||||||
#+(file-append (libc-utf8-locales-for-target
|
|
||||||
(%current-system))
|
|
||||||
"/lib/locale"))
|
|
||||||
(setlocale LC_ALL "en_US.utf8")
|
|
||||||
|
|
||||||
(initializer image-root
|
|
||||||
#:references-graphs '#$graph
|
|
||||||
#:deduplicate? #f
|
|
||||||
#:copy-closures? copy-closures?
|
|
||||||
#:system-directory #$os)
|
|
||||||
;; no point installing a bootloader if we don't populate store
|
|
||||||
(when copy-closures?
|
|
||||||
;; root-offset isn't necessary - we override 'root
|
|
||||||
#$(bootloader-configurations->gexp bootloader-config bootmeta
|
|
||||||
#:overrides (targets partition)))
|
|
||||||
(make-partition-image #$(partition->gexp partition)
|
|
||||||
#$output
|
|
||||||
image-root)))))
|
|
||||||
(computed-file "partition.img" image-builder
|
|
||||||
;; Allow offloading so that this I/O-intensive process
|
|
||||||
;; doesn't run on the build farm's head node.
|
|
||||||
#:local-build? #f
|
|
||||||
#:options `(#:references-graphs ,inputs))))
|
|
||||||
|
|
||||||
(define (gpt-image? image)
|
(define (gpt-image? image)
|
||||||
(eq? 'gpt (image-partition-table-type image)))
|
(eq? 'gpt (image-partition-table-type image)))
|
||||||
|
|
|
||||||
Loading…
Reference in a new issue