03/06: pack: Factorize 'mksquashfs' invocations.

[guix-commits]

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)