[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
03/06: pack: Factorize 'mksquashfs' invocations.
From: |
guix-commits |
Subject: |
03/06: pack: Factorize 'mksquashfs' invocations. |
Date: |
Fri, 13 Mar 2020 12:34:07 -0400 (EDT) |
civodul pushed a commit to branch master
in repository guix.
commit b24ec854519c0e0815b19eeb246c47444aa687c5
Author: Ludovic Courtès <address@hidden>
AuthorDate: Fri Mar 13 12:55:05 2020 +0100
pack: Factorize 'mksquashfs' invocations.
* guix/scripts/pack.scm (squashfs-image)[build](mksquashfs): New
procedure.
Replace instances of (invoke "mksquashfs" ...) with (mksquashfs ...).
---
guix/scripts/pack.scm | 149 +++++++++++++++++++++++++-------------------------
1 file changed, 75 insertions(+), 74 deletions(-)
diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm
index c8d8546..70239b6 100644
--- a/guix/scripts/pack.scm
+++ b/guix/scripts/pack.scm
@@ -365,6 +365,9 @@ added to the pack."
(define database #+database)
(define entry-point #$entry-point)
+ (define (mksquashfs args)
+ (apply invoke "mksquashfs" args))
+
(setenv "PATH" (string-append #$archiver "/bin"))
;; We need an empty file in order to have a valid file argument when
@@ -376,92 +379,90 @@ added to the pack."
;; Add all store items. Unfortunately mksquashfs throws away all
;; ancestor directories and only keeps the basename. We fix this
;; in the following invocations of mksquashfs.
- (apply invoke "mksquashfs"
- `(,@(map store-info-item
- (call-with-input-file "profile"
- read-reference-graph))
- #$environment
- ,#$output
-
- ;; Do not perform duplicate checking because we
- ;; don't have any dupes.
- "-no-duplicates"
- "-comp"
- ,#+(compressor-name compressor)))
+ (mksquashfs `(,@(map store-info-item
+ (call-with-input-file "profile"
+ read-reference-graph))
+ #$environment
+ ,#$output
+
+ ;; Do not perform duplicate checking because we
+ ;; don't have any dupes.
+ "-no-duplicates"
+ "-comp"
+ ,#+(compressor-name compressor)))
;; Here we reparent the store items. For each sub-directory of
;; the store prefix we need one invocation of "mksquashfs".
(for-each (lambda (dir)
- (apply invoke "mksquashfs"
- `(".empty"
- ,#$output
- "-root-becomes" ,dir)))
+ (mksquashfs `(".empty"
+ ,#$output
+ "-root-becomes" ,dir)))
(reverse (string-tokenize (%store-directory)
(char-set-complement (char-set
#\/)))))
;; Add symlinks and mount points.
- (apply invoke "mksquashfs"
- `(".empty"
- ,#$output
- ;; Create SYMLINKS via pseudo file definitions.
- ,@(append-map
- (match-lambda
- ((source '-> target)
- ;; Create relative symlinks to work around a bug in
- ;; Singularity 2.x:
- ;; https://bugs.gnu.org/34913
- ;; https://github.com/sylabs/singularity/issues/1487
- (let ((target (string-append #$profile "/" target)))
- (list "-p"
- (string-join
- ;; name s mode uid gid symlink
- (list source
- "s" "777" "0" "0"
- (relative-file-name (dirname source)
- target)))))))
- '#$symlinks*)
-
- "-p" "/.singularity.d d 555 0 0"
-
- ;; Create the environment file.
- "-p" "/.singularity.d/env d 555 0 0"
- "-p" ,(string-append
- "/.singularity.d/env/90-environment.sh s 777 0 0 "
- (relative-file-name "/.singularity.d/env"
- #$environment))
-
- ;; Create /.singularity.d/actions, and optionally the 'run'
- ;; script, used by 'singularity run'.
- "-p" "/.singularity.d/actions d 555 0 0"
-
- ,@(if entry-point
- `(;; This one if for Singularity 2.x.
- "-p"
- ,(string-append
- "/.singularity.d/actions/run s 777 0 0 "
- (relative-file-name "/.singularity.d/actions"
- (string-append #$profile "/"
- entry-point)))
-
- ;; This one is for Singularity 3.x.
- "-p"
- ,(string-append
- "/.singularity.d/runscript s 777 0 0 "
- (relative-file-name "/.singularity.d"
- (string-append #$profile "/"
- entry-point))))
- '())
-
- ;; Create empty mount points.
- "-p" "/proc d 555 0 0"
- "-p" "/sys d 555 0 0"
- "-p" "/dev d 555 0 0"
- "-p" "/home d 555 0 0"))
+ (mksquashfs
+ `(".empty"
+ ,#$output
+ ;; Create SYMLINKS via pseudo file definitions.
+ ,@(append-map
+ (match-lambda
+ ((source '-> target)
+ ;; Create relative symlinks to work around a bug in
+ ;; Singularity 2.x:
+ ;; https://bugs.gnu.org/34913
+ ;; https://github.com/sylabs/singularity/issues/1487
+ (let ((target (string-append #$profile "/" target)))
+ (list "-p"
+ (string-join
+ ;; name s mode uid gid symlink
+ (list source
+ "s" "777" "0" "0"
+ (relative-file-name (dirname source)
+ target)))))))
+ '#$symlinks*)
+
+ "-p" "/.singularity.d d 555 0 0"
+
+ ;; Create the environment file.
+ "-p" "/.singularity.d/env d 555 0 0"
+ "-p" ,(string-append
+ "/.singularity.d/env/90-environment.sh s 777 0 0 "
+ (relative-file-name "/.singularity.d/env"
+ #$environment))
+
+ ;; Create /.singularity.d/actions, and optionally the 'run'
+ ;; script, used by 'singularity run'.
+ "-p" "/.singularity.d/actions d 555 0 0"
+
+ ,@(if entry-point
+ `(;; This one if for Singularity 2.x.
+ "-p"
+ ,(string-append
+ "/.singularity.d/actions/run s 777 0 0 "
+ (relative-file-name "/.singularity.d/actions"
+ (string-append #$profile "/"
+ entry-point)))
+
+ ;; This one is for Singularity 3.x.
+ "-p"
+ ,(string-append
+ "/.singularity.d/runscript s 777 0 0 "
+ (relative-file-name "/.singularity.d"
+ (string-append #$profile "/"
+ entry-point))))
+ '())
+
+ ;; Create empty mount points.
+ "-p" "/proc d 555 0 0"
+ "-p" "/sys d 555 0 0"
+ "-p" "/dev d 555 0 0"
+ "-p" "/home d 555 0 0"))
(when database
;; Initialize /var/guix.
(install-database-and-gc-roots "var-etc" database #$profile)
- (invoke "mksquashfs" "var-etc" #$output)))))
+ (mksquashfs `("var-etc" ,#$output))))))
(gexp->derivation (string-append name
(compressor-extension compressor)
- branch master updated (10b99dd -> f292c50), guix-commits, 2020/03/13
- 01/06: weather: Exit with non-zero when coverage is below 100%., guix-commits, 2020/03/13
- 02/06: weather: '--coverage' filters out non-package objects., guix-commits, 2020/03/13
- 03/06: pack: Factorize 'mksquashfs' invocations.,
guix-commits <=
- 05/06: pack: Do not create a squashfs "recovery file"., guix-commits, 2020/03/13
- 04/06: pack: Make bit-reproducible squashfs images., guix-commits, 2020/03/13
- 06/06: maint: Add 'etc/release-manifest.scm'., guix-commits, 2020/03/13