diff options
Diffstat (limited to 'tests')
| -rw-r--r-- | tests/boot-parameters.scm | 30 | ||||
| -rw-r--r-- | tests/crate.scm | 589 | ||||
| -rw-r--r-- | tests/cve-sample.json | 2 | ||||
| -rw-r--r-- | tests/elpa.scm | 3 | ||||
| -rw-r--r-- | tests/gexp.scm | 20 | ||||
| -rw-r--r-- | tests/glob.scm | 8 | ||||
| -rw-r--r-- | tests/guix-archive.sh | 4 | ||||
| -rw-r--r-- | tests/guix-hash.sh | 3 | ||||
| -rw-r--r-- | tests/guix-pack-relocatable.sh | 2 | ||||
| -rw-r--r-- | tests/import-utils.scm | 40 | ||||
| -rw-r--r-- | tests/lint.scm | 33 | ||||
| -rw-r--r-- | tests/nar.scm | 21 | ||||
| -rw-r--r-- | tests/opam.scm | 67 | ||||
| -rw-r--r-- | tests/profiles.scm | 38 | ||||
| -rw-r--r-- | tests/store-database.scm | 18 | ||||
| -rw-r--r-- | tests/store-deduplication.scm | 20 | ||||
| -rw-r--r-- | tests/store.scm | 82 | ||||
| -rw-r--r-- | tests/substitute.scm | 154 | ||||
| -rw-r--r-- | tests/swh.scm | 2 | ||||
| -rw-r--r-- | tests/transformations.scm | 31 |
20 files changed, 862 insertions, 305 deletions
diff --git a/tests/boot-parameters.scm b/tests/boot-parameters.scm index a00b227551..3deae564c4 100644 --- a/tests/boot-parameters.scm +++ b/tests/boot-parameters.scm @@ -50,6 +50,9 @@ (define %default-store-directory-prefix (string-append "/" %default-btrfs-subvolume)) (define %default-store-mount-point (%store-prefix)) +(define %default-store-crypto-devices + (list (uuid "00000000-1111-2222-3333-444444444444") + (uuid "55555555-6666-7777-8888-999999999999"))) (define %default-multiboot-modules '()) (define %default-locale "es_ES.utf8") (define %root-path "/") @@ -67,6 +70,7 @@ (locale %default-locale) (store-device %default-store-device) (store-directory-prefix %default-store-directory-prefix) + (store-crypto-devices %default-store-crypto-devices) (store-mount-point %default-store-mount-point))) (define %default-operating-system @@ -110,6 +114,8 @@ (with-store #t) (store-device (quote-uuid %default-store-device)) + (store-crypto-devices + (map quote-uuid %default-store-crypto-devices)) (store-directory-prefix %default-store-directory-prefix) (store-mount-point %default-store-mount-point)) (define (generate-boot-parameters) @@ -125,12 +131,14 @@ (sexp-or-nothing " (kernel-arguments ~S)" kernel-arguments) (sexp-or-nothing " (initrd ~S)" initrd) (if with-store - (format #false " (store~a~a~a)" + (format #false " (store~a~a~a~a)" (sexp-or-nothing " (device ~S)" store-device) (sexp-or-nothing " (mount-point ~S)" store-mount-point) (sexp-or-nothing " (directory-prefix ~S)" - store-directory-prefix)) + store-directory-prefix) + (sexp-or-nothing " (crypto-devices ~S)" + store-crypto-devices)) "") (sexp-or-nothing " (locale ~S)" locale) (sexp-or-nothing " (bootloader-name ~a)" bootloader-name) @@ -158,6 +166,7 @@ (test-read-boot-parameters #:with-store #false) (test-read-boot-parameters #:store-device #false) (test-read-boot-parameters #:store-device 'false) + (test-read-boot-parameters #:store-crypto-devices #false) (test-read-boot-parameters #:store-mount-point #false) (test-read-boot-parameters #:store-directory-prefix #false) (test-read-boot-parameters #:multiboot-modules #false) @@ -254,6 +263,23 @@ (boot-parameters-store-mount-point (test-read-boot-parameters #:with-store #false))) +(test-equal "read, store-crypto-devices, default" + '() + (boot-parameters-store-crypto-devices + (test-read-boot-parameters #:store-crypto-devices #false))) + +;; XXX: <warning: unrecognized crypto-devices #f at '#f'> +(test-equal "read, store-crypto-devices, false" + '() + (boot-parameters-store-crypto-devices + (test-read-boot-parameters #:store-crypto-devices 'false))) + +;; XXX: <warning: unrecognized crypto-device "bad" at '#f'> +(test-equal "read, store-crypto-devices, string" + '() + (boot-parameters-store-crypto-devices + (test-read-boot-parameters #:store-crypto-devices "bad"))) + ;; For whitebox testing (define operating-system-boot-parameters (@@ (gnu system) operating-system-boot-parameters)) diff --git a/tests/crate.scm b/tests/crate.scm index 61a04f986b..bb7032c344 100644 --- a/tests/crate.scm +++ b/tests/crate.scm @@ -2,6 +2,7 @@ ;;; Copyright © 2014 David Thompson <davet@gnu.org> ;;; Copyright © 2016 David Craven <david@craven.ch> ;;; Copyright © 2019, 2020 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2020 Martin Becze <mjbecze@riseup.net> ;;; ;;; This file is part of GNU Guix. ;;; @@ -24,27 +25,72 @@ #:use-module (guix build-system cargo) #:use-module (gcrypt hash) #:use-module (guix tests) + #:use-module (gnu packages) #:use-module (ice-9 iconv) #:use-module (ice-9 match) #:use-module (srfi srfi-64)) + +;; crate versions and dependencies used here +;; foo-0.8.1 +;; foo-1.0.0 +;; foo-1.0.3 +;; leaf-alice 0.7.5 +;; +;; root-1.0.0 +;; root-1.0.4 +;; intermediate-a 1.0.42 +;; intermeidate-b ^1.0.0 +;; leaf-alice ^0.7 +;; leaf-bob ^3 +;; +;; intermediate-a-1.0.40 +;; intermediate-a-1.0.42 +;; intermediate-a-1.1.0-alpha.1 +;; intermediate-a 1.2.3 +;; leaf-alice 0.7.5 +;; leaf-bob ^3 +;; +;; intermediate-b-1.2.3 +;; leaf-bob 3.0.1 +;; +;; leaf-alice-0.7.3 +;; leaf-alice-0.7.5 +;; +;; leaf-bob-3.0.1 + + (define test-foo-crate "{ \"crate\": { - \"max_version\": \"1.0.0\", + \"max_version\": \"1.0.3\", \"name\": \"foo\", \"description\": \"summary\", \"homepage\": \"http://example.com\", \"repository\": \"http://example.com\", - \"keywords\": [\"dummy\" \"test\"], - \"categories\": [\"test\"] + \"keywords\": [\"dummy\", \"test\"], + \"categories\": [\"test\"], \"actual_versions\": [ - { \"id\": \"foo\", + { \"id\": 234210, + \"num\": \"0.8.1\", + \"license\": \"MIT OR Apache-2.0\", + \"links\": { + \"dependencies\": \"/api/v1/crates/foo/0.8.1/dependencies\" + } + }, + { \"id\": 234212, \"num\": \"1.0.0\", \"license\": \"MIT OR Apache-2.0\", \"links\": { \"dependencies\": \"/api/v1/crates/foo/1.0.0/dependencies\" } + }, + { \"id\": 234214, + \"num\": \"1.0.3\", + \"license\": \"MIT OR Apache-2.0\", + \"links\": { + \"dependencies\": \"/api/v1/crates/foo/1.0.3/dependencies\" + } } ] } @@ -54,8 +100,9 @@ "{ \"dependencies\": [ { - \"crate_id\": \"bar\", - \"kind\": \"normal\" + \"crate_id\": \"leaf-alice\", + \"kind\": \"normal\", + \"req\": \"0.7.5\" } ] }") @@ -63,20 +110,27 @@ (define test-root-crate "{ \"crate\": { - \"max_version\": \"1.0.0\", + \"max_version\": \"1.0.4\", \"name\": \"root\", \"description\": \"summary\", \"homepage\": \"http://example.com\", \"repository\": \"http://example.com\", - \"keywords\": [\"dummy\" \"test\"], - \"categories\": [\"test\"] + \"keywords\": [\"dummy\", \"test\"], + \"categories\": [\"test\"], \"actual_versions\": [ - { \"id\": \"foo\", + { \"id\": 234240, \"num\": \"1.0.0\", \"license\": \"MIT OR Apache-2.0\", \"links\": { \"dependencies\": \"/api/v1/crates/root/1.0.0/dependencies\" } + }, + { \"id\": 234242, + \"num\": \"1.0.4\", + \"license\": \"MIT OR Apache-2.0\", + \"links\": { + \"dependencies\": \"/api/v1/crates/root/1.0.4/dependencies\" + } } ] } @@ -86,92 +140,114 @@ "{ \"dependencies\": [ { - \"crate_id\": \"intermediate-1\", - \"kind\": \"normal\" + \"crate_id\": \"intermediate-a\", + \"kind\": \"normal\", + \"req\": \"1.0.42\" }, { - \"crate_id\": \"intermediate-2\", - \"kind\": \"normal\" + \"crate_id\": \"intermediate-b\", + \"kind\": \"normal\", + \"req\": \"^1.0.0\" } { \"crate_id\": \"leaf-alice\", - \"kind\": \"normal\" + \"kind\": \"normal\", + \"req\": \"^0.7\" }, { \"crate_id\": \"leaf-bob\", - \"kind\": \"normal\" + \"kind\": \"normal\", + \"req\": \"^3\" } ] }") -(define test-intermediate-1-crate +(define test-intermediate-a-crate "{ \"crate\": { - \"max_version\": \"1.0.0\", - \"name\": \"intermediate-1\", + \"max_version\": \"1.1.0-alpha.1\", + \"name\": \"intermediate-a\", \"description\": \"summary\", \"homepage\": \"http://example.com\", \"repository\": \"http://example.com\", - \"keywords\": [\"dummy\" \"test\"], - \"categories\": [\"test\"] + \"keywords\": [\"dummy\", \"test\"], + \"categories\": [\"test\"], \"actual_versions\": [ - { \"id\": \"intermediate-1\", - \"num\": \"1.0.0\", + { \"id\": 234251, + \"num\": \"1.0.40\", + \"license\": \"MIT OR Apache-2.0\", + \"links\": { + \"dependencies\": \"/api/v1/crates/intermediate-a/1.0.40/dependencies\" + } + }, + { \"id\": 234250, + \"num\": \"1.0.42\", + \"license\": \"MIT OR Apache-2.0\", + \"links\": { + \"dependencies\": \"/api/v1/crates/intermediate-a/1.0.42/dependencies\" + } + }, + { \"id\": 234252, + \"num\": \"1.1.0-alpha.1\", \"license\": \"MIT OR Apache-2.0\", \"links\": { - \"dependencies\": \"/api/v1/crates/intermediate-1/1.0.0/dependencies\" + \"dependencies\": \"/api/v1/crates/intermediate-a/1.1.0-alpha.1/dependencies\" } } ] } }") -(define test-intermediate-1-dependencies +(define test-intermediate-a-dependencies "{ \"dependencies\": [ { - \"crate_id\": \"intermediate-2\", - \"kind\": \"normal\" + \"crate_id\": \"intermediate-b\", + \"kind\": \"normal\", + \"req\": \"1.2.3\" }, { \"crate_id\": \"leaf-alice\", - \"kind\": \"normal\" + \"kind\": \"normal\", + \"req\": \"0.7.5\" }, { \"crate_id\": \"leaf-bob\", - \"kind\": \"normal\" + \"kind\": \"normal\", + \"req\": \"^3\" } ] }") -(define test-intermediate-2-crate +(define test-intermediate-b-crate "{ \"crate\": { - \"max_version\": \"1.0.0\", - \"name\": \"intermediate-2\", + \"max_version\": \"1.2.3\", + \"name\": \"intermediate-b\", \"description\": \"summary\", \"homepage\": \"http://example.com\", \"repository\": \"http://example.com\", - \"keywords\": [\"dummy\" \"test\"], - \"categories\": [\"test\"] + \"keywords\": [\"dummy\", \"test\"], + \"categories\": [\"test\"], \"actual_versions\": [ - { \"id\": \"intermediate-2\", - \"num\": \"1.0.0\", + { \"id\": 234260, + \"num\": \"1.2.3\", \"license\": \"MIT OR Apache-2.0\", \"links\": { - \"dependencies\": \"/api/v1/crates/intermediate-2/1.0.0/dependencies\" + \"dependencies\": \"/api/v1/crates/intermediate-b/1.2.3/dependencies\" } } ] } }") -(define test-intermediate-2-dependencies +(define test-intermediate-b-dependencies "{ \"dependencies\": [ { \"crate_id\": \"leaf-bob\", - \"kind\": \"normal\" + \"kind\": \"normal\", + \"req\": \"3.0.1\" } ] }") @@ -179,19 +255,26 @@ (define test-leaf-alice-crate "{ \"crate\": { - \"max_version\": \"1.0.0\", + \"max_version\": \"0.7.5\", \"name\": \"leaf-alice\", \"description\": \"summary\", \"homepage\": \"http://example.com\", \"repository\": \"http://example.com\", - \"keywords\": [\"dummy\" \"test\"], - \"categories\": [\"test\"] + \"keywords\": [\"dummy\", \"test\"], + \"categories\": [\"test\"], \"actual_versions\": [ - { \"id\": \"leaf-alice\", - \"num\": \"1.0.0\", + { \"id\": 234270, + \"num\": \"0.7.3\", \"license\": \"MIT OR Apache-2.0\", \"links\": { - \"dependencies\": \"/api/v1/crates/leaf-alice/1.0.0/dependencies\" + \"dependencies\": \"/api/v1/crates/leaf-alice/0.7.3/dependencies\" + } + }, + { \"id\": 234272, + \"num\": \"0.7.5\", + \"license\": \"MIT OR Apache-2.0\", + \"links\": { + \"dependencies\": \"/api/v1/crates/leaf-alice/0.7.5/dependencies\" } } ] @@ -206,19 +289,19 @@ (define test-leaf-bob-crate "{ \"crate\": { - \"max_version\": \"1.0.0\", + \"max_version\": \"3.0.1\", \"name\": \"leaf-bob\", \"description\": \"summary\", \"homepage\": \"http://example.com\", \"repository\": \"http://example.com\", - \"keywords\": [\"dummy\" \"test\"], + \"keywords\": [\"dummy\", \"test\"], \"categories\": [\"test\"] \"actual_versions\": [ - { \"id\": \"leaf-bob\", - \"num\": \"1.0.0\", + { \"id\": 234280, + \"num\": \"3.0.1\", \"license\": \"MIT OR Apache-2.0\", \"links\": { - \"dependencies\": \"/api/v1/crates/leaf-bob/1.0.0/dependencies\" + \"dependencies\": \"/api/v1/crates/leaf-bob/3.0.1/dependencies\" } } ] @@ -230,9 +313,13 @@ \"dependencies\": [] }") + (define test-source-hash "") +(define have-guile-semver? + (false-if-exception (resolve-interface '(semver)))) + (test-begin "crate") @@ -242,8 +329,9 @@ (dummy-package "rust-rustc-serialize" (source (dummy-origin - (uri (crate-uri "rustc-serialize" "1.0"))))))) + (uri (crate-uri "rustc-serialize" "1.0"))))))) +(unless have-guile-semver? (test-skip 1)) (test-assert "crate->guix-package" ;; Replace network resources with sample data. (mock ((guix http-client) http-fetch @@ -251,37 +339,52 @@ (match url ("https://crates.io/api/v1/crates/foo" (open-input-string test-foo-crate)) - ("https://crates.io/api/v1/crates/foo/1.0.0/download" + ("https://crates.io/api/v1/crates/foo/1.0.3/download" (set! test-source-hash - (bytevector->nix-base32-string - (sha256 (string->bytevector "empty file\n" "utf-8")))) + (bytevector->nix-base32-string + (sha256 (string->bytevector "empty file\n" "utf-8")))) (open-input-string "empty file\n")) - ("https://crates.io/api/v1/crates/foo/1.0.0/dependencies" + ("https://crates.io/api/v1/crates/foo/1.0.3/dependencies" (open-input-string test-foo-dependencies)) + ("https://crates.io/api/v1/crates/leaf-alice" + (open-input-string test-leaf-alice-crate)) + ("https://crates.io/api/v1/crates/leaf-alice/0.7.5/download" + (set! test-source-hash + (bytevector->nix-base32-string + (sha256 (string->bytevector "empty file\n" "utf-8")))) + (open-input-string "empty file\n")) + ("https://crates.io/api/v1/crates/leaf-alice/0.7.5/dependencies" + (open-input-string test-leaf-alice-dependencies)) (_ (error "Unexpected URL: " url))))) - (match (crate->guix-package "foo") - (('package - ('name "rust-foo") - ('version "1.0.0") - ('source ('origin - ('method 'url-fetch) - ('uri ('crate-uri "foo" 'version)) - ('file-name ('string-append 'name "-" 'version ".tar.gz")) - ('sha256 - ('base32 - (? string? hash))))) - ('build-system 'cargo-build-system) - ('arguments - ('quasiquote - ('#:cargo-inputs (("rust-bar" ('unquote rust-bar)))))) - ('home-page "http://example.com") - ('synopsis "summary") - ('description "summary") - ('license ('list 'license:expat 'license:asl2.0))) - (string=? test-source-hash hash)) - (x - (pk 'fail x #f))))) + (match (crate->guix-package "foo") + ((define-public 'rust-foo-1 + (package (name "rust-foo") + (version "1.0.3") + (source + (origin + (method url-fetch) + (uri (crate-uri "foo" 'version)) + (file-name (string-append name "-" version ".tar.gz")) + (sha256 + (base32 + (? string? hash))))) + (build-system 'cargo-build-system) + (arguments + ('quasiquote + (#:skip-build? #t + #:cargo-inputs + (("rust-leaf-alice" ('unquote 'rust-leaf-alice-0.7)))))) + (home-page "http://example.com") + (synopsis "summary") + (description "summary") + (license (list license:expat license:asl2.0)))) + + (string=? test-source-hash hash)) + (x + (pk 'fail x #f))))) + +(unless have-guile-semver? (test-skip 1)) (test-assert "cargo-recursive-import" ;; Replace network resources with sample data. (mock ((guix http-client) http-fetch @@ -289,151 +392,169 @@ (match url ("https://crates.io/api/v1/crates/root" (open-input-string test-root-crate)) - ("https://crates.io/api/v1/crates/root/1.0.0/download" + ("https://crates.io/api/v1/crates/root/1.0.4/download" (set! test-source-hash (bytevector->nix-base32-string (sha256 (string->bytevector "empty file\n" "utf-8")))) (open-input-string "empty file\n")) - ("https://crates.io/api/v1/crates/root/1.0.0/dependencies" + ("https://crates.io/api/v1/crates/root/1.0.4/dependencies" (open-input-string test-root-dependencies)) - ("https://crates.io/api/v1/crates/intermediate-1" - (open-input-string test-intermediate-1-crate)) - ("https://crates.io/api/v1/crates/intermediate-1/1.0.0/download" + ("https://crates.io/api/v1/crates/intermediate-a" + (open-input-string test-intermediate-a-crate)) + ("https://crates.io/api/v1/crates/intermediate-a/1.0.42/download" (set! test-source-hash (bytevector->nix-base32-string (sha256 (string->bytevector "empty file\n" "utf-8")))) (open-input-string "empty file\n")) - ("https://crates.io/api/v1/crates/intermediate-1/1.0.0/dependencies" - (open-input-string test-intermediate-1-dependencies)) - ("https://crates.io/api/v1/crates/intermediate-2" - (open-input-string test-intermediate-2-crate)) - ("https://crates.io/api/v1/crates/intermediate-2/1.0.0/download" + ("https://crates.io/api/v1/crates/intermediate-a/1.0.42/dependencies" + (open-input-string test-intermediate-a-dependencies)) + ("https://crates.io/api/v1/crates/intermediate-b" + (open-input-string test-intermediate-b-crate)) + ("https://crates.io/api/v1/crates/intermediate-b/1.2.3/download" (set! test-source-hash (bytevector->nix-base32-string (sha256 (string->bytevector "empty file\n" "utf-8")))) (open-input-string "empty file\n")) - ("https://crates.io/api/v1/crates/intermediate-2/1.0.0/dependencies" - (open-input-string test-intermediate-2-dependencies)) + ("https://crates.io/api/v1/crates/intermediate-b/1.2.3/dependencies" + (open-input-string test-intermediate-b-dependencies)) ("https://crates.io/api/v1/crates/leaf-alice" (open-input-string test-leaf-alice-crate)) - ("https://crates.io/api/v1/crates/leaf-alice/1.0.0/download" + ("https://crates.io/api/v1/crates/leaf-alice/0.7.5/download" (set! test-source-hash (bytevector->nix-base32-string (sha256 (string->bytevector "empty file\n" "utf-8")))) (open-input-string "empty file\n")) - ("https://crates.io/api/v1/crates/leaf-alice/1.0.0/dependencies" + ("https://crates.io/api/v1/crates/leaf-alice/0.7.5/dependencies" (open-input-string test-leaf-alice-dependencies)) ("https://crates.io/api/v1/crates/leaf-bob" (open-input-string test-leaf-bob-crate)) - ("https://crates.io/api/v1/crates/leaf-bob/1.0.0/download" + ("https://crates.io/api/v1/crates/leaf-bob/3.0.1/download" (set! test-source-hash (bytevector->nix-base32-string (sha256 (string->bytevector "empty file\n" "utf-8")))) (open-input-string "empty file\n")) - ("https://crates.io/api/v1/crates/leaf-bob/1.0.0/dependencies" + ("https://crates.io/api/v1/crates/leaf-bob/3.0.1/dependencies" (open-input-string test-leaf-bob-dependencies)) (_ (error "Unexpected URL: " url))))) (match (crate-recursive-import "root") - ;; rust-intermediate-2 has no dependency on the rust-leaf-alice package, so this is a valid ordering - ((('package - ('name "rust-leaf-alice") - ('version (? string? ver)) - ('source - ('origin - ('method 'url-fetch) - ('uri ('crate-uri "leaf-alice" 'version)) - ('file-name - ('string-append 'name "-" 'version ".tar.gz")) - ('sha256 - ('base32 - (? string? hash))))) - ('build-system 'cargo-build-system) - ('home-page "http://example.com") - ('synopsis "summary") - ('description "summary") - ('license ('list 'license:expat 'license:asl2.0))) - ('package - ('name "rust-leaf-bob") - ('version (? string? ver)) - ('source - ('origin - ('method 'url-fetch) - ('uri ('crate-uri "leaf-bob" 'version)) - ('file-name - ('string-append 'name "-" 'version ".tar.gz")) - ('sha256 - ('base32 - (? string? hash))))) - ('build-system 'cargo-build-system) - ('home-page "http://example.com") - ('synopsis "summary") - ('description "summary") - ('license ('list 'license:expat 'license:asl2.0))) - ('package - ('name "rust-intermediate-2") - ('version (? string? ver)) - ('source - ('origin - ('method 'url-fetch) - ('uri ('crate-uri "intermediate-2" 'version)) - ('file-name - ('string-append 'name "-" 'version ".tar.gz")) - ('sha256 - ('base32 - (? string? hash))))) - ('build-system 'cargo-build-system) - ('arguments - ('quasiquote - ('#:cargo-inputs (("rust-leaf-bob" ('unquote rust-leaf-bob)))))) - ('home-page "http://example.com") - ('synopsis "summary") - ('description "summary") - ('license ('list 'license:expat 'license:asl2.0))) - ('package - ('name "rust-intermediate-1") - ('version (? string? ver)) - ('source - ('origin - ('method 'url-fetch) - ('uri ('crate-uri "intermediate-1" 'version)) - ('file-name - ('string-append 'name "-" 'version ".tar.gz")) - ('sha256 - ('base32 - (? string? hash))))) - ('build-system 'cargo-build-system) - ('arguments - ('quasiquote - ('#:cargo-inputs (("rust-intermediate-2" ('unquote rust-intermediate-2)) - ("rust-leaf-alice" ('unquote rust-leaf-alice)) - ("rust-leaf-bob" ('unquote rust-leaf-bob)))))) - ('home-page "http://example.com") - ('synopsis "summary") - ('description "summary") - ('license ('list 'license:expat 'license:asl2.0))) - ('package - ('name "rust-root") - ('version (? string? ver)) - ('source - ('origin - ('method 'url-fetch) - ('uri ('crate-uri "root" 'version)) - ('file-name - ('string-append 'name "-" 'version ".tar.gz")) - ('sha256 - ('base32 - (? string? hash))))) - ('build-system 'cargo-build-system) - ('arguments - ('quasiquote - ('#:cargo-inputs (("rust-intermediate-1" ('unquote rust-intermediate-1)) - ("rust-intermediate-2" ('unquote rust-intermediate-2)) - ("rust-leaf-alice" ('unquote rust-leaf-alice)) - ("rust-leaf-bob" ('unquote rust-leaf-bob)))))) - ('home-page "http://example.com") - ('synopsis "summary") - ('description "summary") - ('license ('list 'license:expat 'license:asl2.0)))) + ;; rust-intermediate-b has no dependency on the rust-leaf-alice + ;; package, so this is a valid ordering + (((define-public 'rust-leaf-alice-0.7 + (package + (name "rust-leaf-alice") + (version "0.7.5") + (source + (origin + (method url-fetch) + (uri (crate-uri "leaf-alice" version)) + (file-name + (string-append name "-" version ".tar.gz")) + (sha256 + (base32 + (? string? hash))))) + (build-system cargo-build-system) + (arguments ('quasiquote (#:skip-build? #t))) + (home-page "http://example.com") + (synopsis "summary") + (description "summary") + (license (list license:expat license:asl2.0)))) + (define-public 'rust-leaf-bob-3 + (package + (name "rust-leaf-bob") + (version "3.0.1") + (source + (origin + (method url-fetch) + (uri (crate-uri "leaf-bob" version)) + (file-name + (string-append name "-" version ".tar.gz")) + (sha256 + (base32 + (? string? hash))))) + (build-system cargo-build-system) + (arguments ('quasiquote (#:skip-build? #t))) + (home-page "http://example.com") + (synopsis "summary") + (description "summary") + (license (list license:expat license:asl2.0)))) + (define-public 'rust-intermediate-b-1 + (package + (name "rust-intermediate-b") + (version "1.2.3") + (source + (origin + (method url-fetch) + (uri (crate-uri "intermediate-b" version)) + (file-name + (string-append name "-" version ".tar.gz")) + (sha256 + (base32 + (? string? hash))))) + (build-system cargo-build-system) + (arguments + ('quasiquote (#:skip-build? #t + #:cargo-inputs + (("rust-leaf-bob" + ('unquote rust-leaf-bob-3)))))) + (home-page "http://example.com") + (synopsis "summary") + (description "summary") + (license (list license:expat license:asl2.0)))) + (define-public 'rust-intermediate-a-1 + (package + (name "rust-intermediate-a") + (version "1.0.42") + (source + (origin + (method url-fetch) + (uri (crate-uri "intermediate-a" version)) + (file-name + (string-append name "-" version ".tar.gz")) + (sha256 + (base32 + (? string? hash))))) + (build-system cargo-build-system) + (arguments + ('quasiquote (#:skip-build? #t + #:cargo-inputs + (("rust-intermediate-b" + ('unquote rust-intermediate-b-1)) + ("rust-leaf-alice" + ('unquote 'rust-leaf-alice-0.7)) + ("rust-leaf-bob" + ('unquote rust-leaf-bob-3)))))) + (home-page "http://example.com") + (synopsis "summary") + (description "summary") + (license (list license:expat license:asl2.0)))) + (define-public 'rust-root-1 + (package + (name "rust-root") + (version "1.0.4") + (source + (origin + (method url-fetch) + (uri (crate-uri "root" version)) + (file-name + (string-append name "-" version ".tar.gz")) + (sha256 + (base32 + (? string? hash))))) + (build-system cargo-build-system) + (arguments + ('quasiquote (#:cargo-inputs + (("rust-intermediate-a" + ('unquote rust-intermediate-a-1)) + ("rust-intermediate-b" + ('unquote rust-intermediate-b-1)) + ("rust-leaf-alice" + ('unquote 'rust-leaf-alice-0.7)) + ("rust-leaf-bob" + ('unquote rust-leaf-bob-3)))))) + (home-page "http://example.com") + (synopsis "summary") + (description "summary") + (license (list license:expat license:asl2.0))))) #t) (x (pk 'fail x #f))))) @@ -458,4 +579,86 @@ '(license:expat license:asl2.0) (string->license "MIT/Apache-2.0")) + + +(define test-doctool-crate + "{ + \"crate\": { + \"max_version\": \"2.2.2\", + \"name\": \"leaf-bob\", + \"description\": \"summary\", + \"homepage\": \"http://example.com\", + \"repository\": \"http://example.com\", + \"keywords\": [\"dummy\", \"test\"], + \"categories\": [\"test\"] + \"actual_versions\": [ + { \"id\": 234280, + \"num\": \"2.2.2\", + \"license\": \"MIT OR Apache-2.0\", + \"links\": { + \"dependencies\": \"/api/v1/crates/doctool/2.2.2/dependencies\" + } + } + ] + } +}") + +;; FIXME: This test depends on some existing packages +(define test-doctool-dependencies + "{ + \"dependencies\": [ + { + \"crate_id\": \"docopt\", + \"kind\": \"normal\", + \"req\": \"^0.8.1\" + } + ] +}") + + +(test-assert "self-test: rust-docopt 0.8.x is gone, please adjust the test case" + (not (null? (find-packages-by-name "rust-docopt" "0.8")))) + +(unless have-guile-semver? (test-skip 1)) +(test-assert "cargo-recursive-import-hoors-existing-packages" + (mock ((guix http-client) http-fetch + (lambda (url . rest) + (match url + ("https://crates.io/api/v1/crates/doctool" + (open-input-string test-doctool-crate)) + ("https://crates.io/api/v1/crates/doctool/2.2.2/download" + (set! test-source-hash + (bytevector->nix-base32-string + (sha256 (string->bytevector "empty file\n" "utf-8")))) + (open-input-string "empty file\n")) + ("https://crates.io/api/v1/crates/doctool/2.2.2/dependencies" + (open-input-string test-doctool-dependencies)) + (_ (error "Unexpected URL: " url))))) + (match (crate-recursive-import "doctool") + (((define-public 'rust-doctool-2 + (package + (name "rust-doctool") + (version "2.2.2") + (source + (origin + (method url-fetch) + (uri (crate-uri "doctool" version)) + (file-name + (string-append name "-" version ".tar.gz")) + (sha256 + (base32 + (? string? hash))))) + (build-system cargo-build-system) + (arguments + ('quasiquote (#:cargo-inputs + (("rust-docopt" + ('unquote 'rust-docopt-0.8)))))) + (home-page "http://example.com") + (synopsis "summary") + (description "summary") + (license (list license:expat license:asl2.0))))) + #t) + (x + (pk 'fail x #f))))) + (test-end "crate") diff --git a/tests/cve-sample.json b/tests/cve-sample.json index 39816f9dd4..11b71817bb 100644 --- a/tests/cve-sample.json +++ b/tests/cve-sample.json @@ -49,7 +49,7 @@ "vulnerable" : true, "cpe23Uri" : "cpe:2.3:o:juniper:junos:16.1:*:*:*:*:*:*:*" } ] - } { + }, { "operator" : "OR", "cpe_match" : [ { "vulnerable" : true, diff --git a/tests/elpa.scm b/tests/elpa.scm index b70539bda6..a008cf993c 100644 --- a/tests/elpa.scm +++ b/tests/elpa.scm @@ -1,6 +1,7 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2015 Federico Beffa <beffa@fbengineering.ch> ;;; Copyright © 2020 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2020 Martin Becze <mjbecze@riseup.net> ;;; ;;; This file is part of GNU Guix. ;;; @@ -51,7 +52,7 @@ (200 "This is the description.") (200 "fake tarball contents")) (parameterize ((current-http-proxy (%local-url))) - (match (elpa->guix-package pkg 'gnu/http) + (match (elpa->guix-package pkg #:repo 'gnu/http) (('package ('name "emacs-auctex") ('version "11.88.6") diff --git a/tests/gexp.scm b/tests/gexp.scm index 686334af61..6e92f0e4b3 100644 --- a/tests/gexp.scm +++ b/tests/gexp.scm @@ -723,10 +723,26 @@ (lambda (port) (display "This is the second one." port)))))) (build-drv #~(begin - (use-modules (guix build store-copy)) + (use-modules (guix build store-copy) + (guix build utils) + (srfi srfi-1)) + + (define (canonical-file? file) + ;; Copied from (guix tests). + (let ((st (lstat file))) + (or (not (string-prefix? (%store-directory) file)) + (eq? 'symlink (stat:type st)) + (and (= 1 (stat:mtime st)) + (zero? (logand #o222 (stat:mode st))))))) (mkdir #$output) - (populate-store '("graph") #$output)))) + (populate-store '("graph") #$output + #:deduplicate? #f) + + ;; Check whether 'populate-store' canonicalizes + ;; permissions and timestamps. + (unless (every canonical-file? (find-files #$output)) + (error "not canonical!" #$output))))) (mlet* %store-monad ((one (gexp->derivation "one" build-one)) (two (gexp->derivation "two" (build-two one))) (drv (gexp->derivation "store-copy" build-drv diff --git a/tests/glob.scm b/tests/glob.scm index 3134069789..2a5a40c3c6 100644 --- a/tests/glob.scm +++ b/tests/glob.scm @@ -1,5 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2018 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2020 Giacomo Leidi <goodoldpaul@autistici.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -53,7 +54,8 @@ "foo[abc]bar" => '("foo" (set #\a #\b #\c) "bar") "foo[a[b]c]bar" => '("foo" (set #\a #\[ #\b #\] #\c) "bar") "[123]x" => '((set #\1 #\2 #\3) "x") - "[a-z]" => '((range #\a #\z))) + "[a-z]" => '((range #\a #\z)) + "**/*.scm" => '(**/ * ".scm")) (test-glob-match ("foo" matches "foo" (and not "foobar" "barfoo")) @@ -64,6 +66,8 @@ ("ab[0-9]c" matches "ab0c" "ab7c" "ab9c" (and not "ab-c" "ab00c" "ab3")) ("ab[cdefg]" matches "abc" "abd" "abg" - (and not "abh" "abcd" "ab["))) + (and not "abh" "abcd" "ab[")) + ("foo/**/*.scm" matches "foo/bar/baz.scm" "foo/bar.scm" "foo/bar/baz/zab.scm" + (and not "foo/bar/baz.java" "foo/bar.smc"))) (test-end "glob") diff --git a/tests/guix-archive.sh b/tests/guix-archive.sh index e796c62f9a..00b87ff0ac 100644 --- a/tests/guix-archive.sh +++ b/tests/guix-archive.sh @@ -1,5 +1,5 @@ # GNU Guix --- Functional package management for GNU -# Copyright © 2013, 2014, 2015, 2019 Ludovic Courtès <ludo@gnu.org> +# Copyright © 2013, 2014, 2015, 2019, 2020 Ludovic Courtès <ludo@gnu.org> # # This file is part of GNU Guix. # @@ -28,7 +28,7 @@ tmpdir="t-archive-dir-$$" rm -f "$archive" "$archive_alt" rm -rf "$tmpdir" -trap 'rm -f "$archive" "$archive_alt"; rm -rf "$tmpdir"' EXIT +trap 'rm -f "$archive" "$archive_alt"; chmod -R +w "$tmpdir"; rm -rf "$tmpdir"' EXIT guix archive --export guile-bootstrap > "$archive" guix archive --export guile-bootstrap:out > "$archive_alt" diff --git a/tests/guix-hash.sh b/tests/guix-hash.sh index 346355539f..c4461fa955 100644 --- a/tests/guix-hash.sh +++ b/tests/guix-hash.sh @@ -1,5 +1,5 @@ # GNU Guix --- Functional package management for GNU -# Copyright © 2013, 2014, 2016, 2020 Ludovic Courtès <ludo@gnu.org> +# Copyright © 2013, 2014, 2016, 2020, 2021 Ludovic Courtès <ludo@gnu.org> # Copyright © 2016 Jan Nieuwenhuizen <janneke@gnu.org> # # This file is part of GNU Guix. @@ -43,6 +43,7 @@ chmod +x "$tmpdir/exe" mkdir "$tmpdir/subdir" test `guix hash -r "$tmpdir"` = 10k1lw41wyrjf9mxydi0is5nkpynlsvgslinics4ppir13g7d74p +test `guix hash -r "$tmpdir" -H sha512` = 301ra58c2vahczzxiyfin41mpyb0ljh4dh9zn3ijvwviaw1j40sfzw5skh9x945da88n3785ggifzig7acd6k72h0mpsc20m1f66m9n # Without '-r', this should fail. ! guix hash "$tmpdir" diff --git a/tests/guix-pack-relocatable.sh b/tests/guix-pack-relocatable.sh index 2beb1b1eb6..b90bc7f891 100644 --- a/tests/guix-pack-relocatable.sh +++ b/tests/guix-pack-relocatable.sh @@ -55,7 +55,7 @@ run_without_store () # Run the relocatable program in the current namespaces. This is a # weak test because we're going to access store items from the host # store. - $* + sh -c "$*" fi } diff --git a/tests/import-utils.scm b/tests/import-utils.scm index 87dda3238f..874816442e 100644 --- a/tests/import-utils.scm +++ b/tests/import-utils.scm @@ -1,6 +1,7 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2015, 2017 Ricardo Wurmus <rekado@elephly.net> ;;; Copyright © 2016 Ben Woodcroft <donttrustben@gmail.com> +;;; Copyright © 2020 Martin Becze <mjbecze@riseup.net> ;;; ;;; This file is part of GNU Guix. ;;; @@ -48,15 +49,16 @@ (package (name "foo") (inputs `(("bar" ,bar))))) - (recursive-import "foo" 'repo + (recursive-import "foo" + #:repo 'repo #:repo->guix-package (match-lambda* - (("foo" 'repo) + (("foo" #:version #f #:repo 'repo) (values '(package (name "foo") (inputs `(("bar" ,bar)))) '("bar"))) - (("bar" 'repo) + (("bar" #:version #f #:repo 'repo) (values '(package (name "bar")) '()))) @@ -120,6 +122,38 @@ (or (package-license (alist->package meta)) 'license-is-false))) +(test-equal "alist->package with SPDX license name 1/2" ;<https://bugs.gnu.org/45453> + license:expat + (let* ((meta '(("name" . "hello") + ("version" . "2.10") + ("source" . (("method" . "url-fetch") + ("uri" . "mirror://gnu/hello/hello-2.10.tar.gz") + ("sha256" . + (("base32" . + "0ssi1wpaf7plaswqqjwigppsg5fyh99vdlb9kzl7c9lng89ndq1i"))))) + ("build-system" . "gnu") + ("home-page" . "https://gnu.org") + ("synopsis" . "Say hi") + ("description" . "This package says hi.") + ("license" . "expat")))) + (package-license (alist->package meta)))) + +(test-equal "alist->package with SPDX license name 2/2" ;<https://bugs.gnu.org/45453> + license:expat + (let* ((meta '(("name" . "hello") + ("version" . "2.10") + ("source" . (("method" . "url-fetch") + ("uri" . "mirror://gnu/hello/hello-2.10.tar.gz") + ("sha256" . + (("base32" . + "0ssi1wpaf7plaswqqjwigppsg5fyh99vdlb9kzl7c9lng89ndq1i"))))) + ("build-system" . "gnu") + ("home-page" . "https://gnu.org") + ("synopsis" . "Say hi") + ("description" . "This package says hi.") + ("license" . "MIT")))) + (package-license (alist->package meta)))) + (test-equal "alist->package with dependencies" `(("gettext" ,(specification->package "gettext"))) (let* ((meta '(("name" . "hello") diff --git a/tests/lint.scm b/tests/lint.scm index 9b230814a5..7c24611934 100644 --- a/tests/lint.scm +++ b/tests/lint.scm @@ -315,7 +315,7 @@ `(("python-setuptools" ,python-setuptools)))))) (check-inputs-should-not-be-an-input-at-all pkg)))) -(test-equal "patches: file names" +(test-equal "file patches: different file name -> warning" "file names of patches should start with the package name" (single-lint-warning-message (let ((pkg (dummy-package "x" @@ -324,6 +324,37 @@ (patches (list "/path/to/y.patch"))))))) (check-patch-file-names pkg)))) +(test-equal "file patches: same file name -> no warnings" + '() + (let ((pkg (dummy-package "x" + (source + (dummy-origin + (patches (list "/path/to/x.patch"))))))) + (check-patch-file-names pkg))) + +(test-equal "<origin> patches: different file name -> warning" + "file names of patches should start with the package name" + (single-lint-warning-message + (let ((pkg (dummy-package "x" + (source + (dummy-origin + (patches + (list + (dummy-origin + (file-name "y.patch"))))))))) + (check-patch-file-names pkg)))) + +(test-equal "<origin> patches: same file name -> no warnings" + '() + (let ((pkg (dummy-package "x" + (source + (dummy-origin + (patches + (list + (dummy-origin + (file-name "x.patch"))))))))) + (check-patch-file-names pkg))) + (test-equal "patches: file name too long" (string-append "x-" (make-string 100 #\a) diff --git a/tests/nar.scm b/tests/nar.scm index aeff3d3330..ba4881caaa 100644 --- a/tests/nar.scm +++ b/tests/nar.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -136,8 +136,11 @@ (define (rm-rf dir) (file-system-fold (const #t) ; enter? (lambda (file stat result) ; leaf + (unless (eq? 'symlink (stat:type stat)) + (chmod file #o644)) (delete-file file)) - (const #t) ; down + (lambda (dir stat result) ; down + (chmod dir #o755)) (lambda (dir stat result) ; up (rmdir dir)) (const #t) ; skip @@ -218,8 +221,10 @@ '(("R" directory #f) ("R/dir" directory #f) ("R/dir/exe" executable "1234") + ("R/dir" directory-complete #f) ("R/foo" regular "abcdefg") - ("R/lnk" symlink "foo")) + ("R/lnk" symlink "foo") + ("R" directory-complete #f)) (let () (define-values (port get-bytevector) @@ -361,7 +366,12 @@ (cut write-file input <>)) (call-with-input-file nar (cut restore-file <> output)) - (file-tree-equal? input output)) + + (and (file-tree-equal? input output) + (every (lambda (file) + (canonical-file? + (string-append output "/" file))) + '("root" "root/reg" "root/exe")))) (lambda () (false-if-exception (delete-file nar)) (false-if-exception (rm-rf output))))))) @@ -442,6 +452,9 @@ (false-if-exception (rm-rf %test-dir)) (setlocale LC_ALL locale))))) +;; XXX: Tell the 'deduplicate' procedure what store we're actually using. +(setenv "NIX_STORE" (%store-prefix)) + (test-assert "restore-file-set (signed, valid)" (with-store store (let* ((texts (unfold (cut >= <> 10) diff --git a/tests/opam.scm b/tests/opam.scm index ec2a668307..11984b56a6 100644 --- a/tests/opam.scm +++ b/tests/opam.scm @@ -80,38 +80,41 @@ url { (set! test-source-hash (call-with-input-file file-name port-sha256)))) (_ (error "Unexpected URL: " url))))) - (let ((my-package (string-append test-repo "/packages/foo/foo.1.0.0"))) - (mkdir-p my-package) - (with-output-to-file (string-append my-package "/opam") - (lambda _ - (format #t "~a" test-opam-file)))) - (match (opam->guix-package "foo" #:repository test-repo) - (('package - ('name "ocaml-foo") - ('version "1.0.0") - ('source ('origin - ('method 'url-fetch) - ('uri "https://example.org/foo-1.0.0.tar.gz") - ('sha256 - ('base32 - (? string? hash))))) - ('build-system 'ocaml-build-system) - ('propagated-inputs - ('quasiquote - (("ocaml-zarith" ('unquote 'ocaml-zarith))))) - ('native-inputs - ('quasiquote - (("ocaml-alcotest" ('unquote 'ocaml-alcotest)) - ("ocamlbuild" ('unquote 'ocamlbuild))))) - ('home-page "https://example.org/") - ('synopsis "Some example package") - ('description "This package is just an example.") - ('license #f)) - (string=? (bytevector->nix-base32-string - test-source-hash) - hash)) - (x - (pk 'fail x #f))))) + (mock ((guix import opam) get-opam-repository + (const test-repo)) + (let ((my-package (string-append test-repo + "/packages/foo/foo.1.0.0"))) + (mkdir-p my-package) + (with-output-to-file (string-append my-package "/opam") + (lambda _ + (format #t "~a" test-opam-file)))) + (match (opam->guix-package "foo" #:repo test-repo) + (('package + ('name "ocaml-foo") + ('version "1.0.0") + ('source ('origin + ('method 'url-fetch) + ('uri "https://example.org/foo-1.0.0.tar.gz") + ('sha256 + ('base32 + (? string? hash))))) + ('build-system 'ocaml-build-system) + ('propagated-inputs + ('quasiquote + (("ocaml-zarith" ('unquote 'ocaml-zarith))))) + ('native-inputs + ('quasiquote + (("ocaml-alcotest" ('unquote 'ocaml-alcotest)) + ("ocamlbuild" ('unquote 'ocamlbuild))))) + ('home-page "https://example.org/") + ('synopsis "Some example package") + ('description "This package is just an example.") + ('license #f)) + (string=? (bytevector->nix-base32-string + test-source-hash) + hash)) + (x + (pk 'fail x #f)))))) ;; Test the opam file parser ;; We fold over some test cases. Each case is a pair of the string to parse and the diff --git a/tests/profiles.scm b/tests/profiles.scm index 055924ba3e..2dec42bec1 100644 --- a/tests/profiles.scm +++ b/tests/profiles.scm @@ -183,6 +183,16 @@ (equal? (list glibc) install) (equal? (list (cons guile-1.8.8 guile-2.0.9)) upgrade))))) +(test-assert "manifest-transaction-effects no double install or upgrades" + (let* ((m0 (manifest (list guile-1.8.8))) + (t (manifest-transaction + (install (list guile-2.0.9 glibc glibc))))) + (let-values (((remove install upgrade downgrade) + (manifest-transaction-effects m0 t))) + (and (null? remove) (null? downgrade) + (equal? (list glibc) install) + (equal? (list (cons guile-1.8.8 guile-2.0.9)) upgrade))))) + (test-assert "manifest-transaction-effects and downgrades" (let* ((m0 (manifest (list guile-2.0.9))) (t (manifest-transaction (install (list guile-1.8.8))))) @@ -191,6 +201,14 @@ (and (null? remove) (null? install) (null? upgrade) (equal? (list (cons guile-2.0.9 guile-1.8.8)) downgrade))))) +(test-assert "manifest-transaction-effects no double downgrade" + (let* ((m0 (manifest (list guile-2.0.9))) + (t (manifest-transaction (install (list guile-1.8.8 guile-1.8.8))))) + (let-values (((remove install upgrade downgrade) + (manifest-transaction-effects m0 t))) + (and (null? remove) (null? install) (null? upgrade) + (equal? (list (cons guile-2.0.9 guile-1.8.8)) downgrade))))) + (test-assert "manifest-transaction-effects and pseudo-upgrades" (let* ((m0 (manifest (list guile-2.0.9))) (t (manifest-transaction (install (list guile-2.0.9))))) @@ -209,6 +227,16 @@ (and (manifest-transaction-removal-candidate? guile-2.0.9 t) (not (manifest-transaction-removal-candidate? glibc t))))) +(test-assert "manifest-transaction-effects no double removal" + (let* ((m0 (manifest (list guile-2.0.9))) + (t (manifest-transaction + (remove (list (manifest-pattern (name "guile"))))))) + (let-values (((remove install upgrade downgrade) + (manifest-transaction-effects m0 t))) + (and (= 1 (length remove)) + (manifest-transaction-removal-candidate? guile-2.0.9 t) + (null? install) (null? downgrade) (null? upgrade))))) + (test-assertm "profile-derivation" (mlet* %store-monad ((entry -> (package->manifest-entry %bootstrap-guile)) @@ -356,6 +384,16 @@ (manifest-entry-search-paths (package->manifest-entry mpl))))) +(test-assert "packages->manifest, no duplicates" + (let ((expected + (manifest + (list + (package->manifest-entry packages:guile-2.2)))) + (manifest (packages->manifest + (list packages:guile-2.2 packages:guile-2.2)))) + (every manifest-entry=? (manifest-entries expected) + (manifest-entries manifest)))) + (test-equal "packages->manifest, propagated inputs" (map (match-lambda ((label package) diff --git a/tests/store-database.scm b/tests/store-database.scm index 3b4ef43f6d..17eea38c63 100644 --- a/tests/store-database.scm +++ b/tests/store-database.scm @@ -20,6 +20,7 @@ #:use-module (guix tests) #:use-module (guix store) #:use-module (guix store database) + #:use-module (guix build store-copy) #:use-module ((guix utils) #:select (call-with-temporary-output-file)) #:use-module ((guix build utils) #:select (mkdir-p delete-file-recursively)) @@ -34,8 +35,7 @@ (test-begin "store-database") -(test-equal "register-path" - '(1 1) +(test-assert "register-items" (let ((file (string-append (%store-prefix) "/" (make-string 32 #\f) "-fake"))) (when (valid-path? %store file) @@ -46,9 +46,9 @@ (drv (string-append file ".drv"))) (call-with-output-file file (cut display "This is a fake store item.\n" <>)) - (register-path file - #:references (list ref) - #:deriver drv) + (reset-timestamps file) + (with-database (store-database-file) db + (register-items db (list (store-info file drv (list ref))))) (and (valid-path? %store file) (equal? (references %store file) (list ref)) @@ -57,7 +57,7 @@ (list (stat:mtime (lstat file)) (stat:mtime (lstat ref))))))) -(test-equal "register-path, directory" +(test-equal "register-items, directory" '(1 1 1) (let ((file (string-append (%store-prefix) "/" (make-string 32 #\f) "-fake-directory"))) @@ -69,7 +69,9 @@ (mkdir-p (string-append file "/a")) (call-with-output-file (string-append file "/a/b") (const #t)) - (register-path file #:deriver drv) + (reset-timestamps file) + (with-database (store-database-file) db + (register-items db (list (store-info file drv '())))) (and (valid-path? %store file) (null? (references %store file)) @@ -101,7 +103,7 @@ (list (path-id db "/gnu/foo") (path-id db "/gnu/bar"))))))) -(test-assert "register-path with unregistered references" +(test-assert "sqlite-register with unregistered references" ;; Make sure we get a "NOT NULL constraint failed: Refs.reference" error ;; when we try to add references that are not registered yet. Better safe ;; than sorry. diff --git a/tests/store-deduplication.scm b/tests/store-deduplication.scm index e2870a363d..b1c2d93bbd 100644 --- a/tests/store-deduplication.scm +++ b/tests/store-deduplication.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2018 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2018, 2020 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -25,6 +25,7 @@ #:use-module (rnrs bytevectors) #:use-module (ice-9 binary-ports) #:use-module (srfi srfi-1) + #:use-module (srfi srfi-26) #:use-module (srfi srfi-64)) (test-begin "store-deduplication") @@ -94,7 +95,7 @@ (lambda () (set! link (lambda (old new) (set! links (+ links 1)) - (if (<= links 3) + (if (<= links 4) (true-link old new) (throw 'system-error "link" "~A" '("Whaaat?!") (list ENOSPC)))))) @@ -106,4 +107,19 @@ (cons (apply = (map (compose stat:ino stat) identical)) (map (compose stat:nlink stat) identical)))))) +(test-assert "copy-file/deduplicate" + (call-with-temporary-directory + (lambda (store) + (let ((source (search-path %load-path "gnu/packages/emacs-xyz.scm"))) + (for-each (lambda (target) + (copy-file/deduplicate source + (string-append store target) + #:store store)) + '("/a" "/b" "/c")) + (and (directory-exists? (string-append store "/.links")) + (file=? source (string-append store "/a")) + (apply = (map (compose stat:ino stat + (cut string-append store <>)) + '("/a" "/b" "/c")))))))) + (test-end "store-deduplication") diff --git a/tests/store.scm b/tests/store.scm index 38051bf5e5..c9a08ac690 100644 --- a/tests/store.scm +++ b/tests/store.scm @@ -715,8 +715,33 @@ #:substitute-urls (%test-substitute-urls)) (and (has-substitutes? s o) (build-derivations s (list d)) + (canonical-file? o) (equal? c (call-with-input-file o get-string-all))))))) +(test-assert "substitute, deduplication" + (with-store s + (let* ((c (random-text)) ; contents of the output + (g (package-derivation s %bootstrap-guile)) + (d1 (build-expression->derivation s "substitute-me" + `(begin ,c (exit 1)) + #:guile-for-build g)) + (d2 (build-expression->derivation s "build-me" + `(call-with-output-file %output + (lambda (p) + (display ,c p))) + #:guile-for-build g)) + (o1 (derivation->output-path d1)) + (o2 (derivation->output-path d2))) + (with-derivation-substitute d1 c + (set-build-options s #:use-substitutes? #t + #:substitute-urls (%test-substitute-urls)) + (and (has-substitutes? s o1) + (build-derivations s (list d2)) ;build + (build-derivations s (list d1)) ;substitute + (canonical-file? o1) + (equal? c (call-with-input-file o1 get-string-all)) + (= (stat:ino (stat o1)) (stat:ino (stat o2)))))))) + (test-assert "substitute + build-things with output path" (with-store s (let* ((c (random-text)) ;contents of the output @@ -735,6 +760,7 @@ (and (has-substitutes? s o) (build-things s (list o)) ;give the output path (valid-path? s o) + (canonical-file? o) (equal? c (call-with-input-file o get-string-all))))))) (test-assert "substitute + build-things with specific output" @@ -755,6 +781,7 @@ (build-things s `((,(derivation-file-name d) . "out"))) (valid-path? s o) + (canonical-file? o) (equal? c (call-with-input-file o get-string-all))))))) (test-assert "substitute, corrupt output hash" @@ -787,6 +814,61 @@ (build-derivations s (list d)) #f)))))) +(test-assert "substitute, corrupt output hash, build trace" + ;; Likewise, and check the build trace. + (with-store s + (let* ((c "hello, world") ; contents of the output + (d (build-expression->derivation + s "corrupt-substitute" + `(mkdir %output) + #:guile-for-build + (package-derivation s %bootstrap-guile (%current-system)))) + (o (derivation->output-path d))) + ;; Make sure we use 'guix substitute'. + (set-build-options s + #:print-build-trace #t + #:use-substitutes? #t + #:fallback? #f + #:substitute-urls (%test-substitute-urls)) + + (with-derivation-substitute d c + (sha256 => (make-bytevector 32 0)) ;select a hash that doesn't match C + + (define output + (call-with-output-string + (lambda (port) + (parameterize ((current-build-output-port port)) + (guard (c ((store-protocol-error? c) #t)) + (build-derivations s (list d)) + #f))))) + + (define actual-hash + (let-values (((port get-hash) + (gcrypt:open-hash-port + (gcrypt:hash-algorithm gcrypt:sha256)))) + (write-file-tree "foo" port + #:file-type+size + (lambda _ + (values 'regular (string-length c))) + #:file-port + (lambda _ + (open-input-string c))) + (close-port port) + (bytevector->nix-base32-string (get-hash)))) + + (define expected-hash + (bytevector->nix-base32-string (make-bytevector 32 0))) + + (define mismatch + (string-append "@ hash-mismatch " o " sha256 " + expected-hash " " actual-hash "\n")) + + (define failure + (string-append "@ substituter-failed " o)) + + (and (string-contains output mismatch) + (string-contains output failure)))))) + (test-assert "substitute --fallback" (with-store s (let* ((t (random-text)) ; contents of the output diff --git a/tests/substitute.scm b/tests/substitute.scm index 6560612c40..542aaf603f 100644 --- a/tests/substitute.scm +++ b/tests/substitute.scm @@ -28,7 +28,9 @@ #: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 utils) + #:select (call-with-temporary-directory + call-with-compressed-output-port)) #:use-module ((guix build utils) #:select (mkdir-p delete-file-recursively dump-port)) #:use-module (guix tests http) @@ -36,6 +38,7 @@ #:use-module (rnrs io ports) #:use-module (web uri) #:use-module (ice-9 regex) + #:use-module (srfi srfi-11) #:use-module (srfi srfi-26) #:use-module (srfi srfi-34) #:use-module (srfi srfi-35) @@ -47,7 +50,8 @@ it writes to GUIX-WARNING-PORT a messages that matches ERROR-RX." (test-equal name '(1 #t) (let ((error-output (open-output-string))) - (parameterize ((guix-warning-port error-output)) + (parameterize ((current-error-port error-output) + (guix-warning-port error-output)) (catch 'quit (lambda () exp @@ -57,6 +61,14 @@ it writes to GUIX-WARNING-PORT a messages that matches ERROR-RX." (let ((message (get-output-string error-output))) (->bool (string-match error-rx message)))))))))) +(define (request-substitution item destination) + "Run 'guix substitute --substitute' to fetch ITEM to DESTINATION." + (parameterize ((guix-warning-port (current-error-port))) + (with-input-from-string (string-append "substitute " item " " + destination "\n") + (lambda () + (guix-substitute "--substitute"))))) + (define %public-key ;; This key is known to be in the ACL by default. (call-with-input-file (string-append %config-directory "/signing-key.pub") @@ -183,6 +195,11 @@ a file for NARINFO." ;; Transmit these options to 'guix substitute'. (substitute-urls (list (getenv "GUIX_BINARY_SUBSTITUTE_URL"))) +;; Never use file descriptor 4, unlike what happens when invoked by the +;; daemon. +(%error-to-file-descriptor-4? #f) + + (test-equal "query narinfo without signature" "" ; not substitutable @@ -283,21 +300,68 @@ System: mips64el-linux\n") (test-quit "substitute, no signature" "no valid substitute" (with-narinfo %narinfo - (guix-substitute "--substitute" - (string-append (%store-prefix) - "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo") - "foo"))) + (with-input-from-string (string-append "substitute " + (%store-prefix) + "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo" + " foo\n") + (lambda () + (guix-substitute "--substitute"))))) -(test-quit "substitute, invalid hash" +(test-quit "substitute, invalid narinfo hash" "no valid substitute" ;; The hash in the signature differs from the hash of %NARINFO. (with-narinfo (string-append %narinfo "Signature: " (signature-field "different body") "\n") - (guix-substitute "--substitute" - (string-append (%store-prefix) - "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo") - "foo"))) + (with-input-from-string (string-append "substitute " + (%store-prefix) + "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo" + " foo\n") + (lambda () + (guix-substitute "--substitute"))))) + +(test-equal "substitute, invalid hash" + (string-append "hash-mismatch sha256 " + (bytevector->nix-base32-string (sha256 #vu8())) " " + (let-values (((port get-hash) + (open-hash-port (hash-algorithm sha256))) + ((content) + "Substitutable data.")) + (write-file-tree "foo" port + #:file-type+size + (lambda _ + (values 'regular + (string-length content))) + #:file-port + (lambda _ + (open-input-string content))) + (close-port port) + (bytevector->nix-base32-string (get-hash))) + "\n") + + ;; Arrange so the actual data hash does not match the 'NarHash' field in the + ;; narinfo. + (with-output-to-string + (lambda () + (let ((narinfo (string-append "StorePath: " (%store-prefix) + "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-wrong-hash +URL: example.nar +Compression: none +NarHash: sha256:" (bytevector->nix-base32-string (sha256 #vu8())) " +NarSize: 42 +References: +Deriver: " (%store-prefix) "/foo.drv +System: mips64el-linux\n"))) + (with-narinfo (string-append narinfo "Signature: " + (signature-field narinfo) "\n") + (call-with-temporary-directory + (lambda (directory) + (with-input-from-string (string-append + "substitute " (%store-prefix) + "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-wrong-hash " + directory "/wrong-hash\n") + (lambda () + (guix-substitute "--substitute")))))))))) (test-quit "substitute, unauthorized key" "no valid substitute" @@ -306,23 +370,26 @@ System: mips64el-linux\n") %narinfo #:public-key %wrong-public-key) "\n") - (guix-substitute "--substitute" - (string-append (%store-prefix) - "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo") - "foo"))) + (with-input-from-string (string-append "substitute " + (%store-prefix) + "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo" + " foo\n") + (lambda () + (guix-substitute "--substitute"))))) (test-equal "substitute, authorized key" - "Substitutable data." + '("Substitutable data." 1 #o444) (with-narinfo (string-append %narinfo "Signature: " (signature-field %narinfo)) (dynamic-wind (const #t) (lambda () - (guix-substitute "--substitute" - (string-append (%store-prefix) - "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo") - "substitute-retrieved") - (call-with-input-file "substitute-retrieved" get-string-all)) + (request-substitution (string-append (%store-prefix) + "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo") + "substitute-retrieved") + (list (call-with-input-file "substitute-retrieved" get-string-all) + (stat:mtime (lstat "substitute-retrieved")) + (stat:perms (lstat "substitute-retrieved")))) (lambda () (false-if-exception (delete-file "substitute-retrieved")))))) @@ -351,10 +418,9 @@ System: mips64el-linux\n") (map (cut string-append "file://" <>) (list %alternate-substitute-directory %main-substitute-directory)))) - (guix-substitute "--substitute" - (string-append (%store-prefix) - "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo") - "substitute-retrieved")) + (request-substitution (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"))))))) @@ -380,10 +446,9 @@ System: mips64el-linux\n") (map (cut string-append "file://" <>) (list %alternate-substitute-directory %main-substitute-directory)))) - (guix-substitute "--substitute" - (string-append (%store-prefix) - "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo") - "substitute-retrieved")) + (request-substitution (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"))))))) @@ -416,10 +481,9 @@ System: mips64el-linux\n") (map (cut string-append "file://" <>) (list %alternate-substitute-directory %main-substitute-directory)))) - (guix-substitute "--substitute" - (string-append (%store-prefix) - "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo") - "substitute-retrieved")) + (request-substitution (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"))))))) @@ -450,10 +514,9 @@ System: mips64el-linux\n") (map (cut string-append "file://" <>) (list %alternate-substitute-directory %main-substitute-directory)))) - (guix-substitute "--substitute" - (string-append (%store-prefix) - "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo") - "substitute-retrieved")) + (request-substitution (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"))))))) @@ -469,10 +532,12 @@ System: mips64el-linux\n") #:public-key %wrong-public-key)) %main-substitute-directory - (guix-substitute "--substitute" - (string-append (%store-prefix) - "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo") - "substitute-retrieved")))) + (with-input-from-string (string-append "substitute " + (%store-prefix) + "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo" + " substitute-retrieved\n") + (lambda () + (guix-substitute "--substitute")))))) (test-equal "substitute, narinfo with several URLs" "Substitutable data." @@ -512,10 +577,9 @@ System: mips64el-linux\n"))) (parameterize ((substitute-urls (list (string-append "file://" %main-substitute-directory)))) - (guix-substitute "--substitute" - (string-append (%store-prefix) - "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo") - "substitute-retrieved")) + (request-substitution (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"))))))) diff --git a/tests/swh.scm b/tests/swh.scm index aef68acbe7..06984b2a80 100644 --- a/tests/swh.scm +++ b/tests/swh.scm @@ -33,7 +33,7 @@ "[ { \"name\": \"one\", \"type\": \"regular\", \"length\": 123, - \"dir_id\": 1 } + \"dir_id\": 1 }, { \"name\": \"two\", \"type\": \"regular\", \"length\": 456, diff --git a/tests/transformations.scm b/tests/transformations.scm index 07ed8b1234..9053deba41 100644 --- a/tests/transformations.scm +++ b/tests/transformations.scm @@ -26,6 +26,7 @@ #:use-module (guix build-system) #:use-module (guix build-system gnu) #:use-module (guix transformations) + #:use-module ((guix gexp) #:select (local-file? local-file-file)) #:use-module (guix ui) #:use-module (guix utils) #:use-module (guix git) @@ -368,10 +369,32 @@ (let ((new (t p))) (match (bag-direct-inputs (package->bag new)) ((("dep" dep) ("tar" tar) _ ...) - ;; TODO: Check whether TAR has #:tests? #f when transformations - ;; apply to implicit inputs. - (equal? (package-arguments dep) - '(#:tests? #f))))))) + (and (equal? (package-arguments dep) '(#:tests? #f)) + (match (memq #:tests? (package-arguments tar)) + ((#:tests? #f _ ...) #t)))))))) + +(test-equal "options->transformation, with-patch" + (search-patches "glibc-locales.patch" "guile-relocatable.patch") + (let* ((dep (dummy-package "dep" + (source (dummy-origin)))) + (p (dummy-package "foo" + (inputs `(("dep" ,dep))))) + (patch1 (search-patch "glibc-locales.patch")) + (patch2 (search-patch "guile-relocatable.patch")) + (t (options->transformation + `((with-patch . ,(string-append "dep=" patch1)) + (with-patch . ,(string-append "dep=" patch2)) + (with-patch . ,(string-append "tar=" patch1)))))) + (let ((new (t p))) + (match (bag-direct-inputs (package->bag new)) + ((("dep" dep) ("tar" tar) _ ...) + (and (member patch1 + (filter-map (lambda (patch) + (and (local-file? patch) + (local-file-file patch))) + (origin-patches (package-source tar)))) + (map local-file-file + (origin-patches (package-source dep))))))))) (test-end) |