X-Git-Url: http://git.hcoop.net/jackhill/guix/guix.git/blobdiff_plain/b03e4fd5269897448124a7b61a737802b2c638ee..97cb43e732a38758c95b7caf3963507188d011cf:/tests/pack.scm diff --git a/tests/pack.scm b/tests/pack.scm index 40473a9fe9..98bfedf21c 100644 --- a/tests/pack.scm +++ b/tests/pack.scm @@ -1,6 +1,7 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2017, 2018 Ludovic Courtès +;;; Copyright © 2017, 2018, 2019, 2020, 2021 Ludovic Courtès ;;; Copyright © 2018 Ricardo Wurmus +;;; Copyright © 2021 Maxim Cournoyer ;;; ;;; This file is part of GNU Guix. ;;; @@ -27,8 +28,14 @@ #:use-module (guix grafts) #:use-module (guix tests) #:use-module (guix gexp) + #:use-module (guix modules) + #:use-module (gnu packages) + #:use-module ((gnu packages base) #:select (glibc-utf8-locales)) #:use-module (gnu packages bootstrap) - #:use-module ((gnu packages compression) #:select (squashfs-tools-next)) + #:use-module ((gnu packages compression) #:select (squashfs-tools)) + #:use-module ((gnu packages debian) #:select (dpkg)) + #:use-module ((gnu packages guile) #:select (guile-sqlite3)) + #:use-module ((gnu packages gnupg) #:select (guile-gcrypt)) #:use-module (srfi srfi-64)) (define %store @@ -46,21 +53,23 @@ (define %gzip-compressor ;; Compressor that uses the bootstrap 'gzip'. ((@ (guix scripts pack) compressor) "gzip" - "gz" - #~(#+(file-append %bootstrap-coreutils&co "/bin/gzip") "-6n"))) + ".gz" + #~(list #+(file-append %bootstrap-coreutils&co "/bin/gzip") "-6n"))) (define %tar-bootstrap %bootstrap-coreutils&co) +(define %ar-bootstrap %bootstrap-binutils) + (test-begin "pack") (unless (network-reachable?) (test-skip 1)) (test-assertm "self-contained-tarball" %store (mlet* %store-monad - ((profile (profile-derivation (packages->manifest - (list %bootstrap-guile)) - #:hooks '() - #:locales? #f)) + ((profile -> (profile + (content (packages->manifest (list %bootstrap-guile))) + (hooks '()) + (locales? #f))) (tarball (self-contained-tarball "pack" profile #:symlinks '(("/bin/Guile" -> "bin/guile")) @@ -136,6 +145,57 @@ (readlink bin)))))))) (built-derivations (list check)))) + (unless store (test-skip 1)) + (test-assertm "self-contained-tarball + localstatedir, UTF-8 file names" store + (mlet* %store-monad + ((guile (set-guile-for-build (default-guile))) + (tree (interned-file-tree + `("directory-with-utf8-file-names" directory + ("α" regular (data "alpha")) + ("λ" 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))))))))))) + (built-derivations (list check)))) + (unless store (test-skip 1)) (test-assertm "docker-image + localstatedir" store (mlet* %store-monad @@ -169,6 +229,7 @@ (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") @@ -198,7 +259,7 @@ (string-append "." #$profile "/bin")) (setenv "PATH" - (string-append #$squashfs-tools-next "/bin")) + (string-append #$squashfs-tools "/bin")) (invoke "unsquashfs" #$image) (with-directory-excursion "squashfs-root" (when (and (file-exists? (string-append bin @@ -206,9 +267,101 @@ (file-exists? "var/guix/db/db.sqlite") (string=? (string-append #$%bootstrap-guile "/bin") (pk 'binlink (readlink bin))) - (string=? (string-append #$profile "/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)) + (test-assertm "deb archive with symlinks and control files" store + (mlet* %store-monad + ((guile (set-guile-for-build (default-guile))) + (profile (profile-derivation (packages->manifest + (list %bootstrap-guile)) + #:hooks '() + #:locales? #f)) + (deb (debian-archive + "deb-pack" profile + #:compressor %gzip-compressor + #:symlinks '(("/opt/gnu/bin" -> "bin")) + #:archiver %tar-bootstrap + #:extra-options + (list #:triggers-file + (plain-file "triggers" + "activate-noawait /usr/share/icons/hicolor\n") + #:postinst-file + (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)))))) (built-derivations (list check))))) (test-end)