aboutsummaryrefslogtreecommitdiff
path: root/tests/pack.scm
diff options
context:
space:
mode:
Diffstat (limited to 'tests/pack.scm')
-rw-r--r--tests/pack.scm279
1 files changed, 142 insertions, 137 deletions
diff --git a/tests/pack.scm b/tests/pack.scm
index 87187bb62c..ce5a2f8a53 100644
--- a/tests/pack.scm
+++ b/tests/pack.scm
@@ -88,43 +88,44 @@
-> "bin/guile"))
#:compressor %gzip-compressor
#:archiver %tar-bootstrap))
- (check (gexp->derivation "check-tarball"
- (with-imported-modules '((guix build utils))
- #~(begin
- (use-modules (guix build utils)
- (srfi srfi-1))
-
- (define store
- ;; The unpacked store.
- (string-append "." (%store-directory) "/"))
-
- (define (canonical? file)
- ;; Return #t if FILE is read-only and its mtime is 1.
- (let ((st (lstat file)))
- (or (not (string-prefix? store file))
- (eq? 'symlink (stat:type st))
- (and (= 1 (stat:mtime st))
- (zero? (logand #o222
- (stat:mode st)))))))
-
- (define bin
- (string-append "." #$profile "/bin"))
-
- (setenv "PATH"
- (string-append #$%tar-bootstrap "/bin"))
- (system* "tar" "xvf" #$tarball)
- (mkdir #$output)
- (exit
- (and (file-exists? (string-append bin "/guile"))
- (file-exists? store)
- (every canonical?
- (find-files "." (const #t)
- #:directories? #t))
- (string=? (string-append #$%bootstrap-guile "/bin")
- (readlink bin))
- (string=? (string-append ".." #$profile
- "/bin/guile")
- (readlink "bin/Guile")))))))))
+ (check (gexp->derivation
+ "check-tarball"
+ (with-imported-modules '((guix build utils))
+ #~(begin
+ (use-modules (guix build utils)
+ (srfi srfi-1))
+
+ (define store
+ ;; The unpacked store.
+ (string-append "." (%store-directory) "/"))
+
+ (define (canonical? file)
+ ;; Return #t if FILE is read-only and its mtime is 1.
+ (let ((st (lstat file)))
+ (or (not (string-prefix? store file))
+ (eq? 'symlink (stat:type st))
+ (and (= 1 (stat:mtime st))
+ (zero? (logand #o222
+ (stat:mode st)))))))
+
+ (define bin
+ (string-append "." #$profile "/bin"))
+
+ (setenv "PATH"
+ (string-append #$%tar-bootstrap "/bin"))
+ (system* "tar" "xvf" #$tarball)
+ (mkdir #$output)
+ (exit
+ (and (file-exists? (string-append bin "/guile"))
+ (file-exists? store)
+ (every canonical?
+ (find-files "." (const #t)
+ #:directories? #t))
+ (string=? (string-append #$%bootstrap-guile "/bin")
+ (readlink bin))
+ (string=? (string-append ".." #$profile
+ "/bin/guile")
+ (readlink "bin/Guile")))))))))
(built-derivations (list check))))
;; The following test needs guile-sqlite3, libgcrypt, etc. as a consequence of
@@ -144,16 +145,17 @@
(locales? #f)))
(tarball (self-contained-tarball "tar-pack" profile
#:localstatedir? #t))
- (check (gexp->derivation "check-tarball"
- #~(let ((bin (string-append "." #$profile "/bin")))
- (setenv "PATH"
- (string-append #$%tar-bootstrap "/bin"))
- (system* "tar" "xvf" #$tarball)
- (mkdir #$output)
- (exit
- (and (file-exists? "var/guix/db/db.sqlite")
- (string=? (string-append #$%bootstrap-guile "/bin")
- (readlink bin))))))))
+ (check (gexp->derivation
+ "check-tarball"
+ #~(let ((bin (string-append "." #$profile "/bin")))
+ (setenv "PATH"
+ (string-append #$%tar-bootstrap "/bin"))
+ (system* "tar" "xvf" #$tarball)
+ (mkdir #$output)
+ (exit
+ (and (file-exists? "var/guix/db/db.sqlite")
+ (string=? (string-append #$%bootstrap-guile "/bin")
+ (readlink bin))))))))
(built-derivations (list check))))
(unless store (test-skip 1))
@@ -166,44 +168,45 @@
("λ" regular (data "lambda")))))
(tarball (self-contained-tarball "tar-pack" tree
#:localstatedir? #t))
- (check (gexp->derivation "check-tarball"
- (with-extensions (list guile-sqlite3 guile-gcrypt)
- (with-imported-modules (source-module-closure
- '((guix store database)))
- #~(begin
- (use-modules (guix store database)
- (rnrs io ports)
- (srfi srfi-1))
-
- (define (valid-file? basename data)
- (define file
- (string-append "./" #$tree "/" basename))
-
- (string=? (call-with-input-file (pk 'file file)
- get-string-all)
- data))
-
- (setenv "PATH"
- (string-append #$%tar-bootstrap "/bin"))
- (system* "tar" "xvf" #$tarball)
-
- (sql-schema
- #$(local-file (search-path %load-path
- "guix/store/schema.sql")))
- (with-database "var/guix/db/db.sqlite" db
- ;; Make sure non-ASCII file names are properly
- ;; handled.
- (setenv "GUIX_LOCPATH"
- #+(file-append glibc-utf8-locales
- "/lib/locale"))
- (setlocale LC_ALL "en_US.utf8")
-
- (mkdir #$output)
- (exit
- (and (every valid-file?
- '("α" "λ")
- '("alpha" "lambda"))
- (integer? (path-id db #$tree)))))))))))
+ (check (gexp->derivation
+ "check-tarball"
+ (with-extensions (list guile-sqlite3 guile-gcrypt)
+ (with-imported-modules (source-module-closure
+ '((guix store database)))
+ #~(begin
+ (use-modules (guix store database)
+ (rnrs io ports)
+ (srfi srfi-1))
+
+ (define (valid-file? basename data)
+ (define file
+ (string-append "./" #$tree "/" basename))
+
+ (string=? (call-with-input-file (pk 'file file)
+ get-string-all)
+ data))
+
+ (setenv "PATH"
+ (string-append #$%tar-bootstrap "/bin"))
+ (system* "tar" "xvf" #$tarball)
+
+ (sql-schema
+ #$(local-file (search-path %load-path
+ "guix/store/schema.sql")))
+ (with-database "var/guix/db/db.sqlite" db
+ ;; Make sure non-ASCII file names are properly
+ ;; handled.
+ (setenv "GUIX_LOCPATH"
+ #+(file-append glibc-utf8-locales
+ "/lib/locale"))
+ (setlocale LC_ALL "en_US.utf8")
+
+ (mkdir #$output)
+ (exit
+ (and (every valid-file?
+ '("α" "λ")
+ '("alpha" "lambda"))
+ (integer? (path-id db #$tree)))))))))))
(built-derivations (list check))))
(unless store (test-skip 1))
@@ -217,33 +220,34 @@
(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")
- (file-is-directory? "tmp")
- (string=? (string-append #$%bootstrap-guile "/bin")
- (pk 'binlink (readlink bin)))
- (string=? (string-append #$profile "/bin/guile")
- (pk 'guilelink (readlink "bin/Guile"))))
- (mkdir #$output)))))))
+ (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")
+ (file-is-directory? "tmp")
+ (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))))
(unless store (test-skip 1))
@@ -257,31 +261,32 @@
(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 "/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)))
-
- ;; This is a relative symlink target.
- (string=? (string-drop
- (string-append #$profile "/bin")
- 1)
- (pk 'guilelink (readlink "bin"))))
- (mkdir #$output))))))))
+ (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 "/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)))
+
+ ;; This is a relative symlink target.
+ (string=? (string-drop
+ (string-append #$profile "/bin")
+ 1)
+ (pk 'guilelink (readlink "bin"))))
+ (mkdir #$output))))))))
(built-derivations (list check))))
(unless store (test-skip 1))
generated by cgit