From 598a6b87cc6636aee9dec57ae95922da0a6e31e8 Mon Sep 17 00:00:00 2001
From: Ludovic Courtès <ludo@gnu.org>
Date: Sun, 4 Nov 2018 17:16:22 +0100
Subject: pack: Squashfs backend now honors '--localstatedir'.

* guix/scripts/pack.scm (squashfs-image)[database]: New variable.
[build]: Add (gnu build install) to the closure.  Call
'install-database-and-gc-roots' when DATABASE is true, and invoke
mksquashfs once more.
* tests/pack.scm ("squashfs-image + localstatedir"): New test.
---
 guix/scripts/pack.scm | 19 +++++++++++++++++--
 tests/pack.scm        | 36 ++++++++++++++++++++++++++++++++++++
 2 files changed, 53 insertions(+), 2 deletions(-)

diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm
index 09fc88988a..a86b95dd38 100644
--- a/guix/scripts/pack.scm
+++ b/guix/scripts/pack.scm
@@ -53,6 +53,7 @@ (define-module (guix scripts pack)
             lookup-compressor
             self-contained-tarball
             docker-image
+            squashfs-image
 
             guix-pack))
 
@@ -288,18 +289,27 @@ (define* (squashfs-image name profile
 
 SYMLINKS must be a list of (SOURCE -> TARGET) tuples denoting symlinks to be
 added to the pack."
+  (define database
+    (and localstatedir?
+         (file-append (store-database (list profile))
+                      "/db/db.sqlite")))
+
   (define build
     (with-imported-modules (source-module-closure
                             '((guix build utils)
-                              (guix build store-copy))
+                              (guix build store-copy)
+                              (gnu build install))
                             #:select? not-config?)
       #~(begin
           (use-modules (guix build utils)
                        (guix build store-copy)
+                       (gnu build install)
                        (srfi srfi-1)
                        (srfi srfi-26)
                        (ice-9 match))
 
+          (define database #+database)
+
           (setenv "PATH" (string-append #$archiver "/bin"))
 
           ;; We need an empty file in order to have a valid file argument when
@@ -352,7 +362,12 @@ (define build
                    ;; Create empty mount points.
                    "-p" "/proc d 555 0 0"
                    "-p" "/sys d 555 0 0"
-                   "-p" "/dev d 555 0 0")))))
+                   "-p" "/dev d 555 0 0"))
+
+          (when database
+            ;; Initialize /var/guix.
+            (install-database-and-gc-roots "var-etc" database #$profile)
+            (invoke "mksquashfs" "var-etc" #$output)))))
 
   (gexp->derivation (string-append name
                                    (compressor-extension compressor)
diff --git a/tests/pack.scm b/tests/pack.scm
index bfff802d8a..0c9e4ffa7f 100644
--- a/tests/pack.scm
+++ b/tests/pack.scm
@@ -28,6 +28,7 @@ (define-module (test-pack)
   #:use-module (guix tests)
   #:use-module (guix gexp)
   #:use-module (gnu packages bootstrap)
+  #:use-module ((gnu packages compression) #:select (squashfs-tools-next))
   #:use-module (srfi srfi-64))
 
 (define %store
@@ -126,6 +127,41 @@ (define bin
                                (string=? (string-append #$profile "/bin/guile")
                                          (pk 'guilelink (readlink "bin/Guile"))))
                           (mkdir #$output)))))))
+      (built-derivations (list check))))
+
+  (unless store (test-skip 1))
+  (test-assertm "squashfs-image + localstatedir" store
+    (mlet* %store-monad
+        ((guile   (set-guile-for-build (default-guile)))
+         (profile (profile-derivation (packages->manifest
+                                       (list %bootstrap-guile))
+                                      #:hooks '()
+                                      #:locales? #f))
+         (image   (squashfs-image "squashfs-pack" profile
+                                  #:symlinks '(("/bin" -> "bin"))
+                                  #:localstatedir? #t))
+         (check   (gexp->derivation
+                   "check-tarball"
+                   (with-imported-modules '((guix build utils))
+                     #~(begin
+                         (use-modules (guix build utils)
+                                      (ice-9 match))
+
+                         (define bin
+                           (string-append "." #$profile "/bin"))
+
+                         (setenv "PATH"
+                                 (string-append #$squashfs-tools-next "/bin"))
+                         (invoke "unsquashfs" #$image)
+                         (with-directory-excursion "squashfs-root"
+                           (when (and (file-exists? (string-append bin
+                                                                   "/guile"))
+                                      (file-exists? "var/guix/db/db.sqlite")
+                                      (string=? (string-append #$%bootstrap-guile "/bin")
+                                                (pk 'binlink (readlink bin)))
+                                      (string=? (string-append #$profile "/bin")
+                                                (pk 'guilelink (readlink "bin"))))
+                             (mkdir #$output))))))))
       (built-derivations (list check)))))
 
 (test-end)
-- 
cgit v1.2.3