diff options
Diffstat (limited to 'tests')
| -rw-r--r-- | tests/crate.scm | 4 | ||||
| -rw-r--r-- | tests/derivations.scm | 22 | ||||
| -rw-r--r-- | tests/guix-package.sh | 14 | ||||
| -rw-r--r-- | tests/hackage.scm | 168 | ||||
| -rw-r--r-- | tests/lzlib.scm | 10 | ||||
| -rw-r--r-- | tests/print.scm | 48 | ||||
| -rw-r--r-- | tests/publish.scm | 154 | ||||
| -rw-r--r-- | tests/store.scm | 20 | ||||
| -rw-r--r-- | tests/substitute.scm | 51 | ||||
| -rw-r--r-- | tests/utils.scm | 68 |
10 files changed, 455 insertions, 104 deletions
diff --git a/tests/crate.scm b/tests/crate.scm index a1dcfd5e52..a4a328d507 100644 --- a/tests/crate.scm +++ b/tests/crate.scm @@ -89,9 +89,9 @@ ('base32 (? string? hash))))) ('build-system 'cargo-build-system) - ('inputs + ('arguments ('quasiquote - (("rust-bar" ('unquote 'rust-bar) "src")))) + (('#:cargo-inputs (("rust-bar" ('unquote rust-bar))))))) ('home-page "http://example.com") ('synopsis "summary") ('description "summary") diff --git a/tests/derivations.scm b/tests/derivations.scm index dbb5b584eb..c421d094a4 100644 --- a/tests/derivations.scm +++ b/tests/derivations.scm @@ -787,6 +787,28 @@ (build-derivations store (list drv)) #f))) +(test-assert "build-derivations with specific output" + (with-store store + (let* ((content (random-text)) ;contents of the output + (drv (build-expression->derivation + store "substitute-me" + `(begin ,content (exit 1)) ;would fail + #:outputs '("out" "one" "two") + #:guile-for-build + (package-derivation store %bootstrap-guile))) + (out (derivation->output-path drv))) + (with-derivation-substitute drv content + (set-build-options store #:use-substitutes? #t + #:substitute-urls (%test-substitute-urls)) + (and (has-substitutes? store out) + + ;; Ask for nothing but the "out" output of DRV. + (build-derivations store `((,drv . "out"))) + + (valid-path? store out) + (equal? (pk 'x content) (pk 'y (call-with-input-file out get-string-all))) + ))))) + (test-assert "build-expression->derivation and derivation-prerequisites-to-build" (let ((drv (build-expression->derivation %store "fail" #f))) ;; The only direct dependency is (%guile-for-build) and it's already diff --git a/tests/guix-package.sh b/tests/guix-package.sh index 767c3f8a66..79d6ec65e4 100644 --- a/tests/guix-package.sh +++ b/tests/guix-package.sh @@ -280,6 +280,20 @@ export GUIX_PACKAGE_PATH guix package -A emacs-foo-bar | grep 42 guix package -i emacs-foo-bar@42 -n +# Make sure GUIX_PACKAGE_PATH/'-L' takes precedence in case of duplicate packages. +cat > "$module_dir/bar.scm"<<EOF +(define-module (bar) + #:use-module (guix packages)) + +(define-public hello + (package (inherit (@@ (gnu packages base) hello)) + (synopsis "an overridden version of GNU hello"))) +EOF + +guix package -i hello -n 2>&1 | grep choosing.*bar.scm +( unset GUIX_PACKAGE_PATH; \ + guix package -i hello -n -L "$module_dir" 2>&1 | grep choosing.*bar.scm ) + # Make sure patches that live under $GUIX_PACKAGE_PATH are found. cat > "$module_dir/emacs.patch"<<EOF This is a fake patch. diff --git a/tests/hackage.scm b/tests/hackage.scm index e17851a213..38a5825af7 100644 --- a/tests/hackage.scm +++ b/tests/hackage.scm @@ -155,78 +155,142 @@ library (test-begin "hackage") -(define* (eval-test-with-cabal test-cabal #:key (cabal-environment '())) - (mock - ((guix import hackage) hackage-fetch - (lambda (name-version) - (call-with-input-string test-cabal - read-cabal))) - (match (hackage->guix-package "foo" #:cabal-environment cabal-environment) - (('package - ('name "ghc-foo") - ('version "1.0.0") - ('source - ('origin - ('method 'url-fetch) - ('uri ('string-append - "https://hackage.haskell.org/package/foo/foo-" - 'version - ".tar.gz")) - ('sha256 - ('base32 - (? string? hash))))) - ('build-system 'haskell-build-system) - ('inputs - ('quasiquote - (("ghc-http" ('unquote 'ghc-http)) - ("ghc-mtl" ('unquote 'ghc-mtl))))) - ('home-page "http://test.org") - ('synopsis (? string?)) - ('description (? string?)) - ('license 'bsd-3)) - #t) - (x - (pk 'fail x #f))))) +(define-syntax-rule (define-package-matcher name pattern) + (define* (name obj) + (match obj + (pattern #t) + (x (pk 'fail x #f))))) + +(define-package-matcher match-ghc-foo + ('package + ('name "ghc-foo") + ('version "1.0.0") + ('source + ('origin + ('method 'url-fetch) + ('uri ('string-append + "https://hackage.haskell.org/package/foo/foo-" + 'version + ".tar.gz")) + ('sha256 + ('base32 + (? string? hash))))) + ('build-system 'haskell-build-system) + ('inputs + ('quasiquote + (("ghc-http" ('unquote 'ghc-http))))) + ('home-page "http://test.org") + ('synopsis (? string?)) + ('description (? string?)) + ('license 'bsd-3))) + +(define* (eval-test-with-cabal test-cabal matcher #:key (cabal-environment '())) + (define port (open-input-string test-cabal)) + (matcher (hackage->guix-package "foo" #:port port #:cabal-environment cabal-environment))) (test-assert "hackage->guix-package test 1" - (eval-test-with-cabal test-cabal-1)) + (eval-test-with-cabal test-cabal-1 match-ghc-foo)) (test-assert "hackage->guix-package test 2" - (eval-test-with-cabal test-cabal-2)) + (eval-test-with-cabal test-cabal-2 match-ghc-foo)) (test-assert "hackage->guix-package test 3" - (eval-test-with-cabal test-cabal-3 + (eval-test-with-cabal test-cabal-3 match-ghc-foo #:cabal-environment '(("impl" . "ghc-7.8")))) (test-assert "hackage->guix-package test 4" - (eval-test-with-cabal test-cabal-4 + (eval-test-with-cabal test-cabal-4 match-ghc-foo #:cabal-environment '(("impl" . "ghc-7.8")))) (test-assert "hackage->guix-package test 5" - (eval-test-with-cabal test-cabal-5 + (eval-test-with-cabal test-cabal-5 match-ghc-foo #:cabal-environment '(("impl" . "ghc-7.8")))) +(define-package-matcher match-ghc-foo-6 + ('package + ('name "ghc-foo") + ('version "1.0.0") + ('source + ('origin + ('method 'url-fetch) + ('uri ('string-append + "https://hackage.haskell.org/package/foo/foo-" + 'version + ".tar.gz")) + ('sha256 + ('base32 + (? string? hash))))) + ('build-system 'haskell-build-system) + ('inputs + ('quasiquote + (("ghc-b" ('unquote 'ghc-b)) + ("ghc-http" ('unquote 'ghc-http))))) + ('native-inputs + ('quasiquote + (("ghc-haskell-gi" ('unquote 'ghc-haskell-gi))))) + ('home-page "http://test.org") + ('synopsis (? string?)) + ('description (? string?)) + ('license 'bsd-3))) + (test-assert "hackage->guix-package test 6" - (eval-test-with-cabal test-cabal-6 - #:cabal-environment '(("impl" . "ghc-7.8")))) + (eval-test-with-cabal test-cabal-6 match-ghc-foo-6)) + +;; Check multi-line layouted description +(define test-cabal-multiline-layout + "name: foo +version: 1.0.0 +homepage: http://test.org +synopsis: synopsis +description: first line + second line +license: BSD3 +executable cabal + build-depends: + HTTP >= 4000.2.5 && < 4000.3, + mtl >= 2.0 && < 3 +") + +(test-assert "hackage->guix-package test multiline desc (layout)" + (eval-test-with-cabal test-cabal-multiline-layout match-ghc-foo)) + +;; Check multi-line braced description +(define test-cabal-multiline-braced + "name: foo +version: 1.0.0 +homepage: http://test.org +synopsis: synopsis +description: { +first line +second line +} +license: BSD3 +executable cabal + build-depends: + HTTP >= 4000.2.5 && < 4000.3, + mtl >= 2.0 && < 3 +") + +(test-assert "hackage->guix-package test multiline desc (braced)" + (eval-test-with-cabal test-cabal-multiline-braced match-ghc-foo)) (test-assert "read-cabal test 1" (match (call-with-input-string test-read-cabal-1 read-cabal) ((("name" ("test-me")) ('section 'library - (('if ('flag "base4point8") - (("build-depends" ("base >= 4.8 && < 5"))) - (('if ('flag "base4") - (("build-depends" ("base >= 4 && < 4.8"))) - (('if ('flag "base3") - (("build-depends" ("base >= 3 && < 4"))) - (("build-depends" ("base < 3")))))))) - ('if ('or ('flag "base4point8") - ('and ('flag "base4") ('flag "base3"))) - (("build-depends" ("random"))) - ()) - ("build-depends" ("containers")) - ("exposed-modules" ("Test.QuickCheck.Exception"))))) + (('if ('flag "base4point8") + (("build-depends" ("base >= 4.8 && < 5"))) + (('if ('flag "base4") + (("build-depends" ("base >= 4 && < 4.8"))) + (('if ('flag "base3") + (("build-depends" ("base >= 3 && < 4"))) + (("build-depends" ("base < 3")))))))) + ('if ('or ('flag "base4point8") + ('and ('flag "base4") ('flag "base3"))) + (("build-depends" ("random"))) + ()) + ("build-depends" ("containers")) + ("exposed-modules" ("Test.QuickCheck.Exception"))))) #t) (x (pk 'fail x #f)))) diff --git a/tests/lzlib.scm b/tests/lzlib.scm index cf53a9417d..543622bb45 100644 --- a/tests/lzlib.scm +++ b/tests/lzlib.scm @@ -108,4 +108,14 @@ (test-assert* "Bytevector of size relative to Lzip internal buffers (1MiB+1)" (compress-and-decompress (random-bytevector (1+ (* 1024 1024))))) +(test-assert "make-lzip-input-port/compressed" + (let* ((len (pk 'len (+ 10 (random 4000 %seed)))) + (data (random-bytevector len)) + (compressed (make-lzip-input-port/compressed + (open-bytevector-input-port data))) + (result (call-with-lzip-input-port compressed + get-bytevector-all))) + (pk (bytevector-length result) (bytevector-length data)) + (bytevector=? result data))) + (test-end) diff --git a/tests/print.scm b/tests/print.scm index 305807c1d1..d4b2cca93f 100644 --- a/tests/print.scm +++ b/tests/print.scm @@ -24,9 +24,31 @@ #:use-module (guix licenses) #:use-module (srfi srfi-64)) +(define-syntax-rule (define-with-source object source expr) + (begin + (define object expr) + (define source 'expr))) + (test-begin "print") -(define pkg +(define-with-source pkg pkg-source + (package + (name "test") + (version "1.2.3") + (source (origin + (method url-fetch) + (uri (string-append "file:///tmp/test-" + version ".tar.gz")) + (sha256 + (base32 + "070pwb7brdcn1mfvplkd56vjc7lbz4iznzkqvfsakvgbv68k71ah")))) + (build-system gnu-build-system) + (home-page "http://gnu.org") + (synopsis "Dummy") + (description "This is a dummy package.") + (license gpl3+))) + +(define-with-source pkg-with-inputs pkg-with-inputs-source (package (name "test") (version "1.2.3") @@ -38,27 +60,19 @@ (base32 "070pwb7brdcn1mfvplkd56vjc7lbz4iznzkqvfsakvgbv68k71ah")))) (build-system gnu-build-system) + (inputs `(("coreutils" ,(@ (gnu packages base) coreutils)) + ("glibc" ,(@ (gnu packages base) glibc) "debug"))) (home-page "http://gnu.org") (synopsis "Dummy") (description "This is a dummy package.") (license gpl3+))) (test-equal "simple package" - (package->code pkg) - '(package - (name "test") - (version "1.2.3") - (source (origin - (method url-fetch) - (uri (string-append "file:///tmp/test-" - version ".tar.gz")) - (sha256 - (base32 - "070pwb7brdcn1mfvplkd56vjc7lbz4iznzkqvfsakvgbv68k71ah")))) - (build-system gnu-build-system) - (home-page "http://gnu.org") - (synopsis "Dummy") - (description "This is a dummy package.") - (license gpl3+))) + pkg-source + (package->code pkg)) + +(test-equal "package with inputs" + pkg-with-inputs-source + (package->code pkg-with-inputs)) (test-end "print") diff --git a/tests/publish.scm b/tests/publish.scm index 097ac036e0..64a8ff3cae 100644 --- a/tests/publish.scm +++ b/tests/publish.scm @@ -36,6 +36,7 @@ #:use-module (gcrypt pk-crypto) #:use-module ((guix pki) #:select (%public-key-file %private-key-file)) #:use-module (guix zlib) + #:use-module (guix lzlib) #:use-module (web uri) #:use-module (web client) #:use-module (web response) @@ -137,17 +138,17 @@ "StorePath: ~a URL: nar/~a Compression: none +FileSize: ~a NarHash: sha256:~a NarSize: ~d -References: ~a -FileSize: ~a~%" +References: ~a~%" %item (basename %item) + (path-info-nar-size info) (bytevector->nix-base32-string (path-info-hash info)) (path-info-nar-size info) - (basename (first (path-info-references info))) - (path-info-nar-size info))) + (basename (first (path-info-references info))))) (signature (base64-encode (string->utf8 (canonical-sexp->string @@ -169,15 +170,15 @@ FileSize: ~a~%" "StorePath: ~a URL: nar/~a Compression: none +FileSize: ~a NarHash: sha256:~a NarSize: ~d -References: ~%\ -FileSize: ~a~%" +References: ~%" item (uri-encode (basename item)) + (path-info-nar-size info) (bytevector->nix-base32-string (path-info-hash info)) - (path-info-nar-size info) (path-info-nar-size info))) (signature (base64-encode (string->utf8 @@ -229,6 +230,19 @@ FileSize: ~a~%" (string-append "/nar/gzip/" (basename %item)))))) (get-bytevector-n nar (bytevector-length %gzip-magic-bytes)))) +(unless (lzlib-available?) + (test-skip 1)) +(test-equal "/nar/lzip/*" + "bar" + (call-with-temporary-output-file + (lambda (temp port) + (let ((nar (http-get-port + (publish-uri + (string-append "/nar/lzip/" (basename %item)))))) + (call-with-lzip-input-port nar + (cut restore-file <> temp))) + (call-with-input-file temp read-string)))) + (unless (zlib-available?) (test-skip 1)) (test-equal "/*.narinfo with compression" @@ -251,6 +265,28 @@ FileSize: ~a~%" (_ #f))) (recutils->alist body))))) +(unless (lzlib-available?) + (test-skip 1)) +(test-equal "/*.narinfo with lzip compression" + `(("StorePath" . ,%item) + ("URL" . ,(string-append "nar/lzip/" (basename %item))) + ("Compression" . "lzip")) + (let ((thread (with-separate-output-ports + (call-with-new-thread + (lambda () + (guix-publish "--port=6790" "-Clzip")))))) + (wait-until-ready 6790) + (let* ((url (string-append "http://localhost:6790/" + (store-path-hash-part %item) ".narinfo")) + (body (http-get-port url))) + (filter (lambda (item) + (match item + (("Compression" . _) #t) + (("StorePath" . _) #t) + (("URL" . _) #t) + (_ #f))) + (recutils->alist body))))) + (unless (zlib-available?) (test-skip 1)) (test-equal "/*.narinfo for a compressed file" @@ -265,6 +301,35 @@ FileSize: ~a~%" (list (assoc-ref info "Compression") (dirname (assoc-ref info "URL"))))) +(unless (and (zlib-available?) (lzlib-available?)) + (test-skip 1)) +(test-equal "/*.narinfo with lzip + gzip" + `((("StorePath" . ,%item) + ("URL" . ,(string-append "nar/gzip/" (basename %item))) + ("Compression" . "gzip") + ("URL" . ,(string-append "nar/lzip/" (basename %item))) + ("Compression" . "lzip")) + 200 + 200) + (call-with-temporary-directory + (lambda (cache) + (let ((thread (with-separate-output-ports + (call-with-new-thread + (lambda () + (guix-publish "--port=6793" "-Cgzip:2" "-Clzip:2")))))) + (wait-until-ready 6793) + (let* ((base "http://localhost:6793/") + (part (store-path-hash-part %item)) + (url (string-append base part ".narinfo")) + (body (http-get-port url))) + (list (take (recutils->alist body) 5) + (response-code + (http-get (string-append base "nar/gzip/" + (basename %item)))) + (response-code + (http-get (string-append base "nar/lzip/" + (basename %item)))))))))) + (test-equal "custom nar path" ;; Serve nars at /foo/bar/chbouib instead of /nar. (list `(("StorePath" . ,%item) @@ -405,6 +470,52 @@ FileSize: ~a~%" (stat:size (stat nar))) (response-code uncompressed))))))))) +(unless (and (zlib-available?) (lzlib-available?)) + (test-skip 1)) +(test-equal "with cache, lzip + gzip" + '(200 200 404) + (call-with-temporary-directory + (lambda (cache) + (let ((thread (with-separate-output-ports + (call-with-new-thread + (lambda () + (guix-publish "--port=6794" "-Cgzip:2" "-Clzip:2" + (string-append "--cache=" cache))))))) + (wait-until-ready 6794) + (let* ((base "http://localhost:6794/") + (part (store-path-hash-part %item)) + (url (string-append base part ".narinfo")) + (nar-url (cute string-append "nar/" <> "/" + (basename %item))) + (cached (cute string-append cache "/" <> "/" + (basename %item) ".narinfo")) + (nar (cute string-append cache "/" <> "/" + (basename %item) ".nar")) + (response (http-get url))) + (wait-for-file (cached "gzip")) + (let* ((body (http-get-port url)) + (narinfo (recutils->alist body)) + (uncompressed (string-append base "nar/" + (basename %item)))) + (and (file-exists? (nar "gzip")) + (file-exists? (nar "lzip")) + (equal? (take (pk 'narinfo/gzip+lzip narinfo) 7) + `(("StorePath" . ,%item) + ("URL" . ,(nar-url "gzip")) + ("Compression" . "gzip") + ("FileSize" . ,(number->string + (stat:size (stat (nar "gzip"))))) + ("URL" . ,(nar-url "lzip")) + ("Compression" . "lzip") + ("FileSize" . ,(number->string + (stat:size (stat (nar "lzip"))))))) + (list (response-code + (http-get (string-append base (nar-url "gzip")))) + (response-code + (http-get (string-append base (nar-url "lzip")))) + (response-code + (http-get uncompressed)))))))))) + (unless (zlib-available?) (test-skip 1)) (let ((item (add-text-to-store %store "fake-compressed-thing.tar.gz" @@ -469,6 +580,35 @@ FileSize: ~a~%" (assoc-ref narinfo "FileSize")) (response-code compressed)))))))))) +(test-equal "with cache, vanishing item" ;<https://bugs.gnu.org/33897> + 200 + (call-with-temporary-directory + (lambda (cache) + (let ((thread (with-separate-output-ports + (call-with-new-thread + (lambda () + (guix-publish "--port=6795" + (string-append "--cache=" cache))))))) + (wait-until-ready 6795) + + ;; Make sure that, even if ITEM disappears, we're still able to fetch + ;; it. + (let* ((base "http://localhost:6795/") + (item (add-text-to-store %store "random" (random-text))) + (part (store-path-hash-part item)) + (url (string-append base part ".narinfo")) + (cached (string-append cache + (if (zlib-available?) + "/gzip/" "/none/") + (basename item) + ".narinfo")) + (response (http-get url))) + (and (= 404 (response-code response)) + (wait-for-file cached) + (begin + (delete-paths %store (list item)) + (response-code (pk 'response (http-get url)))))))))) + (test-equal "/log/NAME" `(200 #t application/x-bzip2) (let ((drv (run-with-store %store diff --git a/tests/store.scm b/tests/store.scm index df66feaebb..518750d26a 100644 --- a/tests/store.scm +++ b/tests/store.scm @@ -599,6 +599,26 @@ (valid-path? s o) (equal? c (call-with-input-file o get-string-all))))))) +(test-assert "substitute + build-things with specific output" + (with-store s + (let* ((c (random-text)) ;contents of the output + (d (build-expression->derivation + s "substitute-me" `(begin ,c (exit 1)) ;would fail + #:outputs '("out" "one" "two") + #:guile-for-build + (package-derivation s %bootstrap-guile (%current-system)))) + (o (derivation->output-path d))) + (with-derivation-substitute d c + (set-build-options s #:use-substitutes? #t + #:substitute-urls (%test-substitute-urls)) + (and (has-substitutes? s o) + + ;; Ask for nothing but the "out" output of D. + (build-things s `((,(derivation-file-name d) . "out"))) + + (valid-path? s o) + (equal? c (call-with-input-file o get-string-all))))))) + (test-assert "substitute, corrupt output hash" ;; Tweak the substituter into installing a substitute whose hash doesn't ;; match the one announced in the narinfo. The daemon must notice this and diff --git a/tests/substitute.scm b/tests/substitute.scm index f4f2e9512d..ff2be662be 100644 --- a/tests/substitute.scm +++ b/tests/substitute.scm @@ -28,8 +28,10 @@ #:use-module (guix base32) #:use-module ((guix store) #:select (%store-prefix)) #:use-module ((guix ui) #:select (guix-warning-port)) + #:use-module ((guix utils) #:select (call-with-compressed-output-port)) + #:use-module ((guix lzlib) #:select (lzlib-available?)) #:use-module ((guix build utils) - #:select (mkdir-p delete-file-recursively)) + #:select (mkdir-p delete-file-recursively dump-port)) #:use-module (guix tests http) #:use-module (rnrs bytevectors) #:use-module (rnrs io ports) @@ -475,6 +477,53 @@ System: mips64el-linux\n") "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo") "substitute-retrieved")))) +(test-equal "substitute, narinfo with several URLs" + "Substitutable data." + (let ((narinfo (string-append "StorePath: " (%store-prefix) + "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo +URL: example.nar.gz +Compression: gzip +URL: example.nar.lz +Compression: lzip +URL: example.nar +Compression: none +NarHash: sha256:" (bytevector->nix-base32-string + (sha256 (string->utf8 "Substitutable data."))) " +NarSize: 42 +References: bar baz +Deriver: " (%store-prefix) "/foo.drv +System: mips64el-linux\n"))) + (with-narinfo (string-append narinfo "Signature: " + (signature-field narinfo)) + (dynamic-wind + (const #t) + (lambda () + (define (compress input output compression) + (call-with-output-file output + (lambda (port) + (call-with-compressed-output-port compression port + (lambda (port) + (call-with-input-file input + (lambda (input) + (dump-port input port)))))))) + + (let ((nar (string-append %main-substitute-directory + "/example.nar"))) + (compress nar (string-append nar ".gz") 'gzip) + (when (lzlib-available?) + (compress nar (string-append nar ".lz") 'lzip))) + + (parameterize ((substitute-urls + (list (string-append "file://" + %main-substitute-directory)))) + (guix-substitute "--substitute" + (string-append (%store-prefix) + "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo") + "substitute-retrieved")) + (call-with-input-file "substitute-retrieved" get-string-all)) + (lambda () + (false-if-exception (delete-file "substitute-retrieved"))))))) + (test-end "substitute") ;;; Local Variables: diff --git a/tests/utils.scm b/tests/utils.scm index 3015b21b23..44861384ab 100644 --- a/tests/utils.scm +++ b/tests/utils.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2014 Eric Bavier <bavier@member.fsf.org> ;;; Copyright © 2016 Mathieu Lirzin <mthl@gnu.org> ;;; @@ -23,6 +23,7 @@ #:use-module (guix utils) #:use-module ((guix store) #:select (%store-prefix store-path-package-name)) #:use-module ((guix search-paths) #:select (string-tokenize*)) + #:use-module ((guix lzlib) #:select (lzlib-available?)) #:use-module (srfi srfi-1) #:use-module (srfi srfi-11) #:use-module (srfi srfi-64) @@ -174,30 +175,47 @@ (any (compose (negate zero?) cdr waitpid) pids)))) -(test-assert "compressed-port, decompressed-port, non-file" - (let ((data (call-with-input-file (search-path %load-path "guix.scm") - get-bytevector-all))) - (let*-values (((compressed pids1) - (compressed-port 'xz (open-bytevector-input-port data))) - ((decompressed pids2) - (decompressed-port 'xz compressed))) - (and (every (compose zero? cdr waitpid) - (append pids1 pids2)) - (equal? (get-bytevector-all decompressed) data))))) - -(false-if-exception (delete-file temp-file)) -(test-assert "compressed-output-port + decompressed-port" - (let* ((file (search-path %load-path "guix/derivations.scm")) - (data (call-with-input-file file get-bytevector-all)) - (port (open-file temp-file "w0b"))) - (call-with-compressed-output-port 'xz port - (lambda (compressed) - (put-bytevector compressed data))) - (close-port port) - - (bytevector=? data - (call-with-decompressed-port 'xz (open-file temp-file "r0b") - get-bytevector-all)))) +(define (test-compression/decompression method run?) + "Test METHOD, a symbol such as 'gzip. Call RUN? to determine whether to +skip these tests." + (unless (run?) (test-skip 1)) + (test-assert (format #f "compressed-port, decompressed-port, non-file [~a]" + method) + (let ((data (call-with-input-file (search-path %load-path "guix.scm") + get-bytevector-all))) + (let*-values (((compressed pids1) + (compressed-port method (open-bytevector-input-port data))) + ((decompressed pids2) + (decompressed-port method compressed))) + (and (every (compose zero? cdr waitpid) + (pk 'pids method (append pids1 pids2))) + (let ((result (get-bytevector-all decompressed))) + (pk 'len method + (if (bytevector? result) + (bytevector-length result) + result) + (bytevector-length data)) + (equal? result data)))))) + + (false-if-exception (delete-file temp-file)) + (unless (run?) (test-skip 1)) + (test-assert (format #f "compressed-output-port + decompressed-port [~a]" + method) + (let* ((file (search-path %load-path "guix/derivations.scm")) + (data (call-with-input-file file get-bytevector-all)) + (port (open-file temp-file "w0b"))) + (call-with-compressed-output-port method port + (lambda (compressed) + (put-bytevector compressed data))) + (close-port port) + + (bytevector=? data + (call-with-decompressed-port method (open-file temp-file "r0b") + get-bytevector-all))))) + +(for-each test-compression/decompression + '(gzip xz lzip) + (list (const #t) (const #t) lzlib-available?)) ;; This is actually in (guix store). (test-equal "store-path-package-name" |