ryan77627/guix
1
0
Fork 0
mirror of https://git.in.rschanz.org/ryan77627/guix.git synced 2024-12-24 05:18:07 -05:00
Code Issues Projects Releases Packages Wiki Activity Actions

pack: Create /tmp in Docker images.

Browse source 
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".
This commit is contained in:
Ludovic Courtès 2019-08-27 11:27:02 +02:00 committed by Ludovic Courtès
parent 2b7c89f4fc
commit 7979a287f8
No known key found for this signature in database
GPG key ID: 090B11993D9AEBB5
3 changed files with 15 additions and 5 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

13
gnu/tests/docker.scm
View file

@ -100,7 +100,7 @@ (define marionette
marionette)) marionette))
(test-equal "Load docker image and run it" (test-equal "Load docker image and run it"
'("hello world" "hi!" "JSON!") '("hello world" "hi!" "JSON!" #o1777)
(marionette-eval (marionette-eval
`(begin `(begin
(define slurp (define slurp
@ -131,8 +131,15 @@ (define slurp
,(string-append #$docker-cli "/bin/docker") ,(string-append #$docker-cli "/bin/docker")
"run" repository&tag "run" repository&tag
"-c" "(use-modules (json)) "-c" "(use-modules (json))
(display (json-string->scm (scm->json-string \"JSON!\")))"))) (display (json-string->scm (scm->json-string \"JSON!\")))"))
(list response1 response2 response3)))
;; 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)) marionette))
(test-end) (test-end)

6
guix/scripts/pack.scm
View file

@ -511,8 +511,10 @@ (define symlink->directives
(,source -> ,target)))))) (,source -> ,target))))))
(define directives (define directives
;; Fully-qualified symlinks. ;; Create a /tmp directory, as some programs expect it, and
(append-map symlink->directives '#$symlinks)) ;; create SYMLINKS.
`((directory "/tmp" ,(getuid) ,(getgid) #o1777)
,@(append-map symlink->directives '#$symlinks)))
(setenv "PATH" (string-append #$archiver "/bin")) (setenv "PATH" (string-append #$archiver "/bin"))

1
tests/pack.scm
View file

@ -169,6 +169,7 @@ (define bin
(when (when
(and (file-exists? (string-append bin "/guile")) (and (file-exists? (string-append bin "/guile"))
(file-exists? "var/guix/db/db.sqlite") (file-exists? "var/guix/db/db.sqlite")
(file-is-directory? "tmp")
(string=? (string-append #$%bootstrap-guile "/bin") (string=? (string-append #$%bootstrap-guile "/bin")
(pk 'binlink (readlink bin))) (pk 'binlink (readlink bin)))
(string=? (string-append #$profile "/bin/guile") (string=? (string-append #$profile "/bin/guile")