unofficial mirror of guix-patches@gnu.org 
 help / color / mirror / code / Atom feed
* [bug#61949] [PATCH] pack: Move common build code to (guix build pack).
@ 2023-03-04  3:15 Maxim Cournoyer
  2023-03-06 15:47 ` Ludovic Courtès
  2023-03-06 19:14 ` [bug#61949] [PATCH v2] " Maxim Cournoyer
  0 siblings, 2 replies; 6+ messages in thread
From: Maxim Cournoyer @ 2023-03-04  3:15 UTC (permalink / raw)
  To: 61949; +Cc: Maxim Cournoyer, ludo

The rationale is to reduce the number of derivations built per pack to ideally
one, to minimize storage requirements.  The number of derivations had gone up
with 68380db4 ("pack: Extract populate-profile-root from
self-contained-tarball/builder.") as a side effect to improving code reuse.

* guix/scripts/pack.scm (guix): Add commentary comment.
(populate-profile-root, self-contained-tarball/builder): Extract to...
* guix/build/pack.scm (populate-profile-root!): ... this, and...
(build-self-contained-tarball): ... that, adjusting for use on the build side.
(assert-utf8-locale): New procedure.
(self-contained-tarball, debian-archive, rpm-archive): Adjust accordingly.
---
 guix/build/pack.scm   | 115 +++++++++++++-
 guix/scripts/pack.scm | 341 +++++++++++++++---------------------------
 tests/pack.scm        | 104 ++++++-------
 3 files changed, 284 insertions(+), 276 deletions(-)

diff --git a/guix/build/pack.scm b/guix/build/pack.scm
index 3b73d1b227..fa9a5f5905 100644
--- a/guix/build/pack.scm
+++ b/guix/build/pack.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2021 Maxim Cournoyer <maxim.cournoyer@gmail.com>
+;;; Copyright © 2021, 2023 Maxim Cournoyer <maxim.cournoyer@gmail.com>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -16,9 +16,26 @@
 ;;; You should have received a copy of the GNU General Public License
 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
 
+;;; Commentary:
+
+;;; This module contains build-side common procedures used by the host-side
+;;; (guix scripts pack) module, mostly to allow for code reuse.  Due to making
+;;; use of the (guix build store-copy) module, it transitively requires the
+;;; sqlite and gcrypt extensions to be available.
+
+;;; Code:
+
 (define-module (guix build pack)
+  #:use-module (gnu build install)
   #:use-module (guix build utils)
-  #:export (tar-base-options))
+  #:use-module (guix build store-copy)
+  #:use-module ((guix build union) #:select (relative-file-name))
+  #:use-module (ice-9 match)
+  #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-26)
+  #:export (tar-base-options
+            populate-profile-root!
+            build-self-contained-tarball))
 
 (define* (tar-base-options #:key tar compressor)
   "Return the base GNU tar options required to produce deterministic archives
@@ -52,3 +69,97 @@ (define (tar-supports-sort? tar)
     ;; process.  Use '--hard-dereference' to eliminate it.
     "--hard-dereference"
     "--check-links"))
+
+(define (assert-utf8-locale)
+  "Verify the current process is using the en_US.utf8 locale."
+  (unless (string=? "unset for tests" (getenv "GUIX_LOCPATH"))
+    (unless (false-if-exception (setlocale LC_ALL "en_US.utf8"))
+      (error "environment not configured for en_US.utf8 locale"))))
+
+(define* (populate-profile-root! profile
+                                 #:key (profile-name "guix-profile")
+                                 localstatedir?
+                                 store-database
+                                 deduplicate?
+                                 (symlinks '()))
+  "Populate the root profile directory with SYMLINKS and a Guix database, when
+LOCALSTATEDIR? is set, and a pre-computed STORE-DATABASE is provided.  The
+directory is created as \"root\" in the current working directory.  When
+DEDUPLICATE? is true, deduplicate the store items, which relies on hard
+links.  It needs to run in an environment where "
+  (when localstatedir?
+    (unless store-database
+      (error "missing STORE-DATABASE argument")))
+
+  (define symlink->directives
+    ;; Return "populate directives" to make the given symlink and its
+    ;; parent directories.
+    (match-lambda
+      ((source '-> target)
+       (let ((target (string-append profile "/" target))
+             (parent (dirname source)))
+         ;; Never add a 'directory' directive for "/" so as to
+         ;; preserve its ownership when extracting the archive (see
+         ;; below), and also because this would lead to adding the
+         ;; same entries twice in the tarball.
+         `(,@(if (string=? parent "/")
+                 '()
+                 `((directory ,parent)))
+           ;; Use a relative file name for compatibility with
+           ;; relocatable packs.
+           (,source -> ,(relative-file-name parent target)))))))
+
+  (define directives
+    ;; Fully-qualified symlinks.
+    (append-map symlink->directives symlinks))
+
+  (define %root "root")
+
+  (assert-utf8-locale)
+
+  ;; Note: there is not much to gain here with deduplication and there
+  ;; is the overhead of the '.links' directory, so turn it off by
+  ;; default.  Furthermore GNU tar < 1.30 sometimes fails to extract
+  ;; tarballs with hard links:
+  ;; <http://lists.gnu.org/archive/html/bug-tar/2017-11/msg00009.html>.
+  (populate-store (list "profile") %root #:deduplicate? deduplicate?)
+
+  (when localstatedir?
+    (install-database-and-gc-roots %root store-database
+                                   profile #:profile-name profile-name))
+
+  ;; Create SYMLINKS.
+  (for-each (cut evaluate-populate-directive <> %root) directives))
+
+(define* (build-self-contained-tarball profile
+                                       tarball-file-name
+                                       #:key (profile-name "guix-profile")
+                                       target
+                                       localstatedir?
+                                       store-database
+                                       deduplicate?
+                                       symlinks
+                                       compressor-command
+                                       archiver)
+  "Create a self-contained tarball TARBALL-FILE-NAME from PROFILE, optionally
+compressing it with COMPRESSOR-COMMAND, the complete command-line string to
+use for the compressor."
+  (assert-utf8-locale)
+
+  (populate-profile-root! profile
+                          #:profile-name profile-name
+                          #:localstatedir? localstatedir?
+                          #:store-database store-database
+                          #:deduplicate? deduplicate?
+                          #:symlinks symlinks)
+
+  (define tar (string-append archiver "/bin/tar"))
+
+  ;; GNU Tar recurses directories by default.  Simply add the whole root
+  ;; directory, which contains all the files to be archived.  This avoids
+  ;; creating duplicate files in the archives that would be stored as hard
+  ;; links by GNU Tar.
+  (apply invoke tar "-cvf" tarball-file-name "-C" "root" "."
+         (tar-base-options
+          #:tar tar
+          #:compressor compressor-command)))
diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm
index eb41eb5563..984622bd16 100644
--- a/guix/scripts/pack.scm
+++ b/guix/scripts/pack.scm
@@ -24,6 +24,14 @@
 ;;; You should have received a copy of the GNU General Public License
 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
 
+;;; Commentary:
+
+;;; This module implements the 'guix pack' command and the various supported
+;;; formats.  Where feasible, the builders of the packs should be implemented
+;;; as single derivations to minimize storage requirements.
+
+;;; Code:
+
 (define-module (guix scripts pack)
   #:use-module (guix scripts)
   #:use-module (guix ui)
@@ -199,153 +207,18 @@ (define (set-utf8-locale profile)
   "Configure the environment to use the \"en_US.utf8\" locale provided by the
 GLIBC-UT8-LOCALES package."
   ;; Arrange to not depend on 'glibc-utf8-locales' when using '--bootstrap'.
-  (and (or (not (profile? profile))
-           (profile-locales? profile))
-       #~(begin
-           (setenv "GUIX_LOCPATH"
-                   #+(file-append glibc-utf8-locales "/lib/locale"))
-           (setlocale LC_ALL "en_US.utf8"))))
-
-(define* (populate-profile-root profile
-                                #:key (profile-name "guix-profile")
-                                target
-                                localstatedir?
-                                deduplicate?
-                                (symlinks '()))
-  "Populate the root profile directory with SYMLINKS and a Guix database, when
-LOCALSTATEDIR? is set.  When DEDUPLICATE? is true, deduplicate the store
-items, which relies on hard links."
-  (define database
-    (and localstatedir?
-         (file-append (store-database (list profile))
-                      "/db/db.sqlite")))
-
-  (define bootstrap?
-    ;; Whether a '--bootstrap' environment is needed, for testing purposes.
-    ;; XXX: Infer that from available info.
-    (and (not database) (not (profile-locales? profile))))
-
-  (define (import-module? module)
-    ;; Since we don't use deduplication support in 'populate-store', don't
-    ;; import (guix store deduplication) and its dependencies, which includes
-    ;; Guile-Gcrypt, unless DEDUPLICATE? is #t.  This makes it possible to run
-    ;; tests with '--bootstrap'.
-    (and (not-config? module)
-         (or deduplicate? (not (equal? '(guix store deduplication) module)))))
-
-  (computed-file "profile-directory"
-    (with-imported-modules (source-module-closure
-                            `((guix build pack)
-                              (guix build store-copy)
-                              (guix build utils)
-                              (guix build union)
-                              (gnu build install))
-                            #:select? import-module?)
+  (if (or (not (profile? profile))
+          (profile-locales? profile))
       #~(begin
-          (use-modules (guix build pack)
-                       (guix build store-copy)
-                       (guix build utils)
-                       ((guix build union) #:select (relative-file-name))
-                       (gnu build install)
-                       (srfi srfi-1)
-                       (srfi srfi-26)
-                       (ice-9 match))
-
-          (define symlink->directives
-            ;; Return "populate directives" to make the given symlink and its
-            ;; parent directories.
-            (match-lambda
-              ((source '-> target)
-               (let ((target (string-append #$profile "/" target))
-                     (parent (dirname source)))
-                 ;; Never add a 'directory' directive for "/" so as to
-                 ;; preserve its ownership when extracting the archive (see
-                 ;; below), and also because this would lead to adding the
-                 ;; same entries twice in the tarball.
-                 `(,@(if (string=? parent "/")
-                         '()
-                         `((directory ,parent)))
-                   ;; Use a relative file name for compatibility with
-                   ;; relocatable packs.
-                   (,source -> ,(relative-file-name parent target)))))))
-
-          (define directives
-            ;; Fully-qualified symlinks.
-            (append-map symlink->directives '#$symlinks))
-
-          ;; Make sure non-ASCII file names are properly handled.
-          #+(set-utf8-locale profile)
-
-          ;; Note: there is not much to gain here with deduplication and there
-          ;; is the overhead of the '.links' directory, so turn it off by
-          ;; default.  Furthermore GNU tar < 1.30 sometimes fails to extract
-          ;; tarballs with hard links:
-          ;; <http://lists.gnu.org/archive/html/bug-tar/2017-11/msg00009.html>.
-          (populate-store (list "profile") #$output
-                          #:deduplicate? #$deduplicate?)
-
-          (when #+localstatedir?
-            (install-database-and-gc-roots #$output #+database #$profile
-                                           #:profile-name #$profile-name))
-
-          ;; Create SYMLINKS.
-          (for-each (cut evaluate-populate-directive <> #$output)
-                    directives)))
-    #:local-build? #f
-    #:guile (if bootstrap? %bootstrap-guile (default-guile))
-    #:options (list #:references-graphs `(("profile" ,profile))
-                    #:target target)))
+          (setenv "GUIX_LOCPATH"
+                  #+(file-append glibc-utf8-locales "/lib/locale"))
+          (setlocale LC_ALL "en_US.utf8"))
+      #~(setenv "GUIX_LOCPATH" "unset for tests")))
 
 \f
 ;;;
 ;;; Tarball format.
 ;;;
-(define* (self-contained-tarball/builder profile
-                                         #:key (profile-name "guix-profile")
-                                         target
-                                         localstatedir?
-                                         deduplicate?
-                                         symlinks
-                                         compressor
-                                         archiver)
-  "Return a GEXP that can build a self-contained tarball."
-
-  (define root (populate-profile-root profile
-                                      #:profile-name profile-name
-                                      #:target target
-                                      #:localstatedir? localstatedir?
-                                      #:deduplicate? deduplicate?
-                                      #:symlinks symlinks))
-
-  (with-imported-modules (source-module-closure '((guix build pack)
-                                                  (guix build utils)))
-    #~(begin
-        (use-modules (guix build pack)
-                     (guix build utils))
-
-        ;; Make sure non-ASCII file names are properly handled.
-        #+(set-utf8-locale profile)
-
-        (define tar #+(file-append archiver "/bin/tar"))
-
-        (define %root (if #$localstatedir? "." #$root))
-
-        (when #$localstatedir?
-          ;; Fix the permission of the Guix database file, which was made
-          ;; read-only when copied to the store in populate-profile-root.
-          (copy-recursively #$root %root)
-          (chmod (string-append %root "/var/guix/db/db.sqlite") #o644))
-
-        (with-directory-excursion %root
-          ;; GNU Tar recurses directories by default.  Simply add the whole
-          ;; current directory, which contains all the files to be archived.
-          ;; This avoids creating duplicate files in the archives that would
-          ;; be stored as hard links by GNU Tar.
-          (apply invoke tar "-cvf" #$output "."
-                 (tar-base-options
-                  #:tar tar
-                  #:compressor #+(and=> compressor compressor-command)))))))
-
 (define* (self-contained-tarball name profile
                                  #:key target
                                  (profile-name "guix-profile")
@@ -367,16 +240,39 @@ (define* (self-contained-tarball name profile
     (warning (G_ "entry point not supported in the '~a' format~%")
              'tarball))
 
+  (define database
+    (and localstatedir?
+         (file-append (store-database (list profile))
+                      "/db/db.sqlite")))
+
   (gexp->derivation (string-append name ".tar"
                                    (compressor-extension compressor))
-    (self-contained-tarball/builder profile
-                                    #:profile-name profile-name
-                                    #:target target
-                                    #:localstatedir? localstatedir?
-                                    #:deduplicate? deduplicate?
-                                    #:symlinks symlinks
-                                    #:compressor compressor
-                                    #:archiver archiver)))
+    (with-extensions (list guile-gcrypt)
+      (with-imported-modules `(((guix config) => ,(make-config.scm))
+                               ,@(source-module-closure
+                                  `((guix build pack)
+                                    (guix build utils))
+                                  #:select? not-config?))
+        #~(begin
+            (use-modules (guix build pack)
+                         (guix build utils))
+
+            ;; Make sure non-ASCII file names are properly handled.
+            #+(set-utf8-locale profile)
+
+            (build-self-contained-tarball #$profile
+                                          #$output
+                                          #:profile-name #$profile-name
+                                          #:target #$target
+                                          #:localstatedir? #$localstatedir?
+                                          #:store-database #+database
+                                          #:deduplicate? #$deduplicate?
+                                          #:symlinks '#$symlinks
+                                          #:compressor-command
+                                          #+(and=> compressor compressor-command)
+                                          #:archiver #+archiver))))
+    #:target target
+    #:references-graphs `(("profile" ,profile))))
 
 \f
 ;;;
@@ -721,20 +617,10 @@ (define %valid-compressors '("gzip" "xz" "none"))
     (warning (G_ "entry point not supported in the '~a' format~%")
              'deb))
 
-  (define data-tarball
-    (computed-file (string-append "data.tar" (compressor-extension
-                                              compressor))
-      (self-contained-tarball/builder profile
-                                      #:target target
-                                      #:profile-name profile-name
-                                      #:localstatedir? localstatedir?
-                                      #:deduplicate? deduplicate?
-                                      #:symlinks symlinks
-                                      #:compressor compressor
-                                      #:archiver archiver)
-      #:local-build? #f                 ;allow offloading
-      #:options (list #:references-graphs `(("profile" ,profile))
-                      #:target target)))
+  (define database
+    (and localstatedir?
+         (file-append (store-database (list profile))
+                      "/db/db.sqlite")))
 
   (define build
     (with-extensions (list guile-gcrypt)
@@ -752,6 +638,9 @@ (define build
                          (ice-9 optargs)
                          (srfi srfi-1))
 
+            ;; Make sure non-ASCII file names are properly handled.
+            #+(set-utf8-locale profile)
+
             (define machine-type
               ;; Extract the machine type from the specified target, else from the
               ;; current system.
@@ -805,10 +694,25 @@ (define debian-format-version "2.0")
               (lambda (port)
                 (format port "~a~%" debian-format-version)))
 
-            (define data-tarball-file-name (strip-store-file-name
-                                            #+data-tarball))
+            (define compressor-command
+              #+(and=> compressor compressor-command))
 
-            (copy-file #+data-tarball data-tarball-file-name)
+            (define compressor-extension
+              #+(compressor-extension compressor))
+
+            (define data-tarball-file-name
+              (string-append "data.tar" compressor-extension))
+
+            (build-self-contained-tarball #$profile
+                                          data-tarball-file-name
+                                          #:profile-name #$profile-name
+                                          #:localstatedir? #$localstatedir?
+                                          #:store-database #+database
+                                          #:deduplicate? #$deduplicate?
+                                          #:symlinks '#$symlinks
+                                          #:compressor-command
+                                          compressor-command
+                                          #:archiver #+archiver)
 
             ;; Generate the control archive.
             (let-keywords '#$extra-options #f
@@ -817,8 +721,7 @@ (define data-tarball-file-name (strip-store-file-name
                            (triggers-file #f))
 
               (define control-tarball-file-name
-                (string-append "control.tar"
-                               #$(compressor-extension compressor)))
+                (string-append "control.tar" compressor-extension))
 
               ;; Write the compressed control tarball.  Only the control file is
               ;; mandatory (see: 'man deb' and 'man deb-control').
@@ -848,7 +751,7 @@ (define tar (string-append #+archiver "/bin/tar"))
               (apply invoke tar
                      `(,@(tar-base-options
                           #:tar tar
-                          #:compressor #+(and=> compressor compressor-command))
+                          #:compressor compressor-command)
                        "-cvf" ,control-tarball-file-name
                        "control"
                        ,@(if postinst-file '("postinst") '())
@@ -859,7 +762,9 @@ (define tar (string-append #+archiver "/bin/tar"))
                       "debian-binary"
                       control-tarball-file-name data-tarball-file-name))))))
 
-  (gexp->derivation (string-append name ".deb") build))
+  (gexp->derivation (string-append name ".deb") build
+                    #:target target
+                    #:references-graphs `(("profile" ,profile))))
 
 \f
 ;;;
@@ -883,66 +788,27 @@ (define* (rpm-archive name profile
   (when entry-point
     (warning (G_ "entry point not supported in the '~a' format~%") 'rpm))
 
-  (define root (populate-profile-root profile
-                                      #:profile-name profile-name
-                                      #:target target
-                                      #:localstatedir? localstatedir?
-                                      #:deduplicate? deduplicate?
-                                      #:symlinks symlinks))
-
-  (define payload
-    (let* ((raw-cpio-file-name "payload.cpio")
-           (compressed-cpio-file-name (string-append raw-cpio-file-name
-                                                     (compressor-extension
-                                                      compressor))))
-      (computed-file compressed-cpio-file-name
-        (with-imported-modules (source-module-closure
-                                '((guix build utils)
-                                  (guix cpio)
-                                  (guix rpm)))
-          #~(begin
-              (use-modules (guix build utils)
-                           (guix cpio)
-                           (guix rpm)
-                           (srfi srfi-1))
-
-              ;; Make sure non-ASCII file names are properly handled.
-              #+(set-utf8-locale profile)
-
-              (define %root (if #$localstatedir? "." #$root))
-
-              (when #$localstatedir?
-                ;; Fix the permission of the Guix database file, which was made
-                ;; read-only when copied to the store in populate-profile-root.
-                (copy-recursively #$root %root)
-                (chmod (string-append %root "/var/guix/db/db.sqlite") #o644))
-
-              (call-with-output-file #$raw-cpio-file-name
-                (lambda (port)
-                  (with-directory-excursion %root
-                    ;; The first "." entry is discarded.
-                    (write-cpio-archive
-                     (remove fhs-directory?
-                             (cdr (find-files "." #:directories? #t)))
-                     port))))
-              (when #+(compressor-command compressor)
-                (apply invoke (append #+(compressor-command compressor)
-                                      (list #$raw-cpio-file-name))))
-              (copy-file #$compressed-cpio-file-name #$output)))
-        #:local-build? #f)))            ;allow offloading
+  (define database
+    (and localstatedir?
+         (file-append (store-database (list profile))
+                      "/db/db.sqlite")))
 
   (define build
     (with-extensions (list guile-gcrypt)
       (with-imported-modules `(((guix config) => ,(make-config.scm))
                                ,@(source-module-closure
                                   `((gcrypt hash)
+                                    (guix build pack)
                                     (guix build utils)
+                                    (guix cpio)
                                     (guix profiles)
                                     (guix rpm))
                                   #:select? not-config?))
         #~(begin
             (use-modules (gcrypt hash)
+                         (guix build pack)
                          (guix build utils)
+                         (guix cpio)
                          (guix profiles)
                          (guix rpm)
                          (ice-9 binary-ports)
@@ -954,6 +820,35 @@ (define build
             ;; Make sure non-ASCII file names are properly handled.
             #+(set-utf8-locale profile)
 
+            (define %root "root")
+
+            (populate-profile-root! #$profile
+                                    #:profile-name #$profile-name
+                                    #:localstatedir? #$localstatedir?
+                                    #:store-database #+database
+                                    #:deduplicate? #$deduplicate?
+                                    #:symlinks '#$symlinks)
+
+            (define raw-cpio-file-name "payload.cpio")
+
+            ;; Generate CPIO payload.
+            (call-with-output-file raw-cpio-file-name
+              (lambda (port)
+                (with-directory-excursion %root
+                  ;; The first "." entry is discarded.
+                  (write-cpio-archive
+                   (remove fhs-directory?
+                           (cdr (find-files "." #:directories? #t)))
+                   port))))
+
+            (when #+(compressor-command compressor)
+              (apply invoke (append #+(compressor-command compressor)
+                                    (list raw-cpio-file-name))))
+
+            (define cpio-file-name
+              (string-append "payload.cpio"
+                             #$(compressor-extension compressor)))
+
             (define machine-type
               (and=> (or #$target %host-type)
                      (lambda (triplet)
@@ -981,7 +876,7 @@ (define lead
                              #:target (or #$target %host-type)))
 
             (define payload-digest
-              (bytevector->hex-string (file-sha256 #$payload)))
+              (bytevector->hex-string (file-sha256 cpio-file-name)))
 
             (let-keywords '#$extra-options #f ((relocatable? #f)
                                                (prein-file #f)
@@ -991,7 +886,7 @@ (define payload-digest
 
               (let ((header (generate-header name version
                                              payload-digest
-                                             #$root
+                                             %root
                                              #$(compressor-name compressor)
                                              #:target (or #$target %host-type)
                                              #:relocatable? relocatable?
@@ -1003,7 +898,7 @@ (define payload-digest
                 (define header-sha256
                   (bytevector->hex-string (sha256 (u8-list->bytevector header))))
 
-                (define payload-size (stat:size (stat #$payload)))
+                (define payload-size (stat:size (stat cpio-file-name)))
 
                 (define header+compressed-payload-size
                   (+ (length header) payload-size))
@@ -1013,7 +908,7 @@ (define signature
                                       header+compressed-payload-size))
 
                 ;; Serialize the archive components to a file.
-                (call-with-input-file #$payload
+                (call-with-input-file cpio-file-name
                   (lambda (in)
                     (call-with-output-file #$output
                       (lambda (out)
@@ -1022,7 +917,9 @@ (define signature
                                                                    header))
                         (sendfile out in payload-size)))))))))))
 
-  (gexp->derivation (string-append name ".rpm") build))
+  (gexp->derivation (string-append name ".rpm") build
+                    #:target target
+                    #:references-graphs `(("profile" ,profile))))
 
   \f
 ;;;
diff --git a/tests/pack.scm b/tests/pack.scm
index 87187bb62c..397fb37b12 100644
--- a/tests/pack.scm
+++ b/tests/pack.scm
@@ -76,64 +76,64 @@ (define rpm-for-tests
 \f
 (test-begin "pack")
 
-(unless (network-reachable?) (test-skip 1))
-(test-assertm "self-contained-tarball" %store
-  (mlet* %store-monad
-      ((profile -> (profile
-                    (content (packages->manifest (list %bootstrap-guile)))
-                    (hooks '())
-                    (locales? #f)))
-       (tarball (self-contained-tarball "pack" profile
-                                        #:symlinks '(("/bin/Guile"
-                                                      -> "bin/guile"))
-                                        #:compressor %gzip-compressor
-                                        #:archiver %tar-bootstrap))
-       (check   (gexp->derivation "check-tarball"
-                  (with-imported-modules '((guix build utils))
-                    #~(begin
-                        (use-modules (guix build utils)
-                                     (srfi srfi-1))
-
-                        (define store
-                          ;; The unpacked store.
-                          (string-append "." (%store-directory) "/"))
-
-                        (define (canonical? file)
-                          ;; Return #t if FILE is read-only and its mtime is 1.
-                          (let ((st (lstat file)))
-                            (or (not (string-prefix? store file))
-                                (eq? 'symlink (stat:type st))
-                                (and (= 1 (stat:mtime st))
-                                     (zero? (logand #o222
-                                                    (stat:mode st)))))))
-
-                        (define bin
-                          (string-append "." #$profile "/bin"))
-
-                        (setenv "PATH"
-                                (string-append #$%tar-bootstrap "/bin"))
-                        (system* "tar" "xvf" #$tarball)
-                        (mkdir #$output)
-                        (exit
-                         (and (file-exists? (string-append bin "/guile"))
-                              (file-exists? store)
-                              (every canonical?
-                                     (find-files "." (const #t)
-                                                 #:directories? #t))
-                              (string=? (string-append #$%bootstrap-guile "/bin")
-                                        (readlink bin))
-                              (string=? (string-append ".." #$profile
-                                                       "/bin/guile")
-                                        (readlink "bin/Guile")))))))))
-    (built-derivations (list check))))
-
 ;; The following test needs guile-sqlite3, libgcrypt, etc. as a consequence of
 ;; commit c45477d2a1a651485feede20fe0f3d15aec48b39 and related changes.  Thus,
 ;; run it on the user's store, if it's available, on the grounds that these
 ;; dependencies may be already there, or we can get substitutes or build them
 ;; quite inexpensively; see <https://bugs.gnu.org/32184>.
-
 (with-external-store store
+  (unless store (test-skip 1))
+  (test-assertm "self-contained-tarball" store
+    (mlet* %store-monad
+        ((guile   (set-guile-for-build (default-guile)))
+         (profile -> (profile
+                      (content (packages->manifest (list %bootstrap-guile)))
+                      (hooks '())
+                      (locales? #f)))
+         (tarball (self-contained-tarball "pack" profile
+                                          #:symlinks '(("/bin/Guile"
+                                                        -> "bin/guile"))
+                                          #:compressor %gzip-compressor
+                                          #:archiver %tar-bootstrap))
+         (check   (gexp->derivation "check-tarball"
+                    (with-imported-modules '((guix build utils))
+                      #~(begin
+                          (use-modules (guix build utils)
+                                       (srfi srfi-1))
+
+                          (define store
+                            ;; The unpacked store.
+                            (string-append "." (%store-directory) "/"))
+
+                          (define (canonical? file)
+                            ;; Return #t if FILE is read-only and its mtime is 1.
+                            (let ((st (lstat file)))
+                              (or (not (string-prefix? store file))
+                                  (eq? 'symlink (stat:type st))
+                                  (and (= 1 (stat:mtime st))
+                                       (zero? (logand #o222
+                                                      (stat:mode st)))))))
+
+                          (define bin
+                            (string-append "." #$profile "/bin"))
+
+                          (setenv "PATH"
+                                  (string-append #$%tar-bootstrap "/bin"))
+                          (system* "tar" "xvf" #$tarball)
+                          (mkdir #$output)
+                          (exit
+                           (and (file-exists? (string-append bin "/guile"))
+                                (file-exists? store)
+                                (every canonical?
+                                       (find-files "." (const #t)
+                                                   #:directories? #t))
+                                (string=? (string-append #$%bootstrap-guile "/bin")
+                                          (readlink bin))
+                                (string=? (string-append ".." #$profile
+                                                         "/bin/guile")
+                                          (readlink "bin/Guile")))))))))
+      (built-derivations (list check))))
+
   (unless store (test-skip 1))
   (test-assertm "self-contained-tarball + localstatedir" store
     (mlet* %store-monad

base-commit: 89e5f3f3847b3bfd507ea9f0874a73f99a53cbf9
-- 
2.39.1





^ permalink raw reply related	[flat|nested] 6+ messages in thread

end of thread, other threads:[~2023-07-18 21:14 UTC | newest]

Thread overview: 6+ messages (download: mbox.gz / follow: Atom feed)
-- links below jump to the message on this page --
2023-03-04  3:15 [bug#61949] [PATCH] pack: Move common build code to (guix build pack) Maxim Cournoyer
2023-03-06 15:47 ` Ludovic Courtès
2023-03-06 19:13   ` Maxim Cournoyer
2023-03-06 19:14 ` [bug#61949] [PATCH v2] " Maxim Cournoyer
2023-07-03  9:10   ` [bug#61949] [PATCH] " Ludovic Courtès
2023-07-18 21:13     ` bug#61949: " Maxim Cournoyer

Code repositories for project(s) associated with this public inbox

	https://git.savannah.gnu.org/cgit/guix.git

This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).