X-Git-Url: https://git.hcoop.net/jackhill/guix/guix.git/blobdiff_plain/5432734b00ae14c3a93af358fc7bbf80e3db5ee8..7ca97fae366b5ac8324a774d8aa09c2a36348666:/tests/lint.scm?ds=sidebyside diff --git a/tests/lint.scm b/tests/lint.scm index 50316ade9a..d692b42f93 100644 --- a/tests/lint.scm +++ b/tests/lint.scm @@ -1,8 +1,8 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2012, 2013 Cyril Roelandt -;;; Copyright © 2014, 2015 Eric Bavier -;;; Copyright © 2014, 2015 Ludovic Courtès -;;; Copyright © 2015 Mathieu Lirzin +;;; Copyright © 2014, 2015, 2016 Eric Bavier +;;; Copyright © 2014, 2015, 2016 Ludovic Courtès +;;; Copyright © 2015, 2016 Mathieu Lirzin ;;; ;;; This file is part of GNU Guix. ;;; @@ -19,6 +19,9 @@ ;;; You should have received a copy of the GNU General Public License ;;; along with GNU Guix. If not, see . +;; Avoid interference. +(unsetenv "http_proxy") + (define-module (test-lint) #:use-module (guix tests) #:use-module (guix download) @@ -28,10 +31,12 @@ #:use-module (guix scripts lint) #:use-module (guix ui) #:use-module (gnu packages) + #:use-module (gnu packages glib) #:use-module (gnu packages pkg-config) #:use-module (web server) #:use-module (web server http) #:use-module (web response) + #:use-module (ice-9 match) #:use-module (ice-9 threads) #:use-module (srfi srfi-9 gnu) #:use-module (srfi srfi-64)) @@ -99,14 +104,14 @@ http-write (@@ (web server http) http-close)) -(define (call-with-http-server code thunk) - "Call THUNK with an HTTP server running and returning CODE on HTTP -requests." +(define (call-with-http-server code data thunk) + "Call THUNK with an HTTP server running and returning CODE and DATA (a +string) on HTTP requests." (define (server-body) (define (handle request body) (values (build-response #:code code #:reason-phrase "Such is life") - "Hello, world.")) + data)) (catch 'quit (lambda () @@ -120,8 +125,11 @@ requests." ;; Normally SERVER exits automatically once it has received a request. (thunk)))) -(define-syntax-rule (with-http-server code body ...) - (call-with-http-server code (lambda () body ...))) +(define-syntax-rule (with-http-server code data body ...) + (call-with-http-server code data (lambda () body ...))) + +(define %long-string + (make-string 2000 #\a)) (test-begin "lint") @@ -135,6 +143,14 @@ requests." (define-syntax-rule (with-warnings body ...) (call-with-warnings (lambda () body ...))) +(test-assert "description: not a string" + (->bool + (string-contains (with-warnings + (let ((pkg (dummy-package "x" + (description 'foobar)))) + (check-description-style pkg))) + "invalid description"))) + (test-assert "description: not empty" (->bool (string-contains (with-warnings @@ -188,6 +204,28 @@ requests." "E.g. Foo, i.e. Bar resp. Baz (a.k.a. DVD).")))) (check-description-style pkg))))) +(test-assert "description: may not contain trademark signs" + (and (->bool + (string-contains (with-warnings + (let ((pkg (dummy-package "x" + (description "Does The Right Thing™")))) + (check-description-style pkg))) + "should not contain trademark sign")) + (->bool + (string-contains (with-warnings + (let ((pkg (dummy-package "x" + (description "Works with Format®")))) + (check-description-style pkg))) + "should not contain trademark sign")))) + +(test-assert "synopsis: not a string" + (->bool + (string-contains (with-warnings + (let ((pkg (dummy-package "x" + (synopsis #f)))) + (check-synopsis-style pkg))) + "invalid synopsis"))) + (test-assert "synopsis: not empty" (->bool (string-contains (with-warnings @@ -297,7 +335,16 @@ requests." (let ((pkg (dummy-package "x" (inputs `(("pkg-config" ,pkg-config)))))) (check-inputs-should-be-native pkg))) - "pkg-config should probably be a native input"))) + "'pkg-config' should probably be a native input"))) + +(test-assert "inputs: glib:bin is probably a native input" + (->bool + (string-contains + (with-warnings + (let ((pkg (dummy-package "x" + (inputs `(("glib" ,glib "bin")))))) + (check-inputs-should-be-native pkg))) + "'glib:bin' should probably be a native input"))) (test-assert "patches: file names" (->bool @@ -305,10 +352,7 @@ requests." (with-warnings (let ((pkg (dummy-package "x" (source - (origin - (method url-fetch) - (uri "someurl") - (sha256 "somesha") + (dummy-origin (patches (list "/path/to/y.patch"))))))) (check-patch-file-names pkg))) "file names of patches should start with the package name"))) @@ -319,10 +363,7 @@ requests." (with-warnings (let ((pkg (dummy-package "x" (source - (origin - (method url-fetch) - (uri "someurl") - (sha256 "somesha") + (dummy-origin (patches (list (search-patch "this-patch-does-not-exist!")))))))) (check-patch-file-names pkg))) @@ -389,18 +430,30 @@ requests." (test-equal "home-page: 200" "" (with-warnings - (with-http-server 200 + (with-http-server 200 %long-string (let ((pkg (package (inherit (dummy-package "x")) (home-page %local-url)))) (check-home-page pkg))))) +(test-skip (if %http-server-socket 0 1)) +(test-assert "home-page: 200 but short length" + (->bool + (string-contains + (with-warnings + (with-http-server 200 "This is too small." + (let ((pkg (package + (inherit (dummy-package "x")) + (home-page %local-url)))) + (check-home-page pkg)))) + "suspiciously small"))) + (test-skip (if %http-server-socket 0 1)) (test-assert "home-page: 404" (->bool (string-contains (with-warnings - (with-http-server 404 + (with-http-server 404 %long-string (let ((pkg (package (inherit (dummy-package "x")) (home-page %local-url)))) @@ -488,7 +541,7 @@ requests." (test-equal "source: 200" "" (with-warnings - (with-http-server 200 + (with-http-server 200 %long-string (let ((pkg (package (inherit (dummy-package "x")) (source (origin @@ -497,12 +550,27 @@ requests." (sha256 %null-sha256)))))) (check-source pkg))))) +(test-skip (if %http-server-socket 0 1)) +(test-assert "source: 200 but short length" + (->bool + (string-contains + (with-warnings + (with-http-server 200 "This is too small." + (let ((pkg (package + (inherit (dummy-package "x")) + (source (origin + (method url-fetch) + (uri %local-url) + (sha256 %null-sha256)))))) + (check-source pkg)))) + "suspiciously small"))) + (test-skip (if %http-server-socket 0 1)) (test-assert "source: 404" (->bool (string-contains (with-warnings - (with-http-server 404 + (with-http-server 404 %long-string (let ((pkg (package (inherit (dummy-package "x")) (source (origin @@ -529,6 +597,64 @@ requests." (check-vulnerabilities (dummy-package "pi" (version "3.14")))) "vulnerable to CVE-2015-1234"))) +(test-assert "cve: one patched vulnerability" + (mock ((guix scripts lint) package-vulnerabilities + (lambda (package) + (list (make-struct (@@ (guix cve) ) 0 + "CVE-2015-1234" + (list (cons (package-name package) + (package-version package))))))) + (string-null? + (with-warnings + (check-vulnerabilities + (dummy-package "pi" + (version "3.14") + (source + (dummy-origin + (patches + (list "/a/b/pi-CVE-2015-1234.patch")))))))))) + +(test-assert "cve: vulnerability fixed in replacement version" + (mock ((guix scripts 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)))))) + ("1" + '())))) + (and (not (string-null? + (with-warnings + (check-vulnerabilities + (dummy-package "foo" (version "0")))))) + (string-null? + (with-warnings + (check-vulnerabilities + (dummy-package + "foo" (version "0") + (replacement (dummy-package "foo" (version "1")))))))))) + +(test-assert "cve: patched vulnerability in replacement" + (mock ((guix scripts lint) package-vulnerabilities + (lambda (package) + (list (make-struct (@@ (guix cve) ) 0 + "CVE-2015-1234" + (list (cons (package-name package) + (package-version package))))))) + (string-null? + (with-warnings + (check-vulnerabilities + (dummy-package + "pi" (version "3.14") (source (dummy-origin)) + (replacement (dummy-package + "pi" (version "3.14") + (source + (dummy-origin + (patches + (list "/a/b/pi-CVE-2015-1234.patch")))))))))))) + (test-assert "formatting: lonely parentheses" (string-contains (with-warnings @@ -567,10 +693,7 @@ requests." (test-end "lint") - -(exit (= (test-runner-fail-count (test-runner-current)) 0)) - ;; Local Variables: -;; eval: (put 'with-http-server 'scheme-indent-function 1) +;; eval: (put 'with-http-server 'scheme-indent-function 2) ;; eval: (put 'with-warnings 'scheme-indent-function 0) ;; End: