X-Git-Url: https://git.hcoop.net/jackhill/guix/guix.git/blobdiff_plain/f363c836e0b4c416dae594af4257459da592b35c..6182897c98e11676b9a370da297a688c311f4cab:/tests/lint.scm diff --git a/tests/lint.scm b/tests/lint.scm index 59be061a99..95abd71378 100644 --- a/tests/lint.scm +++ b/tests/lint.scm @@ -1,7 +1,7 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2012, 2013 Cyril Roelandt ;;; Copyright © 2014, 2015, 2016 Eric Bavier -;;; Copyright © 2014, 2015, 2016, 2017, 2018 Ludovic Courtès +;;; Copyright © 2014, 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès ;;; Copyright © 2015, 2016 Mathieu Lirzin ;;; Copyright © 2016 Hartmut Goebel ;;; Copyright © 2017 Alex Kost @@ -35,6 +35,7 @@ #:use-module (guix packages) #:use-module (guix lint) #:use-module (guix ui) + #:use-module (guix swh) #:use-module (gnu packages) #:use-module (gnu packages glib) #:use-module (gnu packages pkg-config) @@ -47,6 +48,7 @@ #:use-module (ice-9 regex) #:use-module (ice-9 getopt-long) #:use-module (ice-9 pretty-print) + #:use-module (rnrs bytevectors) #:use-module (srfi srfi-1) #:use-module (srfi srfi-9 gnu) #:use-module (srfi srfi-26) @@ -74,6 +76,12 @@ (((and (? lint-warning?) warning)) (lint-warning-message warning)))) +(define (warning-contains? str warnings) + "Return true if WARNINGS is a singleton with a warning that contains STR." + (match warnings + (((? lint-warning? warning)) + (string-contains (lint-warning-message warning) str)))) + (test-begin "lint") @@ -326,7 +334,7 @@ (check-patch-file-names pkg)))) (test-equal "patches: not found" - "this-patch-does-not-exist!: patch not found" + "this-patch-does-not-exist!: patch not found\n" (single-lint-warning-message (let ((pkg (dummy-package "x" @@ -345,6 +353,36 @@ (((and (? lint-warning?) first-warning) others ...) (lint-warning-message first-warning)))) +(test-equal "profile-collisions: no warnings" + '() + (check-profile-collisions (dummy-package "x"))) + +(test-equal "profile-collisions: propagated inputs collide" + "propagated inputs p0@1 and p0@2 collide" + (let* ((p0 (dummy-package "p0" (version "1"))) + (p0* (dummy-package "p0" (version "2"))) + (p1 (dummy-package "p1" (propagated-inputs `(("p0" ,p0))))) + (p2 (dummy-package "p2" (propagated-inputs `(("p1" ,p1))))) + (p3 (dummy-package "p3" (propagated-inputs `(("p0" ,p0*))))) + (p4 (dummy-package "p4" (propagated-inputs + `(("p2" ,p2) ("p3", p3)))))) + (single-lint-warning-message + (check-profile-collisions p4)))) + +(test-assert "profile-collisions: propagated inputs collide, store items" + (string-match-or-error + "propagated inputs /[[:graph:]]+-p0-1 and /[[:graph:]]+-p0-1 collide" + (let* ((p0 (dummy-package "p0" (version "1"))) + (p0* (dummy-package "p0" (version "1") + (inputs `(("x" ,(dummy-package "x")))))) + (p1 (dummy-package "p1" (propagated-inputs `(("p0" ,p0))))) + (p2 (dummy-package "p2" (propagated-inputs `(("p1" ,p1))))) + (p3 (dummy-package "p3" (propagated-inputs `(("p0" ,p0*))))) + (p4 (dummy-package "p4" (propagated-inputs + `(("p2" ,p2) ("p3", p3)))))) + (single-lint-warning-message + (check-profile-collisions p4))))) + (test-equal "license: invalid license" "invalid license field" (single-lint-warning-message @@ -366,13 +404,11 @@ (single-lint-warning-message (check-home-page pkg)))) -(test-equal "home-page: host not found" - "URI http://does-not-exist domain not found: Name or service not known" +(test-assert "home-page: host not found" (let ((pkg (package (inherit (dummy-package "x")) (home-page "http://does-not-exist")))) - (single-lint-warning-message - (check-home-page pkg)))) + (warning-contains? "domain not found" (check-home-page pkg)))) (test-skip (if (http-server-can-listen?) 0 1)) (test-equal "home-page: Connection refused" @@ -386,7 +422,7 @@ (test-skip (if (http-server-can-listen?) 0 1)) (test-equal "home-page: 200" '() - (with-http-server 200 %long-string + (with-http-server `((200 ,%long-string)) (let ((pkg (package (inherit (dummy-package "x")) (home-page (%local-url))))) @@ -395,7 +431,7 @@ (test-skip (if (http-server-can-listen?) 0 1)) (test-equal "home-page: 200 but short length" "URI http://localhost:9999/foo/bar returned suspiciously small file (18 bytes)" - (with-http-server 200 "This is too small." + (with-http-server `((200 "This is too small.")) (let ((pkg (package (inherit (dummy-package "x")) (home-page (%local-url))))) @@ -406,7 +442,7 @@ (test-skip (if (http-server-can-listen?) 0 1)) (test-equal "home-page: 404" "URI http://localhost:9999/foo/bar not reachable: 404 (\"Such is life\")" - (with-http-server 404 %long-string + (with-http-server `((404 ,%long-string)) (let ((pkg (package (inherit (dummy-package "x")) (home-page (%local-url))))) @@ -416,7 +452,7 @@ (test-skip (if (http-server-can-listen?) 0 1)) (test-equal "home-page: 301, invalid" "invalid permanent redirect from http://localhost:9999/foo/bar" - (with-http-server 301 %long-string + (with-http-server `((301 ,%long-string)) (let ((pkg (package (inherit (dummy-package "x")) (home-page (%local-url))))) @@ -426,12 +462,14 @@ (test-skip (if (http-server-can-listen?) 0 1)) (test-equal "home-page: 301 -> 200" "permanent redirect from http://localhost:10000/foo/bar to http://localhost:9999/foo/bar" - (with-http-server 200 %long-string - (let ((initial-url (%local-url))) + (with-http-server `((200 ,%long-string)) + (let* ((initial-url (%local-url)) + (redirect (build-response #:code 301 + #:headers + `((location + . ,(string->uri initial-url)))))) (parameterize ((%http-server-port (+ 1 (%http-server-port)))) - (with-http-server (301 `((location - . ,(string->uri initial-url)))) - "" + (with-http-server `((,redirect "")) (let ((pkg (package (inherit (dummy-package "x")) (home-page (%local-url))))) @@ -441,12 +479,14 @@ (test-skip (if (http-server-can-listen?) 0 1)) (test-equal "home-page: 301 -> 404" "URI http://localhost:10000/foo/bar not reachable: 404 (\"Such is life\")" - (with-http-server 404 "booh!" - (let ((initial-url (%local-url))) + (with-http-server '((404 "booh!")) + (let* ((initial-url (%local-url)) + (redirect (build-response #:code 301 + #:headers + `((location + . ,(string->uri initial-url)))))) (parameterize ((%http-server-port (+ 1 (%http-server-port)))) - (with-http-server (301 `((location - . ,(string->uri initial-url)))) - "" + (with-http-server `((,redirect "")) (let ((pkg (package (inherit (dummy-package "x")) (home-page (%local-url))))) @@ -571,7 +611,7 @@ (origin (method git-fetch) (uri (git-reference - (url "https://github.com/archive/example.git") + (url "https://github.com/archive/example") (commit "0"))) (sha256 %null-sha256)))))) (check-source-unstable-tarball pkg))) @@ -579,7 +619,7 @@ (test-skip (if (http-server-can-listen?) 0 1)) (test-equal "source: 200" '() - (with-http-server 200 %long-string + (with-http-server `((200 ,%long-string)) (let ((pkg (package (inherit (dummy-package "x")) (source (origin @@ -591,7 +631,7 @@ (test-skip (if (http-server-can-listen?) 0 1)) (test-equal "source: 200 but short length" "URI http://localhost:9999/foo/bar returned suspiciously small file (18 bytes)" - (with-http-server 200 "This is too small." + (with-http-server '((200 "This is too small.")) (let ((pkg (package (inherit (dummy-package "x")) (source (origin @@ -606,7 +646,7 @@ (test-skip (if (http-server-can-listen?) 0 1)) (test-equal "source: 404" "URI http://localhost:9999/foo/bar not reachable: 404 (\"Such is life\")" - (with-http-server 404 %long-string + (with-http-server `((404 ,%long-string)) (let ((pkg (package (inherit (dummy-package "x")) (source (origin @@ -618,14 +658,34 @@ (and (? lint-warning?) second-warning)) (lint-warning-message second-warning)))))) +(test-skip (if (http-server-can-listen?) 0 1)) +(test-equal "source: 404 and 200" + '() + (with-http-server `((404 ,%long-string)) + (let ((bad-url (%local-url))) + (parameterize ((%http-server-port (+ 1 (%http-server-port)))) + (with-http-server `((200 ,%long-string)) + (let ((pkg (package + (inherit (dummy-package "x")) + (source (origin + (method url-fetch) + (uri (list bad-url (%local-url))) + (sha256 %null-sha256)))))) + ;; Since one of the two URLs is good, this should return the empty + ;; list. + (check-source pkg))))))) + (test-skip (if (http-server-can-listen?) 0 1)) (test-equal "source: 301 -> 200" "permanent redirect from http://localhost:10000/foo/bar to http://localhost:9999/foo/bar" - (with-http-server 200 %long-string - (let ((initial-url (%local-url))) + (with-http-server `((200 ,%long-string)) + (let* ((initial-url (%local-url)) + (redirect (build-response #:code 301 + #:headers + `((location + . ,(string->uri initial-url)))))) (parameterize ((%http-server-port (+ 1 (%http-server-port)))) - (with-http-server (301 `((location . ,(string->uri initial-url)))) - "" + (with-http-server `((,redirect "")) (let ((pkg (package (inherit (dummy-package "x")) (source (origin @@ -637,14 +697,37 @@ (and (? lint-warning?) second-warning)) (lint-warning-message second-warning))))))))) +(test-skip (if (http-server-can-listen?) 0 1)) +(test-equal "source, git-reference: 301 -> 200" + "permanent redirect from http://localhost:10000/foo/bar to http://localhost:9999/foo/bar" + (with-http-server `((200 ,%long-string)) + (let* ((initial-url (%local-url)) + (redirect (build-response #:code 301 + #:headers + `((location + . ,(string->uri initial-url)))))) + (parameterize ((%http-server-port (+ 1 (%http-server-port)))) + (with-http-server `((,redirect "")) + (let ((pkg (dummy-package + "x" + (source (origin + (method git-fetch) + (uri (git-reference (url (%local-url)) + (commit "v1.0.0"))) + (sha256 %null-sha256)))))) + (single-lint-warning-message (check-source pkg)))))))) + (test-skip (if (http-server-can-listen?) 0 1)) (test-equal "source: 301 -> 404" "URI http://localhost:10000/foo/bar not reachable: 404 (\"Such is life\")" - (with-http-server 404 "booh!" - (let ((initial-url (%local-url))) + (with-http-server '((404 "booh!")) + (let* ((initial-url (%local-url)) + (redirect (build-response #:code 301 + #:headers + `((location + . ,(string->uri initial-url)))))) (parameterize ((%http-server-port (+ 1 (%http-server-port)))) - (with-http-server (301 `((location . ,(string->uri initial-url)))) - "" + (with-http-server `((,redirect "")) (let ((pkg (package (inherit (dummy-package "x")) (source (origin @@ -674,9 +757,10 @@ (single-lint-warning-message (check-mirror-url (dummy-package "x" (source source)))))) +(test-skip (if (http-server-can-listen?) 0 1)) (test-equal "github-url" '() - (with-http-server 200 %long-string + (with-http-server `((200 ,%long-string)) (check-github-url (dummy-package "x" (source (origin @@ -685,20 +769,31 @@ (sha256 %null-sha256))))))) (let ((github-url "https://github.com/foo/bar/bar-1.0.tar.gz")) + (test-skip (if (http-server-can-listen?) 0 1)) (test-equal "github-url: one suggestion" (string-append "URL should be '" github-url "'") - (with-http-server (301 `((location . ,(string->uri github-url)))) "" - (let ((initial-uri (%local-url))) - (parameterize ((%http-server-port (+ 1 (%http-server-port)))) - (with-http-server (302 `((location . ,(string->uri initial-uri)))) "" - (single-lint-warning-message - (check-github-url - (dummy-package "x" (source - (origin - (method url-fetch) - (uri (%local-url)) - (sha256 %null-sha256))))))))))) + (let ((redirect (build-response #:code 301 + #:headers + `((location + . ,(string->uri github-url)))))) + (with-http-server `((,redirect "")) + (let* ((initial-url (%local-url)) + (redirect (build-response #:code 302 + #:headers + `((location + . ,(string->uri initial-url)))))) + (parameterize ((%http-server-port (+ 1 (%http-server-port)))) + (with-http-server `((,redirect "")) + (single-lint-warning-message + (check-github-url + (dummy-package "x" (source + (origin + (method url-fetch) + (uri (%local-url)) + (sha256 %null-sha256)))))))))))) + + (test-skip (if (http-server-can-listen?) 0 1)) (test-equal "github-url: already the correct github url" '() (check-github-url @@ -710,28 +805,30 @@ (test-equal "cve" '() - (mock ((guix scripts lint) package-vulnerabilities (const '())) + (mock ((guix lint) package-vulnerabilities (const '())) (check-vulnerabilities (dummy-package "x")))) (test-equal "cve: one vulnerability" "probably vulnerable to CVE-2015-1234" - (mock ((guix scripts lint) package-vulnerabilities + (let ((dummy-vulnerabilities (lambda (package) - (list (make-struct (@@ (guix cve) ) 0 - "CVE-2015-1234" - (list (cons (package-name package) - (package-version package))))))) - (single-lint-warning-message - (check-vulnerabilities (dummy-package "pi" (version "3.14")))))) + (list (make-struct/no-tail + (@@ (guix cve) ) + "CVE-2015-1234" + (list (cons (package-name package) + (package-version package)))))))) + (single-lint-warning-message + (check-vulnerabilities (dummy-package "pi" (version "3.14")) + dummy-vulnerabilities)))) (test-equal "cve: one patched vulnerability" '() - (mock ((guix scripts lint) package-vulnerabilities + (mock ((guix lint) package-vulnerabilities (lambda (package) - (list (make-struct (@@ (guix cve) ) 0 - "CVE-2015-1234" - (list (cons (package-name package) - (package-version package))))))) + (list (make-struct/no-tail (@@ (guix cve) ) + "CVE-2015-1234" + (list (cons (package-name package) + (package-version package))))))) (check-vulnerabilities (dummy-package "pi" (version "3.14") @@ -742,12 +839,12 @@ (test-equal "cve: known safe from vulnerability" '() - (mock ((guix scripts lint) package-vulnerabilities + (mock ((guix lint) package-vulnerabilities (lambda (package) - (list (make-struct (@@ (guix cve) ) 0 - "CVE-2015-1234" - (list (cons (package-name package) - (package-version package))))))) + (list (make-struct/no-tail (@@ (guix cve) ) + "CVE-2015-1234" + (list (cons (package-name package) + (package-version package))))))) (check-vulnerabilities (dummy-package "pi" (version "3.14") @@ -755,14 +852,14 @@ (test-equal "cve: vulnerability fixed in replacement version" '() - (mock ((guix scripts lint) package-vulnerabilities + (mock ((guix lint) package-vulnerabilities (lambda (package) (match (package-version package) ("0" - (list (make-struct (@@ (guix cve) ) 0 - "CVE-2015-1234" - (list (cons (package-name package) - (package-version package)))))) + (list (make-struct/no-tail (@@ (guix cve) ) + "CVE-2015-1234" + (list (cons (package-name package) + (package-version package)))))) ("1" '())))) (check-vulnerabilities @@ -772,12 +869,12 @@ (test-equal "cve: patched vulnerability in replacement" '() - (mock ((guix scripts lint) package-vulnerabilities + (mock ((guix lint) package-vulnerabilities (lambda (package) - (list (make-struct (@@ (guix cve) ) 0 - "CVE-2015-1234" - (list (cons (package-name package) - (package-version package))))))) + (list (make-struct/no-tail (@@ (guix cve) ) + "CVE-2015-1234" + (list (cons (package-name package) + (package-version package))))))) (check-vulnerabilities (dummy-package "pi" (version "3.14") (source (dummy-origin)) @@ -820,9 +917,93 @@ '() (check-formatting (dummy-package "x"))) +(test-skip (if (http-server-can-listen?) 0 1)) +(test-assert "archival: missing content" + (let* ((origin (origin + (method url-fetch) + (uri "http://example.org/foo.tgz") + (sha256 (make-bytevector 32)))) + (warnings (with-http-server '((404 "Not archived.")) + (parameterize ((%swh-base-url (%local-url))) + (check-archival (dummy-package "x" + (source origin))))))) + (warning-contains? "not archived" warnings))) + +(test-skip (if (http-server-can-listen?) 0 1)) +(test-equal "archival: content available" + '() + (let* ((origin (origin + (method url-fetch) + (uri "http://example.org/foo.tgz") + (sha256 (make-bytevector 32)))) + ;; https://archive.softwareheritage.org/api/1/content/ + (content "{ \"checksums\": {}, \"data_url\": \"xyz\", + \"length\": 42 }")) + (with-http-server `((200 ,content)) + (parameterize ((%swh-base-url (%local-url))) + (check-archival (dummy-package "x" (source origin))))))) + +(test-skip (if (http-server-can-listen?) 0 1)) +(test-assert "archival: missing revision" + (let* ((origin (origin + (method git-fetch) + (uri (git-reference + (url "http://example.org/foo.git") + (commit "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"))) + (sha256 (make-bytevector 32)))) + ;; https://archive.softwareheritage.org/api/1/origin/save/ + (save "{ \"origin_url\": \"http://example.org/foo.git\", + \"save_request_date\": \"2014-11-17T22:09:38+01:00\", + \"save_request_status\": \"accepted\", + \"save_task_status\": \"scheduled\" }") + (warnings (with-http-server `((404 "No revision.") ;lookup-revision + (404 "No origin.") ;lookup-origin + (200 ,save)) ;save-origin + (parameterize ((%swh-base-url (%local-url))) + (check-archival (dummy-package "x" (source origin))))))) + (warning-contains? "scheduled" warnings))) + +(test-skip (if (http-server-can-listen?) 0 1)) +(test-equal "archival: revision available" + '() + (let* ((origin (origin + (method git-fetch) + (uri (git-reference + (url "http://example.org/foo.git") + (commit "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"))) + (sha256 (make-bytevector 32)))) + ;; https://archive.softwareheritage.org/api/1/revision/ + (revision "{ \"author\": {}, \"parents\": [], + \"date\": \"2014-11-17T22:09:38+01:00\" }")) + (with-http-server `((200 ,revision)) + (parameterize ((%swh-base-url (%local-url))) + (check-archival (dummy-package "x" (source origin))))))) + +(test-skip (if (http-server-can-listen?) 0 1)) +(test-assert "archival: rate limit reached" + ;; We should get a single warning stating that the rate limit was reached, + ;; and nothing more, in particular no other HTTP requests. + (let* ((origin (origin + (method url-fetch) + (uri "http://example.org/foo.tgz") + (sha256 (make-bytevector 32)))) + (too-many (build-response + #:code 429 + #:reason-phrase "Too many requests" + #:headers '((x-ratelimit-remaining . "0") + (x-ratelimit-reset . "3000000000")))) + (warnings (with-http-server `((,too-many "Rate limit reached.")) + (parameterize ((%swh-base-url (%local-url))) + (append-map (lambda (name) + (check-archival + (dummy-package name (source origin)))) + '("x" "y" "z")))))) + (string-contains (single-lint-warning-message warnings) + "rate limit reached"))) + (test-end "lint") ;; Local Variables: -;; eval: (put 'with-http-server 'scheme-indent-function 2) +;; eval: (put 'with-http-server 'scheme-indent-function 1) ;; eval: (put 'with-warnings 'scheme-indent-function 0) ;; End: