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.
This commit is contained in:
Ludovic Courtès 2018-11-04 17:16:22 +01:00
parent f5a2fb1bfb
commit 598a6b87cc
No known key found for this signature in database
GPG Key ID: 090B11993D9AEBB5
2 changed files with 53 additions and 2 deletions

View File

@ -53,6 +53,7 @@
lookup-compressor lookup-compressor
self-contained-tarball self-contained-tarball
docker-image docker-image
squashfs-image
guix-pack)) guix-pack))
@ -288,18 +289,27 @@ points for virtual file systems (like procfs), and optional symlinks.
SYMLINKS must be a list of (SOURCE -> TARGET) tuples denoting symlinks to be SYMLINKS must be a list of (SOURCE -> TARGET) tuples denoting symlinks to be
added to the pack." added to the pack."
(define database
(and localstatedir?
(file-append (store-database (list profile))
"/db/db.sqlite")))
(define build (define build
(with-imported-modules (source-module-closure (with-imported-modules (source-module-closure
'((guix build utils) '((guix build utils)
(guix build store-copy)) (guix build store-copy)
(gnu build install))
#:select? not-config?) #:select? not-config?)
#~(begin #~(begin
(use-modules (guix build utils) (use-modules (guix build utils)
(guix build store-copy) (guix build store-copy)
(gnu build install)
(srfi srfi-1) (srfi srfi-1)
(srfi srfi-26) (srfi srfi-26)
(ice-9 match)) (ice-9 match))
(define database #+database)
(setenv "PATH" (string-append #$archiver "/bin")) (setenv "PATH" (string-append #$archiver "/bin"))
;; We need an empty file in order to have a valid file argument when ;; We need an empty file in order to have a valid file argument when
@ -352,7 +362,12 @@ added to the pack."
;; Create empty mount points. ;; Create empty mount points.
"-p" "/proc d 555 0 0" "-p" "/proc d 555 0 0"
"-p" "/sys 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 (gexp->derivation (string-append name
(compressor-extension compressor) (compressor-extension compressor)

View File

@ -28,6 +28,7 @@
#:use-module (guix tests) #:use-module (guix tests)
#:use-module (guix gexp) #:use-module (guix gexp)
#:use-module (gnu packages bootstrap) #:use-module (gnu packages bootstrap)
#:use-module ((gnu packages compression) #:select (squashfs-tools-next))
#:use-module (srfi srfi-64)) #:use-module (srfi srfi-64))
(define %store (define %store
@ -126,6 +127,41 @@
(string=? (string-append #$profile "/bin/guile") (string=? (string-append #$profile "/bin/guile")
(pk 'guilelink (readlink "bin/Guile")))) (pk 'guilelink (readlink "bin/Guile"))))
(mkdir #$output))))))) (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))))) (built-derivations (list check)))))
(test-end) (test-end)