diff options
Diffstat (limited to 'tests/pack.scm')
| -rw-r--r-- | tests/pack.scm | 307 |
1 files changed, 154 insertions, 153 deletions
diff --git a/tests/pack.scm b/tests/pack.scm index ce5a2f8a53..cf249f861b 100644 --- a/tests/pack.scm +++ b/tests/pack.scm @@ -76,66 +76,66 @@ (test-begin "pack") -(unless (network-reachable?) (test-skip 1)) -(test-assertm "self-contained-tarball" %store - (mlet* %store-monad - ((profile -> (profile - (content (packages->manifest (list %bootstrap-guile))) - (hooks '()) - (locales? #f))) - (tarball (self-contained-tarball "pack" profile - #:symlinks '(("/bin/Guile" - -> "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"))))))))) - (built-derivations (list check)))) - ;; The following test needs guile-sqlite3, libgcrypt, etc. as a consequence of ;; commit c45477d2a1a651485feede20fe0f3d15aec48b39 and related changes. Thus, ;; run it on the user's store, if it's available, on the grounds that these ;; dependencies may be already there, or we can get substitutes or build them ;; quite inexpensively; see <https://bugs.gnu.org/32184>. - (with-external-store store (unless store (test-skip 1)) + (test-assertm "self-contained-tarball" store + (mlet* %store-monad + ((guile (set-guile-for-build (default-guile))) + (profile -> (profile + (content (packages->manifest (list %bootstrap-guile))) + (hooks '()) + (locales? #f))) + (tarball (self-contained-tarball "pack" profile + #:symlinks '(("/bin/Guile" + -> "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"))))))))) + (built-derivations (list check)))) + + (unless store (test-skip 1)) (test-assertm "self-contained-tarball + localstatedir" store (mlet* %store-monad ((guile (set-guile-for-build (default-guile))) @@ -239,15 +239,14 @@ ((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))))))) + (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)) @@ -310,71 +309,72 @@ (plain-file "postinst" "echo running configure script\n")))) (check - (gexp->derivation "check-deb-pack" - (with-imported-modules '((guix build utils)) - #~(begin - (use-modules (guix build utils) - (ice-9 match) - (ice-9 popen) - (ice-9 rdelim) - (ice-9 textual-ports) - (rnrs base)) - - (setenv "PATH" (string-join - (list (string-append #+%tar-bootstrap "/bin") - (string-append #+dpkg "/bin") - (string-append #+%ar-bootstrap "/bin")) - ":")) - - ;; Validate the output of 'dpkg --info'. - (let* ((port (open-pipe* OPEN_READ "dpkg" "--info" #$deb)) - (info (get-string-all port)) - (exit-val (status:exit-val (close-pipe port)))) - (assert (zero? exit-val)) - - (assert (string-contains - info - (string-append "Package: " - #+(package-name %bootstrap-guile)))) - - (assert (string-contains - info - (string-append "Version: " - #+(package-version %bootstrap-guile))))) - - ;; Sanity check .deb contents. - (invoke "ar" "-xv" #$deb) - (assert (file-exists? "debian-binary")) - (assert (file-exists? "data.tar.gz")) - (assert (file-exists? "control.tar.gz")) - - ;; Verify there are no hard links in data.tar.gz, as hard - ;; links would cause dpkg to fail unpacking the archive. - (define hard-links - (let ((port (open-pipe* OPEN_READ "tar" "-tvf" "data.tar.gz"))) - (let loop ((hard-links '())) - (match (read-line port) - ((? eof-object?) - (assert (zero? (status:exit-val (close-pipe port)))) - hard-links) - (line - (if (string-prefix? "u" line) - (loop (cons line hard-links)) - (loop hard-links))))))) - - (unless (null? hard-links) - (error "hard links found in data.tar.gz" hard-links)) - - ;; Verify the presence of the control files. - (invoke "tar" "-xf" "control.tar.gz") - (assert (file-exists? "control")) - (assert (and (file-exists? "postinst") - (= #o111 ;script is executable - (logand #o111 (stat:perms - (stat "postinst")))))) - (assert (file-exists? "triggers")) - - (mkdir #$output)))))) + (gexp->derivation + "check-deb-pack" + (with-imported-modules '((guix build utils)) + #~(begin + (use-modules (guix build utils) + (ice-9 match) + (ice-9 popen) + (ice-9 rdelim) + (ice-9 textual-ports) + (rnrs base)) + + (setenv "PATH" (string-join + (list (string-append #+%tar-bootstrap "/bin") + (string-append #+dpkg "/bin") + (string-append #+%ar-bootstrap "/bin")) + ":")) + + ;; Validate the output of 'dpkg --info'. + (let* ((port (open-pipe* OPEN_READ "dpkg" "--info" #$deb)) + (info (get-string-all port)) + (exit-val (status:exit-val (close-pipe port)))) + (assert (zero? exit-val)) + + (assert (string-contains + info + (string-append "Package: " + #+(package-name %bootstrap-guile)))) + + (assert (string-contains + info + (string-append "Version: " + #+(package-version %bootstrap-guile))))) + + ;; Sanity check .deb contents. + (invoke "ar" "-xv" #$deb) + (assert (file-exists? "debian-binary")) + (assert (file-exists? "data.tar.gz")) + (assert (file-exists? "control.tar.gz")) + + ;; Verify there are no hard links in data.tar.gz, as hard + ;; links would cause dpkg to fail unpacking the archive. + (define hard-links + (let ((port (open-pipe* OPEN_READ "tar" "-tvf" "data.tar.gz"))) + (let loop ((hard-links '())) + (match (read-line port) + ((? eof-object?) + (assert (zero? (status:exit-val (close-pipe port)))) + hard-links) + (line + (if (string-prefix? "u" line) + (loop (cons line hard-links)) + (loop hard-links))))))) + + (unless (null? hard-links) + (error "hard links found in data.tar.gz" hard-links)) + + ;; Verify the presence of the control files. + (invoke "tar" "-xf" "control.tar.gz") + (assert (file-exists? "control")) + (assert (and (file-exists? "postinst") + (= #o111 ;script is executable + (logand #o111 (stat:perms + (stat "postinst")))))) + (assert (file-exists? "triggers")) + + (mkdir #$output)))))) (built-derivations (list check)))) (unless store (test-skip 1)) @@ -390,32 +390,33 @@ #:symlinks '(("/bin/guile" -> "bin/guile")) #:extra-options '(#:relocatable? #t))) (check - (gexp->derivation "check-rpm-pack" - (with-imported-modules (source-module-closure - '((guix build utils))) - #~(begin - (use-modules (guix build utils)) - - (define fakeroot #+(file-append fakeroot "/bin/fakeroot")) - (define rpm #+(file-append rpm-for-tests "/bin/rpm")) - (mkdir-p "/tmp/lib/rpm") - - ;; Install the RPM package. This causes RPM to validate the - ;; signatures, header as well as the file digests, which - ;; makes it a rather thorough test. - (mkdir "test-prefix") - (invoke fakeroot rpm "--install" - (string-append "--prefix=" (getcwd) "/test-prefix") - #$rpm-pack) - - ;; Invoke the installed Guile command. - (invoke "./test-prefix/bin/guile" "--version") - - ;; Uninstall the RPM package. - (invoke fakeroot rpm "--erase" "guile-bootstrap") - - ;; Required so the above is run. - (mkdir #$output)))))) + (gexp->derivation + "check-rpm-pack" + (with-imported-modules (source-module-closure + '((guix build utils))) + #~(begin + (use-modules (guix build utils)) + + (define fakeroot #+(file-append fakeroot "/bin/fakeroot")) + (define rpm #+(file-append rpm-for-tests "/bin/rpm")) + (mkdir-p "/tmp/lib/rpm") + + ;; Install the RPM package. This causes RPM to validate the + ;; signatures, header as well as the file digests, which + ;; makes it a rather thorough test. + (mkdir "test-prefix") + (invoke fakeroot rpm "--install" + (string-append "--prefix=" (getcwd) "/test-prefix") + #$rpm-pack) + + ;; Invoke the installed Guile command. + (invoke "./test-prefix/bin/guile" "--version") + + ;; Uninstall the RPM package. + (invoke fakeroot rpm "--erase" "guile-bootstrap") + + ;; Required so the above is run. + (mkdir #$output)))))) (built-derivations (list check))))) (test-end) |