diff options
| -rw-r--r-- | tests/pack.scm | 279 |
1 files changed, 137 insertions, 142 deletions
diff --git a/tests/pack.scm b/tests/pack.scm index a4c388d93e..a02924b7d2 100644 --- a/tests/pack.scm +++ b/tests/pack.scm @@ -74,44 +74,43 @@ -> "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 @@ -131,17 +130,16 @@ #: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)) @@ -154,45 +152,44 @@ ("λ" 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)) @@ -206,34 +203,33 @@ (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)) @@ -247,32 +243,31 @@ (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)) |