05/08: pack: Create /tmp in Docker images.

[guix-commits]

civodul pushed a commit to branch master
in repository guix.

commit 7979a287f8eb84cbbfa44629951572408939a756
Author: Ludovic Courtès <address@hidden>
Date:   Tue Aug 27 11:27:02 2019 +0200

    pack: Create /tmp in Docker images.
    
    Fixes <https://bugs.gnu.org/37161>.
    
    * guix/scripts/pack.scm (docker-image)[build]: Add a 'directory' entry
    for "/tmp" to DIRECTIVES.
    * tests/pack.scm ("docker-image + localstatedir"): Test the presence of 
/tmp.
    * gnu/tests/docker.scm (run-docker-test)["Load docker image and run
    it"]: Test the presence and permission bits of "/tmp".
---
 gnu/tests/docker.scm  | 13 ++++++++++---
 guix/scripts/pack.scm |  6 ++++--
 tests/pack.scm        |  1 +
 3 files changed, 15 insertions(+), 5 deletions(-)

diff --git a/gnu/tests/docker.scm b/gnu/tests/docker.scm
index 3ec5c3d..3f98a1e 100644
--- a/gnu/tests/docker.scm
+++ b/gnu/tests/docker.scm
@@ -100,7 +100,7 @@ inside %DOCKER-OS."
              marionette))
 
           (test-equal "Load docker image and run it"
-            '("hello world" "hi!" "JSON!")
+            '("hello world" "hi!" "JSON!" #o1777)
             (marionette-eval
              `(begin
                 (define slurp
@@ -131,8 +131,15 @@ inside %DOCKER-OS."
                                    ,(string-append #$docker-cli "/bin/docker")
                                    "run" repository&tag
                                    "-c" "(use-modules (json))
-  (display (json-string->scm (scm->json-string \"JSON!\")))")))
-                  (list response1 response2 response3)))
+  (display (json-string->scm (scm->json-string \"JSON!\")))"))
+
+                       ;; Check whether /tmp exists.
+                       (response4 (slurp
+                                   ,(string-append #$docker-cli "/bin/docker")
+                                   "run" repository&tag "-c"
+                                   "(display (stat:perms (lstat \"/tmp\")))")))
+                  (list response1 response2 response3
+                        (string->number response4))))
              marionette))
 
           (test-end)
diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm
index a15530a..dd91a24 100644
--- a/guix/scripts/pack.scm
+++ b/guix/scripts/pack.scm
@@ -511,8 +511,10 @@ the image."
                      (,source -> ,target))))))
 
             (define directives
-              ;; Fully-qualified symlinks.
-              (append-map symlink->directives '#$symlinks))
+              ;; Create a /tmp directory, as some programs expect it, and
+              ;; create SYMLINKS.
+              `((directory "/tmp" ,(getuid) ,(getgid) #o1777)
+                ,@(append-map symlink->directives '#$symlinks)))
 
 
             (setenv "PATH" (string-append #$archiver "/bin"))
diff --git a/tests/pack.scm b/tests/pack.scm
index ea88cd8..71ff5ae 100644
--- a/tests/pack.scm
+++ b/tests/pack.scm
@@ -169,6 +169,7 @@
                          (when
                           (and (file-exists? (string-append bin "/guile"))
                                (file-exists? "var/guix/db/db.sqlite")
+                               (file-is-directory? "tmp")
                                (string=? (string-append #$%bootstrap-guile 
"/bin")
                                          (pk 'binlink (readlink bin)))
                                (string=? (string-append #$profile "/bin/guile")