;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2012, 2013 Cyril Roelandt <tipecaml@gmail.com>
;;; Copyright © 2014, 2015, 2016 Eric Bavier <bavier@member.fsf.org>
-;;; Copyright © 2014, 2015, 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2014, 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2015, 2016 Mathieu Lirzin <mthl@gnu.org>
;;; Copyright © 2016 Hartmut Goebel <h.goebel@crazy-compilers.com>
;;; Copyright © 2017 Alex Kost <alezost@gmail.com>
#: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)
#: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)
(((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))))
+
\f
(test-begin "lint")
(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"
(((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
(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"
(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)))))
(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)))))
(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)))))
(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)))))
(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)))))
(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)))))
(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)))
(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
(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
(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
(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
(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
(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
(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
(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) <vulnerability>) 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) <vulnerability>)
+ "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) <vulnerability>) 0
- "CVE-2015-1234"
- (list (cons (package-name package)
- (package-version package)))))))
+ (list (make-struct/no-tail (@@ (guix cve) <vulnerability>)
+ "CVE-2015-1234"
+ (list (cons (package-name package)
+ (package-version package)))))))
(check-vulnerabilities
(dummy-package "pi"
(version "3.14")
(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) <vulnerability>) 0
- "CVE-2015-1234"
- (list (cons (package-name package)
- (package-version package)))))))
+ (list (make-struct/no-tail (@@ (guix cve) <vulnerability>)
+ "CVE-2015-1234"
+ (list (cons (package-name package)
+ (package-version package)))))))
(check-vulnerabilities
(dummy-package "pi"
(version "3.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) <vulnerability>) 0
- "CVE-2015-1234"
- (list (cons (package-name package)
- (package-version package))))))
+ (list (make-struct/no-tail (@@ (guix cve) <vulnerability>)
+ "CVE-2015-1234"
+ (list (cons (package-name package)
+ (package-version package))))))
("1"
'()))))
(check-vulnerabilities
(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) <vulnerability>) 0
- "CVE-2015-1234"
- (list (cons (package-name package)
- (package-version package)))))))
+ (list (make-struct/no-tail (@@ (guix cve) <vulnerability>)
+ "CVE-2015-1234"
+ (list (cons (package-name package)
+ (package-version package)))))))
(check-vulnerabilities
(dummy-package
"pi" (version "3.14") (source (dummy-origin))
'()
(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:
HCoop / jackhill / guix / guix.git / blobdiff