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

@@ -194,24 +194,9 @@ (define (symlink-spec-option-parser opt name arg result)
      (leave (G_ "~a: invalid symlink specification~%")
             arg))))
 
-
+(define (set-utf8-locale profile)
-;;;
+  "Configure the environment to use the \"en_US.utf8\" locale provided by the
-;;; Tarball format.
+GLIBC-UT8-LOCALES package."
-;;;
-(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 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))
@@ -220,13 +205,29 @@ (define set-utf8-locale
                    #+(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 (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))))
+         (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)
@@ -244,8 +245,6 @@ (define (import-module? module)
                        (srfi srfi-26)
                        (ice-9 match))
 
-        (define %root "root")
-
           (define symlink->directives
             ;; Return "populate directives" to make the given symlink and its
             ;; parent directories.
@@ -269,29 +268,70 @@ (define directives
             (append-map symlink->directives '#$symlinks))
 
           ;; 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.
+          ;; is the overhead of the '.links' directory, so turn it off by
-        ;; Furthermore GNU tar < 1.30 sometimes fails to extract tarballs
+          ;; default.  Furthermore GNU tar < 1.30 sometimes fails to extract
-        ;; with hard links:
+          ;; tarballs with hard links:
           ;; <http://lists.gnu.org/archive/html/bug-tar/2017-11/msg00009.html>.
-        (populate-store (list "profile") %root #:deduplicate? #f)
+          (populate-store (list "profile") #$output
+                          #:deduplicate? #$deduplicate?)
 
           (when #+localstatedir?
-          (install-database-and-gc-roots %root #+database #$profile
+            (install-database-and-gc-roots #$output #+database #$profile
                                            #:profile-name #$profile-name))
 
           ;; Create SYMLINKS.
-        (for-each (cut evaluate-populate-directive <> %root)
+          (for-each (cut evaluate-populate-directive <> #$output)
-                  directives)
+                    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 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))
 
-        ;; 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 @@ (define* (self-contained-tarball name profile
     (warning (G_ "entry point not supported in the '~a' format~%")
              'tarball))
 
-  (gexp->derivation
+  (gexp->derivation (string-append name ".tar"
-   (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))))
+                                    #:localstatedir? localstatedir?
+                                    #:deduplicate? deduplicate?
+                                    #:symlinks symlinks
+                                    #:compressor compressor
+                                    #:archiver archiver)))
 
 
 ;;;
@@ -676,13 +715,15 @@ (define %valid-compressors '("gzip" "xz" "none"))
              'deb))
 
   (define data-tarball
-    (computed-file (string-append "data.tar"
+    (computed-file (string-append "data.tar" (compressor-extension
-                                  (compressor-extension compressor))
+                                              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 @@ (define tar (string-append #+archiver "/bin/tar"))
                       "debian-binary"
                       control-tarball-file-name data-tarball-file-name))))))
 
-  (gexp->derivation (string-append name ".deb")
+  (gexp->derivation (string-append name ".deb") build))
-    build
-    #:target target
-    #:references-graphs `(("profile" ,profile))))
 
 
 ;;;