[bug#33259] [PATCH 4/8] pack: Docker backend now honors '--localstatedir'.

[Ludovic Courtès]

* guix/docker.scm (build-docker-image): Add #:database parameter.
Create /var/guix/db, /var/guix/profiles, etc. when DATABASE is true.
* guix/scripts/pack.scm (docker-image): Export.  Remove #:deduplicate?
parameter.  Define 'database' and pass it to 'docker-image'.
* tests/pack.scm (test-assertm): Recompile the derivation of
%BOOTSTRAP-GUILE.
("docker-image + localstatedir"): New test.
---
 guix/docker.scm       | 16 ++++++++++++-
 guix/scripts/pack.scm |  9 +++++++-
 tests/pack.scm        | 53 +++++++++++++++++++++++++++++++++++++++++--
 3 files changed, 74 insertions(+), 4 deletions(-)

diff --git a/guix/docker.scm b/guix/docker.scm
index 0757d3356f..c19a24d45c 100644
--- a/guix/docker.scm
+++ b/guix/docker.scm
@@ -26,6 +26,7 @@
                           delete-file-recursively
                           with-directory-excursion
                           invoke))
+  #:use-module (gnu build install)
   #:use-module (json)                             ;guile-json
   #:use-module (srfi srfi-19)
   #:use-module (srfi srfi-26)
@@ -108,11 +109,15 @@ return \"a\"."
                              (symlinks '())
                              (transformations '())
                              (system (utsname:machine (uname)))
+                             database
                              compressor
                              (creation-time (current-time time-utc)))
   "Write to IMAGE a Docker image archive containing the given PATHS.  PREFIX
 must be a store path that is a prefix of any store paths in PATHS.
 
+When DATABASE is true, copy it to /var/guix/db in the image and create
+/var/guix/gcroots and friends.
+
 SYMLINKS must be a list of (SOURCE -> TARGET) tuples describing symlinks to be
 created in the image, where each TARGET is relative to PREFIX.
 TRANSFORMATIONS must be a list of (OLD -> NEW) tuples describing how to
@@ -188,10 +193,15 @@ SRFI-19 time-utc object, as the creation time in 
metadata."
                                 source))))
                   symlinks)
 
+        (when database
+          ;; Initialize /var/guix, assuming PREFIX points to a profile.
+          (install-database-and-gc-roots "." database prefix))
+
         (apply invoke "tar" "-cf" "layer.tar"
                `(,@transformation-options
                  ,@%tar-determinism-options
                  ,@paths
+                 ,@(if database '("var") '())
                  ,@(map symlink-source symlinks)))
         ;; It is possible for "/" to show up in the archive, especially when
         ;; applying transformations.  For example, the transformation
@@ -203,7 +213,11 @@ SRFI-19 time-utc object, as the creation time in metadata."
         (system* "tar" "--delete" "/" "-f" "layer.tar")
         (for-each delete-file-recursively
                   (map (compose topmost-component symlink-source)
-                       symlinks)))
+                       symlinks))
+
+        ;; Delete /var/guix.
+        (when database
+          (delete-file-recursively "var")))
 
       (with-output-to-file "config.json"
         (lambda ()
diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm
index 3e6430bcce..09fc88988a 100644
--- a/guix/scripts/pack.scm
+++ b/guix/scripts/pack.scm
@@ -52,6 +52,8 @@
   #:export (compressor?
             lookup-compressor
             self-contained-tarball
+            docker-image
+
             guix-pack))
 
 ;; Type of a compression tool.
@@ -360,7 +362,6 @@ added to the pack."
 
 (define* (docker-image name profile
                        #:key target
-                       deduplicate?
                        (compressor (first %compressors))
                        localstatedir?
                        (symlinks '())
@@ -370,6 +371,11 @@ image is a tarball conforming to the Docker Image 
Specification, compressed
 with COMPRESSOR.  It can be passed to 'docker load'.  If TARGET is true, it
 must a be a GNU triplet and it is used to derive the architecture metadata in
 the image."
+  (define database
+    (and localstatedir?
+         (file-append (store-database (list profile))
+                      "/db/db.sqlite")))
+
   (define defmod 'define-module)                  ;trick Geiser
 
   (define build
@@ -388,6 +394,7 @@ the image."
                                      (call-with-input-file "profile"
                                        read-reference-graph))
                                 #$profile
+                                #:database #+database
                                 #:system (or #$target (utsname:machine 
(uname)))
                                 #:symlinks '#$symlinks
                                 #:compressor '#$(compressor-command compressor)
diff --git a/tests/pack.scm b/tests/pack.scm
index 6bd18bdee2..e8d4f9f18d 100644
--- a/tests/pack.scm
+++ b/tests/pack.scm
@@ -22,6 +22,7 @@
   #:use-module (guix store)
   #:use-module (guix derivations)
   #:use-module (guix profiles)
+  #:use-module (guix packages)                    ;XXX: debugging
   #:use-module (guix monads)
   #:use-module (guix grafts)
   #:use-module (guix tests)
@@ -37,8 +38,9 @@
 
 (define-syntax-rule (test-assertm name store exp)
   (test-assert name
-    (run-with-store store exp
-                    #:guile-for-build (%guile-for-build))))
+    (let ((guile (package-derivation store %bootstrap-guile)))
+      (run-with-store store exp
+                      #:guile-for-build guile))))
 
 (define %gzip-compressor
   ;; Compressor that uses the bootstrap 'gzip'.
@@ -79,6 +81,53 @@
                                      (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 "docker-image + localstatedir" store
+    (mlet* %store-monad
+        ((guile   (set-guile-for-build (default-guile)))
+         (profile (profile-derivation (packages->manifest
+                                       (list %bootstrap-guile))
+                                      #:hooks '()
+                                      #:locales? #f))
+         (tarball (docker-image "docker-pack" profile
+                                #:symlinks '(("/bin/Guile" -> "bin/guile"))
+                                #: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 #$%tar-bootstrap 
"/bin"))
+                         (mkdir "base")
+                         (with-directory-excursion "base"
+                           (invoke "tar" "xvf" #$tarball))
+
+                         (match (find-files "base" "layer.tar")
+                           ((layer)
+                            (invoke "tar" "xvf" layer)))
+
+                         (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/guile")
+                                         (pk 'guilelink (readlink 
"bin/Guile"))))
+                          (mkdir #$output)))))))
+      (built-derivations (list check)))))
+
 (test-end)
 
 ;; Local Variables:
-- 
2.19.1