04/08: pack: Extract populate-profile-root from self-contained-tarball/builder.

[guix-commits]

apteryx pushed a commit to branch master
in repository guix.

commit 68380db4c40a2ee1156349a87254fd7b1f1a52d5
Author: Maxim Cournoyer <maxim.cournoyer@gmail.com>
AuthorDate: Wed Feb 1 15:53:14 2023 -0500

    pack: Extract populate-profile-root from self-contained-tarball/builder.
    
    This allows more code to be reused between the various archive writers.
    
    * guix/scripts/pack.scm (set-utf8-locale): New top-level procedure, 
extracted
    from...
    (populate-profile-root): New procedure, extracted from...
    (self-contained-tarball/builder): ... here.  Add #:target argument.  Call
    populate-profile-root.
    [LOCALSTATEDIR?]: Set db.sqlite file permissions.
    (self-contained-tarball): Call self-contained-tarball/builder with the 
TARGET
    argument, and set #:local-build? to #f for the gexp-derivation call.  Remove
    now extraneous #:target and #:references-graphs arguments from the
    gexp->derivation call.
    (debian-archive): Call self-contained-tarball/builder with the #:target
    argument.  Fix indentation.  Remove now extraneous #:target and
     #:references-graphs arguments from the gexp->derivation call.
---
 guix/scripts/pack.scm | 230 +++++++++++++++++++++++++++++---------------------
 1 file changed, 134 insertions(+), 96 deletions(-)

diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm
index e552cb108a..77425e5b0f 100644
--- a/guix/scripts/pack.scm
+++ b/guix/scripts/pack.scm
@@ -194,104 +194,144 @@ target the profile's @file{bin/env} file:
      (leave (G_ "~a: invalid symlink specification~%")
             arg))))
 
-
-;;;
-;;; Tarball format.
-;;;
-(define* (self-contained-tarball/builder profile
-                                         #:key (profile-name "guix-profile")
-                                         (compressor (first %compressors))
-                                         localstatedir?
-                                         (symlinks '())
-                                         (archiver tar)
-                                         (extra-options '()))
-  "Return the G-Expression of the builder used for self-contained-tarball."
+(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 set-utf8-locale
-    ;; 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 (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.  That way we can run tests with '--bootstrap'.
+    ;; Guile-Gcrypt, unless DEDUPLICATE? is #t.  This makes it possible to run
+    ;; tests with '--bootstrap'.
     (and (not-config? module)
-         (not (equal? '(guix store deduplication) module))))
-
-  (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?)
+         (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?)
+      #~(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
+    #:options (list #:references-graphs `(("profile" ,profile))
+                    #:target target)))
+
+
+;;;
+;;; 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 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 %root "root")
-
-        (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))
+                     (guix build utils))
 
         ;; Make sure non-ASCII file names are properly handled.
-        #+set-utf8-locale
+        #+(set-utf8-locale profile)
 
         (define tar #+(file-append archiver "/bin/tar"))
 
-        ;; Note: there is not much to gain here with deduplication and there
-        ;; is the overhead of the '.links' directory, so turn it off.
-        ;; 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? #f)
-
-        (when #+localstatedir?
-          (install-database-and-gc-roots %root #+database #$profile
-                                         #:profile-name #$profile-name))
+        (define %root (if #$localstatedir? "." #$root))
 
-        ;; Create SYMLINKS.
-        (for-each (cut evaluate-populate-directive <> %root)
-                  directives)
+        (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))
 
-        ;; Create the tarball.
         (with-directory-excursion %root
           ;; GNU Tar recurses directories by default.  Simply add the whole
-          ;; current directory, which contains all the generated files so far.
+          ;; 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 "."
@@ -320,17 +360,16 @@ added to the pack."
     (warning (G_ "entry point not supported in the '~a' format~%")
              'tarball))
 
-  (gexp->derivation
-   (string-append name ".tar"
-                  (compressor-extension compressor))
-   (self-contained-tarball/builder profile
-                                   #:profile-name profile-name
-                                   #:compressor compressor
-                                   #:localstatedir? localstatedir?
-                                   #:symlinks symlinks
-                                   #:archiver archiver)
-   #:target target
-   #:references-graphs `(("profile" ,profile))))
+  (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)))
 
 
 ;;;
@@ -676,13 +715,15 @@ Valid compressors are: ~a~%") compressor-name 
%valid-compressors)))
              'deb))
 
   (define data-tarball
-    (computed-file (string-append "data.tar"
-                                  (compressor-extension compressor))
+    (computed-file (string-append "data.tar" (compressor-extension
+                                              compressor))
       (self-contained-tarball/builder profile
+                                      #:target target
                                       #:profile-name profile-name
-                                      #:compressor compressor
                                       #:localstatedir? localstatedir?
+                                      #:deduplicate? deduplicate?
                                       #:symlinks symlinks
+                                      #:compressor compressor
                                       #:archiver archiver)
       #:local-build? #f                 ;allow offloading
       #:options (list #:references-graphs `(("profile" ,profile))
@@ -811,10 +852,7 @@ Section: misc
                       "debian-binary"
                       control-tarball-file-name data-tarball-file-name))))))
 
-  (gexp->derivation (string-append name ".deb")
-    build
-    #:target target
-    #:references-graphs `(("profile" ,profile))))
+  (gexp->derivation (string-append name ".deb") build))
 
 
 ;;;