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

* [bug#61949] [PATCH] pack: Move common build code to (guix build pack).
  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
  1 sibling, 1 reply; 6+ messages in thread
From: Ludovic Courtès @ 2023-03-06 15:47 UTC (permalink / raw)
  To: Maxim Cournoyer; +Cc: 61949

Hi,

Maxim Cournoyer <maxim.cournoyer@gmail.com> skribis:

> 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.

Thanks for working on it!

[...]

> +;;; Copyright © 2021, 2023 Maxim Cournoyer <maxim.cournoyer@gmail.com>

This may be inaccurate given that some of the code here predates this
file.

>  ;;; 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)

Commentary/code should come after ‘define-module’.

> +(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 '()))

Please leave out the bang from the name.  The convention in Scheme is to
suffix a name with bang when it modifies the object(s) it’s given;
that’s not the case here (see also ‘mkdir’, ‘open-output-file’, etc.).

> +  "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

Please move the ‘when’ expression after all defines so that this code
can be interpreted by Guile 2.0, which in turn will allow us to run
tests on ‘guile-bootstrap’.

> +(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"))

Likewise, move defines before statements.

Also, I would just assume “tar” is in $PATH.  That’s the assumption
generally made for things that need to shell out to various commands,
such as (gnu build file-systems), (guix docker), etc.

>  ;;; 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:

Likewise needs to be moved down.  :-)

> -(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))

[...]

>  ;; 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

We should avoid moving this tests here.  The goal is to keep as many
tests as possible under the “normal mode” (outside
‘with-external-store’) because they are exercised more frequently.

I went to great lengths to make it possible here, so we should strive to
preserve that property.

(Note that I haven’t tried running the code and tests yet.)

Could you send a v2?

Thanks,
Ludo’.




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

* [bug#61949] [PATCH] pack: Move common build code to (guix build pack).
  2023-03-06 15:47 ` Ludovic Courtès
@ 2023-03-06 19:13   ` Maxim Cournoyer
  0 siblings, 0 replies; 6+ messages in thread
From: Maxim Cournoyer @ 2023-03-06 19:13 UTC (permalink / raw)
  To: Ludovic Courtès; +Cc: 61949

Hi Ludovic,

Ludovic Courtès <ludo@gnu.org> writes:

> Hi,
>
> Maxim Cournoyer <maxim.cournoyer@gmail.com> skribis:
>
>> 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.
>
> Thanks for working on it!

> [...]
>
>> +;;; Copyright © 2021, 2023 Maxim Cournoyer <maxim.cournoyer@gmail.com>
>
> This may be inaccurate given that some of the code here predates this
> file.
>
>>  ;;; 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)
>
> Commentary/code should come after ‘define-module’.

Eh.  I remembered getting it wrong last time, and tried finding the
information in the Guile Reference manual; I ended up looking at the
"module/scripts/display-commentary.scm" source of the Guile tree, which
has:

--8<---------------cut here---------------start------------->8---
[...]

;;; Commentary:

;; Usage: display-commentary REF1 REF2 ...
;;
;; Display Commentary section from REF1, REF2 and so on.
;; Each REF may be a filename or module name (list of symbols).
;; In the latter case, a filename is computed by searching `%load-path'.

;;; Code:

(define-module (scripts display-commentary)
  :use-module (ice-9 documentation)
  :export (display-commentary))
--8<---------------cut here---------------end--------------->8---

Is this wrong?  It seems the module implementing the functionality
should have gotten that right, ha!  Fixed.

>> +(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 '()))
>
> Please leave out the bang from the name.  The convention in Scheme is to
> suffix a name with bang when it modifies the object(s) it’s given;
> that’s not the case here (see also ‘mkdir’, ‘open-output-file’, etc.).

I see.  I wasn't sure, thanks.  Fixed.

>> +  "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
>
> Please move the ‘when’ expression after all defines so that this code
> can be interpreted by Guile 2.0, which in turn will allow us to run
> tests on ‘guile-bootstrap’.

Done, but there were more complications to get the correct Guile running
(because of the new gcrypt extension dependency introduced with the move
of 'populate-profile-root' to inside the build module).

>> +(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"))
>
> Likewise, move defines before statements.

Done.

> Also, I would just assume “tar” is in $PATH.  That’s the assumption
> generally made for things that need to shell out to various commands,
> such as (gnu build file-systems), (guix docker), etc.

Done.  I also dropped the extraneous #:target argument of the
'build-self-contained-tarball' procedure.

>>  ;;; 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:
>
> Likewise needs to be moved down.  :-)

Done.

>> -(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))
>
> [...]
>
>>  ;; 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
>
> We should avoid moving this tests here.  The goal is to keep as many
> tests as possible under the “normal mode” (outside
> ‘with-external-store’) because they are exercised more frequently.

I tried avoiding it, but I think it's because of the new gcrypt
'with-extensions' requirement that is now needed for the
populate-profile-root that runs on the build side, as explained above.
It would attempt to build guile-default and others, like the earlier
problem we've had.

> I went to great lengths to make it possible here, so we should strive to
> preserve that property.

I also appreciate the value of being able to run things without a true
store/daemon.

> (Note that I haven’t tried running the code and tests yet.)
>
> Could you send a v2?

It will follow shortly.

By the way, any clue why this happens?

--8<---------------cut here---------------start------------->8---
$ make check TESTS=tests/pack.sh
[...]
PASS: tests/pack.scm
--8<---------------cut here---------------end--------------->8---

I'd have expected PASS: tests/pack.sh

Thanks!

Maxim




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

* [bug#61949] [PATCH v2] pack: Move common build code to (guix build pack).
  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:14 ` Maxim Cournoyer
  2023-07-03  9:10   ` [bug#61949] [PATCH] " Ludovic Courtès
  1 sibling, 1 reply; 6+ messages in thread
From: Maxim Cournoyer @ 2023-03-06 19:14 UTC (permalink / raw)
  To: 61949
  Cc: Josselin Poiret, Tobias Geerinckx-Rice, Maxim Cournoyer,
	Simon Tournier, Mathieu Othacehe, ludo, Christopher Baines,
	Ricardo Wurmus

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.

---

Changes in v2:
- Drop '!' from populate-profile-root!
- Move top commentary comment below define-module block
- Move expressions after definitions for Guile 2.0 compatibility
- Remove #:target and #:archiver from build-self-contained-tarball

 guix/build/pack.scm   | 111 +++++++++++++-
 guix/scripts/pack.scm | 343 +++++++++++++++---------------------------
 tests/pack.scm        | 104 ++++++-------
 3 files changed, 282 insertions(+), 276 deletions(-)

diff --git a/guix/build/pack.scm b/guix/build/pack.scm
index 3b73d1b227..fcb1da2a6c 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.
 ;;;
@@ -17,8 +17,25 @@
 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
 
 (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))
+
+;;; 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* (tar-base-options #:key tar compressor)
   "Return the base GNU tar options required to produce deterministic archives
@@ -52,3 +69,93 @@ (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 "
+  (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")
+
+  (when localstatedir?
+    (unless store-database
+      (error "missing STORE-DATABASE argument")))
+
+  (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")
+                                       localstatedir?
+                                       store-database
+                                       deduplicate?
+                                       symlinks
+                                       compressor-command)
+  "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."
+  (populate-profile-root profile
+                         #:profile-name profile-name
+                         #:localstatedir? localstatedir?
+                         #:store-database store-database
+                         #:deduplicate? deduplicate?
+                         #:symlinks symlinks)
+
+  (assert-utf8-locale)
+
+  ;; 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..eeb729b931 100644
--- a/guix/scripts/pack.scm
+++ b/guix/scripts/pack.scm
@@ -74,6 +74,14 @@ (define-module (guix scripts pack)
             %formats
             guix-pack))
 
+;;; 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:
+
 ;; This one is only for use in this module, so don't put it in %compressors.
 (define bootstrap-xz
   (compressor "bootstrap-xz" ".xz"
@@ -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,40 @@ (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)
+
+            (setenv "PATH" #+(file-append archiver "/bin"))
+
+            (build-self-contained-tarball #$profile
+                                          #$output
+                                          #:profile-name #$profile-name
+                                          #:localstatedir? #$localstatedir?
+                                          #:store-database #+database
+                                          #:deduplicate? #$deduplicate?
+                                          #:symlinks '#$symlinks
+                                          #:compressor-command
+                                          #+(and=> compressor
+                                                   compressor-command)))))
+    #:target target
+    #:references-graphs `(("profile" ,profile))))
 
 \f
 ;;;
@@ -721,20 +618,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 +639,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 +695,26 @@ (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))
+
+            (define compressor-extension
+              #+(compressor-extension compressor))
+
+            (define data-tarball-file-name
+              (string-append "data.tar" compressor-extension))
+
+            (setenv "PATH" #+(file-append archiver "/bin"))
 
-            (copy-file #+data-tarball data-tarball-file-name)
+            (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)
 
             ;; Generate the control archive.
             (let-keywords '#$extra-options #f
@@ -817,8 +723,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 +753,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 +764,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 +790,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 +822,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 +878,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 +888,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 +900,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 +910,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 +919,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: a0d22c41989e529859c813fb64a78250bde76991
-- 
2.39.1





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

* [bug#61949] [PATCH] pack: Move common build code to (guix build pack).
  2023-03-06 19:14 ` [bug#61949] [PATCH v2] " Maxim Cournoyer
@ 2023-07-03  9:10   ` Ludovic Courtès
  2023-07-18 21:13     ` bug#61949: " Maxim Cournoyer
  0 siblings, 1 reply; 6+ messages in thread
From: Ludovic Courtès @ 2023-07-03  9:10 UTC (permalink / raw)
  To: Maxim Cournoyer
  Cc: 61949, Christopher Baines, Simon Tournier, Mathieu Othacehe,
	Tobias Geerinckx-Rice, Josselin Poiret, Ricardo Wurmus

Hi Maxim and all,

Maxim Cournoyer <maxim.cournoyer@gmail.com> skribis:

> 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.

Sorry for dropping the ball!

> Changes in v2:
> - Drop '!' from populate-profile-root!
> - Move top commentary comment below define-module block
> - Move expressions after definitions for Guile 2.0 compatibility
> - Remove #:target and #:archiver from build-self-contained-tarball

I believe the only outstanding issue for me is the ability to run tests
without relying on an external store.

>  (define* (self-contained-tarball name profile
>                                   #:key target
>                                   (profile-name "guix-profile")
> @@ -367,16 +240,40 @@ (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))

You can remove (guix config) here since it’s unused.

> +                               ,@(source-module-closure
> +                                  `((guix build pack)
> +                                    (guix build utils))
> +                                  #:select? not-config?))

I figured that, to allow tests to run without an external store, we need
to change it like this:

  (gexp->derivation (string-append name ".tar"
                                   (compressor-extension compressor))
    (with-extensions (if deduplicate? (list guile-gcrypt) '())
      (with-imported-modules (let ((lst (source-module-closure
                                         `((guix build pack)
                                           (guix build utils))
                                         #:select? not-config?)))
                               (if deduplicate?
                                   lst
                                   (delete '(guix store deduplication) lst)))
        #~(begin
            (use-modules (guix build pack)
                         (guix build utils))
            …))))

Quite some boilerplate given that #:deduplicate? is always #f in practice.
So maybe it’s not worth the trouble, after all.

I’ll let you rebase and adjust as you see fit, but it LGTM!

Thanks,
Ludo’.




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

* bug#61949: [PATCH] pack: Move common build code to (guix build pack).
  2023-07-03  9:10   ` [bug#61949] [PATCH] " Ludovic Courtès
@ 2023-07-18 21:13     ` Maxim Cournoyer
  0 siblings, 0 replies; 6+ messages in thread
From: Maxim Cournoyer @ 2023-07-18 21:13 UTC (permalink / raw)
  To: Ludovic Courtès
  Cc: 61949-done, Christopher Baines, Simon Tournier, Mathieu Othacehe,
	Tobias Geerinckx-Rice, Josselin Poiret, Ricardo Wurmus

Hi Ludo!

Ludovic Courtès <ludo@gnu.org> writes:

> Hi Maxim and all,
>
> Maxim Cournoyer <maxim.cournoyer@gmail.com> skribis:
>
>> 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.
>
> Sorry for dropping the ball!

Thanks for picking it up again :-)


[...]

>>    (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))
>
> You can remove (guix config) here since it’s unused.

Done.

>> +                               ,@(source-module-closure
>> +                                  `((guix build pack)
>> +                                    (guix build utils))
>> +                                  #:select? not-config?))
>
> I figured that, to allow tests to run without an external store, we need
> to change it like this:
>
>   (gexp->derivation (string-append name ".tar"
>                                    (compressor-extension compressor))
>     (with-extensions (if deduplicate? (list guile-gcrypt) '())
>       (with-imported-modules (let ((lst (source-module-closure
>                                          `((guix build pack)
>                                            (guix build utils))
>                                          #:select? not-config?)))
>                                (if deduplicate?
>                                    lst
>                                    (delete '(guix store deduplication) lst)))
>         #~(begin
>             (use-modules (guix build pack)
>                          (guix build utils))
>             …))))
>
> Quite some boilerplate given that #:deduplicate? is always #f in practice.
> So maybe it’s not worth the trouble, after all.
>
> I’ll let you rebase and adjust as you see fit, but it LGTM!

Thanks for this!  I had to use it for tests/guix-pack.sh to pass, but it
still would work for the first test in tests/pack.scm (after modifying
it to use the test store as it used to), so I've left tests/pack.scm

The change is now installed, thanks for the review!

-- 
Thanks,
Maxim




^ permalink raw reply	[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).