TakeV/guix
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity
guix/tests/lint.scm
Christopher Baines f363c836e0
lint: Move the linting code to a different module. 
To try and move towards making programatic access to the linting code easier,
this commit separates out the linting script, from the linting functionality
that it uses.

* guix/scripts/lint.scm (emit-warnings): Alter to to not use match-lambda, as
<lint-warning> isn't accessible.
(<lint-warning>, lint-warning, make-lint-warning, lint-warning?,
lint-warning-message, lint-warning-message-text, lint-warning-message-data,
lint-warning-location, package-file, %make-warning make-warning,
<lint-checker>, lint-checker, make-lint-checker, lint-checker?,
lint-checker-name, lint-checker-description, lint-checker-check,
properly-starts-sentance?, starts-with-abbreviation?, %quoted-identifier-rx,
check-description-style, package-input-intersection,
check-inputs-should-be-native, check-inputs-should-not-be-an-input-at-all,
package-name-regexp, check-synopsis-style, probe-uri,
tls-certificate-error-string, validate-uri, check-home-page,
%distro-directory, check-patch-file-names, escape-quotes,
official-gnu-packages*, check-gnu-synopsis+description, origin-uris,
check-source, check-source-file-name, check-source-unstable-tarball,
check-mirror-url, check-github-url, check-derivation, check-license,
call-with-networking-fail-safe, with-networking-fail-safe,
current-vulnerabilities*, package-vulnerabilities, check-vulnerabilities,
check-for-updates, report-tabulations, report-trailing-white-space,
report-long-line, %hanging-paren-rx, report-lone-parantheses,
%formatting-reporters, report-formatting-issues, check-formatting, %checkers):
Move to…
* guix/lint.scm: … here
* po/guix/POTFILES.in: Add guix/lint.scm.
* Makefile.am: Add guix/lint.scm.
* tests/lint.scm: Change to import (guix lint), rather than (guix scripts lint).
2019-07-15 22:32:19 +01:00

828 lines
31 KiB
Scheme
Raw Blame History

This file contains invisible Unicode characters

This file contains invisible Unicode characters that are indistinguishable to humans but may be processed differently by a computer. If you think that this is intentional, you can safely ignore this warning. Use the Escape button to reveal them.

;;; 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 © 2015, 2016 Mathieu Lirzin <mthl@gnu.org>
;;; Copyright © 2016 Hartmut Goebel <h.goebel@crazy-compilers.com>
;;; Copyright © 2017 Alex Kost <alezost@gmail.com>
;;; Copyright © 2017 Efraim Flashner <efraim@flashner.co.il>
;;; Copyright © 2018, 2019 Arun Isaac <arunisaac@systemreboot.net>
;;;
;;; This file is part of GNU Guix.
;;;
;;; GNU Guix is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; GNU Guix is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
;; Avoid interference.
(unsetenv "http_proxy")
(define-module (test-lint)
#:use-module (guix tests)
#:use-module (guix tests http)
#:use-module (guix download)
#:use-module (guix git-download)
#:use-module (guix build-system gnu)
#:use-module (guix packages)
#:use-module (guix lint)
#:use-module (guix ui)
#:use-module (gnu packages)
#:use-module (gnu packages glib)
#:use-module (gnu packages pkg-config)
#:use-module (gnu packages python-xyz)
#:use-module (web uri)
#:use-module (web server)
#:use-module (web server http)
#:use-module (web response)
#:use-module (ice-9 match)
#:use-module (ice-9 regex)
#:use-module (ice-9 getopt-long)
#:use-module (ice-9 pretty-print)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-9 gnu)
#:use-module (srfi srfi-26)
#:use-module (srfi srfi-64))
;; Test the linter.
;; Avoid collisions with other tests.
(%http-server-port 9999)
(define %null-sha256
;; SHA256 of the empty string.
(base32
"0mdqa9w1p6cmli6976v4wi0sw9r4p5prkj7lzfd1877wk11c9c73"))
(define %long-string
(make-string 2000 #\a))
(define (string-match-or-error pattern str)
(or (string-match pattern str)
(error str "did not match" pattern)))
(define single-lint-warning-message
(match-lambda
(((and (? lint-warning?) warning))
(lint-warning-message warning))))
(test-begin "lint")
(test-equal "description: not a string"
"invalid description: foobar"
(single-lint-warning-message
(check-description-style
(dummy-package "x" (description 'foobar)))))
(test-equal "description: not empty"
"description should not be empty"
(single-lint-warning-message
(check-description-style
(dummy-package "x" (description "")))))
(test-equal "description: invalid Texinfo markup"
"Texinfo markup in description is invalid"
(single-lint-warning-message
(check-description-style
(dummy-package "x" (description "f{oo}b@r")))))
(test-equal "description: does not start with an upper-case letter"
"description should start with an upper-case letter or digit"
(single-lint-warning-message
(let ((pkg (dummy-package "x"
(description "bad description."))))
(check-description-style pkg))))
(test-equal "description: may start with a digit"
'()
(let ((pkg (dummy-package "x"
(description "2-component library."))))
(check-description-style pkg)))
(test-equal "description: may start with lower-case package name"
'()
(let ((pkg (dummy-package "x"
(description "x is a dummy package."))))
(check-description-style pkg)))
(test-equal "description: two spaces after end of sentence"
"sentences in description should be followed by two spaces; possible infraction at 3"
(single-lint-warning-message
(let ((pkg (dummy-package "x"
(description "Bad. Quite bad."))))
(check-description-style pkg))))
(test-equal "description: end-of-sentence detection with abbreviations"
'()
(let ((pkg (dummy-package "x"
(description
"E.g. Foo, i.e. Bar resp. Baz (a.k.a. DVD)."))))
(check-description-style pkg)))
(test-equal "description: may not contain trademark signs: ™"
"description should not contain trademark sign '™' at 20"
(single-lint-warning-message
(let ((pkg (dummy-package "x"
(description "Does The Right Thing™"))))
(check-description-style pkg))))
(test-equal "description: may not contain trademark signs: ®"
"description should not contain trademark sign '®' at 17"
(single-lint-warning-message
(let ((pkg (dummy-package "x"
(description "Works with Format®"))))
(check-description-style pkg))))
(test-equal "description: suggest ornament instead of quotes"
"use @code or similar ornament instead of quotes"
(single-lint-warning-message
(let ((pkg (dummy-package "x"
(description "This is a 'quoted' thing."))))
(check-description-style pkg))))
(test-equal "synopsis: not a string"
"invalid synopsis: #f"
(single-lint-warning-message
(let ((pkg (dummy-package "x"
(synopsis #f))))
(check-synopsis-style pkg))))
(test-equal "synopsis: not empty"
"synopsis should not be empty"
(single-lint-warning-message
(let ((pkg (dummy-package "x"
(synopsis ""))))
(check-synopsis-style pkg))))
(test-equal "synopsis: valid Texinfo markup"
"Texinfo markup in synopsis is invalid"
(single-lint-warning-message
(check-synopsis-style
(dummy-package "x" (synopsis "Bad $@ texinfo")))))
(test-equal "synopsis: does not start with an upper-case letter"
"synopsis should start with an upper-case letter or digit"
(single-lint-warning-message
(let ((pkg (dummy-package "x"
(synopsis "bad synopsis"))))
(check-synopsis-style pkg))))
(test-equal "synopsis: may start with a digit"
'()
(let ((pkg (dummy-package "x"
(synopsis "5-dimensional frobnicator"))))
(check-synopsis-style pkg)))
(test-equal "synopsis: ends with a period"
"no period allowed at the end of the synopsis"
(single-lint-warning-message
(let ((pkg (dummy-package "x"
(synopsis "Bad synopsis."))))
(check-synopsis-style pkg))))
(test-equal "synopsis: ends with 'etc.'"
'()
(let ((pkg (dummy-package "x"
(synopsis "Foo, bar, etc."))))
(check-synopsis-style pkg)))
(test-equal "synopsis: starts with 'A'"
"no article allowed at the beginning of the synopsis"
(single-lint-warning-message
(let ((pkg (dummy-package "x"
(synopsis "A bad synopŝis"))))
(check-synopsis-style pkg))))
(test-equal "synopsis: starts with 'An'"
"no article allowed at the beginning of the synopsis"
(single-lint-warning-message
(let ((pkg (dummy-package "x"
(synopsis "An awful synopsis"))))
(check-synopsis-style pkg))))
(test-equal "synopsis: starts with 'a'"
'("no article allowed at the beginning of the synopsis"
"synopsis should start with an upper-case letter or digit")
(sort
(map
lint-warning-message
(let ((pkg (dummy-package "x"
(synopsis "a bad synopsis"))))
(check-synopsis-style pkg)))
string<?))
(test-equal "synopsis: starts with 'an'"
'("no article allowed at the beginning of the synopsis"
"synopsis should start with an upper-case letter or digit")
(sort
(map
lint-warning-message
(let ((pkg (dummy-package "x"
(synopsis "an awful synopsis"))))
(check-synopsis-style pkg)))
string<?))
(test-equal "synopsis: too long"
"synopsis should be less than 80 characters long"
(single-lint-warning-message
(let ((pkg (dummy-package "x"
(synopsis (make-string 80 #\X)))))
(check-synopsis-style pkg))))
(test-equal "synopsis: start with package name"
"synopsis should not start with the package name"
(single-lint-warning-message
(let ((pkg (dummy-package "x"
(name "Foo")
(synopsis "Foo, a nice package"))))
(check-synopsis-style pkg))))
(test-equal "synopsis: start with package name prefix"
'()
(let ((pkg (dummy-package "arb"
(synopsis "Arbitrary precision"))))
(check-synopsis-style pkg)))
(test-equal "synopsis: start with abbreviation"
'()
(let ((pkg (dummy-package "uucp"
;; Same problem with "APL interpreter", etc.
(synopsis "UUCP implementation")
(description "Imagine this is Taylor UUCP."))))
(check-synopsis-style pkg)))
(test-equal "inputs: pkg-config is probably a native input"
"'pkg-config' should probably be a native input"
(single-lint-warning-message
(let ((pkg (dummy-package "x"
(inputs `(("pkg-config" ,pkg-config))))))
(check-inputs-should-be-native pkg))))
(test-equal "inputs: glib:bin is probably a native input"
"'glib:bin' should probably be a native input"
(single-lint-warning-message
(let ((pkg (dummy-package "x"
(inputs `(("glib" ,glib "bin"))))))
(check-inputs-should-be-native pkg))))
(test-equal
"inputs: python-setuptools should not be an input at all (input)"
"'python-setuptools' should probably not be an input at all"
(single-lint-warning-message
(let ((pkg (dummy-package "x"
(inputs `(("python-setuptools"
,python-setuptools))))))
(check-inputs-should-not-be-an-input-at-all pkg))))
(test-equal
"inputs: python-setuptools should not be an input at all (native-input)"
"'python-setuptools' should probably not be an input at all"
(single-lint-warning-message
(let ((pkg (dummy-package "x"
(native-inputs
`(("python-setuptools"
,python-setuptools))))))
(check-inputs-should-not-be-an-input-at-all pkg))))
(test-equal
"inputs: python-setuptools should not be an input at all (propagated-input)"
"'python-setuptools' should probably not be an input at all"
(single-lint-warning-message
(let ((pkg (dummy-package "x"
(propagated-inputs
`(("python-setuptools" ,python-setuptools))))))
(check-inputs-should-not-be-an-input-at-all pkg))))
(test-equal "patches: file names"
"file names of patches should start with the package name"
(single-lint-warning-message
(let ((pkg (dummy-package "x"
(source
(dummy-origin
(patches (list "/path/to/y.patch")))))))
(check-patch-file-names pkg))))
(test-equal "patches: file name too long"
(string-append "x-"
(make-string 100 #\a)
".patch: file name is too long")
(single-lint-warning-message
(let ((pkg (dummy-package
"x"
(source
(dummy-origin
(patches (list (string-append "x-"
(make-string 100 #\a)
".patch"))))))))
(check-patch-file-names pkg))))
(test-equal "patches: not found"
"this-patch-does-not-exist!: patch not found"
(single-lint-warning-message
(let ((pkg (dummy-package
"x"
(source
(dummy-origin
(patches
(list (search-patch "this-patch-does-not-exist!"))))))))
(check-patch-file-names pkg))))
(test-equal "derivation: invalid arguments"
"failed to create x86_64-linux derivation: (wrong-type-arg \"map\" \"Wrong type argument: ~S\" (invalid-module) ())"
(match (let ((pkg (dummy-package "x"
(arguments
'(#:imported-modules (invalid-module))))))
(check-derivation pkg))
(((and (? lint-warning?) first-warning) others ...)
(lint-warning-message first-warning))))
(test-equal "license: invalid license"
"invalid license field"
(single-lint-warning-message
(check-license (dummy-package "x" (license #f)))))
(test-equal "home-page: wrong home-page"
"invalid value for home page"
(let ((pkg (package
(inherit (dummy-package "x"))
(home-page #f))))
(single-lint-warning-message
(check-home-page pkg))))
(test-equal "home-page: invalid URI"
"invalid home page URL: \"foobar\""
(let ((pkg (package
(inherit (dummy-package "x"))
(home-page "foobar"))))
(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"
(let ((pkg (package
(inherit (dummy-package "x"))
(home-page "http://does-not-exist"))))
(single-lint-warning-message
(check-home-page pkg))))
(test-skip (if (http-server-can-listen?) 0 1))
(test-equal "home-page: Connection refused"
"URI http://localhost:9999/foo/bar unreachable: Connection refused"
(let ((pkg (package
(inherit (dummy-package "x"))
(home-page (%local-url)))))
(single-lint-warning-message
(check-home-page pkg))))
(test-skip (if (http-server-can-listen?) 0 1))
(test-equal "home-page: 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-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."
(let ((pkg (package
(inherit (dummy-package "x"))
(home-page (%local-url)))))
(single-lint-warning-message
(check-home-page pkg)))))
(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
(let ((pkg (package
(inherit (dummy-package "x"))
(home-page (%local-url)))))
(single-lint-warning-message
(check-home-page pkg)))))
(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
(let ((pkg (package
(inherit (dummy-package "x"))
(home-page (%local-url)))))
(single-lint-warning-message
(check-home-page pkg)))))
(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)))
(parameterize ((%http-server-port (+ 1 (%http-server-port))))
(with-http-server (301 `((location
. ,(string->uri initial-url))))
""
(let ((pkg (package
(inherit (dummy-package "x"))
(home-page (%local-url)))))
(single-lint-warning-message
(check-home-page pkg))))))))
(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)))
(parameterize ((%http-server-port (+ 1 (%http-server-port))))
(with-http-server (301 `((location
. ,(string->uri initial-url))))
""
(let ((pkg (package
(inherit (dummy-package "x"))
(home-page (%local-url)))))
(single-lint-warning-message
(check-home-page pkg))))))))
(test-equal "source-file-name"
"the source file name should contain the package name"
(let ((pkg (dummy-package "x"
(version "3.2.1")
(source
(origin
(method url-fetch)
(uri "http://www.example.com/3.2.1.tar.gz")
(sha256 %null-sha256))))))
(single-lint-warning-message
(check-source-file-name pkg))))
(test-equal "source-file-name: v prefix"
"the source file name should contain the package name"
(let ((pkg (dummy-package "x"
(version "3.2.1")
(source
(origin
(method url-fetch)
(uri "http://www.example.com/v3.2.1.tar.gz")
(sha256 %null-sha256))))))
(single-lint-warning-message
(check-source-file-name pkg))))
(test-equal "source-file-name: bad checkout"
"the source file name should contain the package name"
(let ((pkg (dummy-package "x"
(version "3.2.1")
(source
(origin
(method git-fetch)
(uri (git-reference
(url "http://www.example.com/x.git")
(commit "0")))
(sha256 %null-sha256))))))
(single-lint-warning-message
(check-source-file-name pkg))))
(test-equal "source-file-name: good checkout"
'()
(let ((pkg (dummy-package "x"
(version "3.2.1")
(source
(origin
(method git-fetch)
(uri (git-reference
(url "http://git.example.com/x.git")
(commit "0")))
(file-name (string-append "x-" version))
(sha256 %null-sha256))))))
(check-source-file-name pkg)))
(test-equal "source-file-name: valid"
'()
(let ((pkg (dummy-package "x"
(version "3.2.1")
(source
(origin
(method url-fetch)
(uri "http://www.example.com/x-3.2.1.tar.gz")
(sha256 %null-sha256))))))
(check-source-file-name pkg)))
(test-equal "source-unstable-tarball"
"the source URI should not be an autogenerated tarball"
(let ((pkg (dummy-package "x"
(source
(origin
(method url-fetch)
(uri "https://github.com/example/example/archive/v0.0.tar.gz")
(sha256 %null-sha256))))))
(single-lint-warning-message
(check-source-unstable-tarball pkg))))
(test-equal "source-unstable-tarball: source #f"
'()
(let ((pkg (dummy-package "x"
(source #f))))
(check-source-unstable-tarball pkg)))
(test-equal "source-unstable-tarball: valid"
'()
(let ((pkg (dummy-package "x"
(source
(origin
(method url-fetch)
(uri "https://github.com/example/example/releases/download/x-0.0/x-0.0.tar.gz")
(sha256 %null-sha256))))))
(check-source-unstable-tarball pkg)))
(test-equal "source-unstable-tarball: package named archive"
'()
(let ((pkg (dummy-package "x"
(source
(origin
(method url-fetch)
(uri "https://github.com/example/archive/releases/download/x-0.0/x-0.0.tar.gz")
(sha256 %null-sha256))))))
(check-source-unstable-tarball pkg)))
(test-equal "source-unstable-tarball: not-github"
'()
(let ((pkg (dummy-package "x"
(source
(origin
(method url-fetch)
(uri "https://bitbucket.org/archive/example/download/x-0.0.tar.gz")
(sha256 %null-sha256))))))
(check-source-unstable-tarball pkg)))
(test-equal "source-unstable-tarball: git-fetch"
'()
(let ((pkg (dummy-package "x"
(source
(origin
(method git-fetch)
(uri (git-reference
(url "https://github.com/archive/example.git")
(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
(let ((pkg (package
(inherit (dummy-package "x"))
(source (origin
(method url-fetch)
(uri (%local-url))
(sha256 %null-sha256))))))
(check-source pkg))))
(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."
(let ((pkg (package
(inherit (dummy-package "x"))
(source (origin
(method url-fetch)
(uri (%local-url))
(sha256 %null-sha256))))))
(match (check-source pkg)
((first-warning ; All source URIs are unreachable
(and (? lint-warning?) second-warning))
(lint-warning-message second-warning))))))
(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
(let ((pkg (package
(inherit (dummy-package "x"))
(source (origin
(method url-fetch)
(uri (%local-url))
(sha256 %null-sha256))))))
(match (check-source pkg)
((first-warning ; All source URIs are unreachable
(and (? lint-warning?) second-warning))
(lint-warning-message second-warning))))))
(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)))
(parameterize ((%http-server-port (+ 1 (%http-server-port))))
(with-http-server (301 `((location . ,(string->uri initial-url))))
""
(let ((pkg (package
(inherit (dummy-package "x"))
(source (origin
(method url-fetch)
(uri (%local-url))
(sha256 %null-sha256))))))
(match (check-source pkg)
((first-warning ; All source URIs are unreachable
(and (? lint-warning?) second-warning))
(lint-warning-message second-warning)))))))))
(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)))
(parameterize ((%http-server-port (+ 1 (%http-server-port))))
(with-http-server (301 `((location . ,(string->uri initial-url))))
""
(let ((pkg (package
(inherit (dummy-package "x"))
(source (origin
(method url-fetch)
(uri (%local-url))
(sha256 %null-sha256))))))
(match (check-source pkg)
((first-warning ; The first warning says that all URI's are
; unreachable
(and (? lint-warning?) second-warning))
(lint-warning-message second-warning)))))))))
(test-equal "mirror-url"
'()
(let ((source (origin
(method url-fetch)
(uri "http://example.org/foo/bar.tar.gz")
(sha256 %null-sha256))))
(check-mirror-url (dummy-package "x" (source source)))))
(test-equal "mirror-url: one suggestion"
"URL should be 'mirror://gnu/foo/foo.tar.gz'"
(let ((source (origin
(method url-fetch)
(uri "http://ftp.gnu.org/pub/gnu/foo/foo.tar.gz")
(sha256 %null-sha256))))
(single-lint-warning-message
(check-mirror-url (dummy-package "x" (source source))))))
(test-equal "github-url"
'()
(with-http-server 200 %long-string
(check-github-url
(dummy-package "x" (source
(origin
(method url-fetch)
(uri (%local-url))
(sha256 %null-sha256)))))))
(let ((github-url "https://github.com/foo/bar/bar-1.0.tar.gz"))
(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)))))))))))
(test-equal "github-url: already the correct github url"
'()
(check-github-url
(dummy-package "x" (source
(origin
(method url-fetch)
(uri github-url)
(sha256 %null-sha256)))))))
(test-equal "cve"
'()
(mock ((guix scripts 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
(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"))))))
(test-equal "cve: one patched vulnerability"
'()
(mock ((guix scripts lint) package-vulnerabilities
(lambda (package)
(list (make-struct (@@ (guix cve) <vulnerability>) 0
"CVE-2015-1234"
(list (cons (package-name package)
(package-version package)))))))
(check-vulnerabilities
(dummy-package "pi"
(version "3.14")
(source
(dummy-origin
(patches
(list "/a/b/pi-CVE-2015-1234.patch"))))))))
(test-equal "cve: known safe from vulnerability"
'()
(mock ((guix scripts lint) package-vulnerabilities
(lambda (package)
(list (make-struct (@@ (guix cve) <vulnerability>) 0
"CVE-2015-1234"
(list (cons (package-name package)
(package-version package)))))))
(check-vulnerabilities
(dummy-package "pi"
(version "3.14")
(properties `((lint-hidden-cve . ("CVE-2015-1234"))))))))
(test-equal "cve: vulnerability fixed in replacement version"
'()
(mock ((guix scripts 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))))))
("1"
'()))))
(check-vulnerabilities
(dummy-package
"foo" (version "0")
(replacement (dummy-package "foo" (version "1")))))))
(test-equal "cve: patched vulnerability in replacement"
'()
(mock ((guix scripts lint) package-vulnerabilities
(lambda (package)
(list (make-struct (@@ (guix cve) <vulnerability>) 0
"CVE-2015-1234"
(list (cons (package-name package)
(package-version package)))))))
(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-equal "formatting: lonely parentheses"
"parentheses feel lonely, move to the previous or next line"
(single-lint-warning-message
(check-formatting
(dummy-package "ugly as hell!"
)
)))
(test-assert "formatting: tabulation"
(string-match-or-error
"tabulation on line [0-9]+, column [0-9]+"
(single-lint-warning-message
(check-formatting (dummy-package "leave the tab here: ")))))
(test-assert "formatting: trailing white space"
(string-match-or-error
"trailing white space .*"
;; Leave the trailing white space on the next line!
(single-lint-warning-message
(check-formatting (dummy-package "x")))))
(test-assert "formatting: long line"
(string-match-or-error
"line [0-9]+ is way too long \\([0-9]+ characters\\)"
(single-lint-warning-message (check-formatting
(dummy-package "x")) ;here is a stupid comment just to make a long line
)))
(test-equal "formatting: alright"
'()
(check-formatting (dummy-package "x")))
(test-end "lint")
;; Local Variables:
;; eval: (put 'with-http-server 'scheme-indent-function 2)
;; eval: (put 'with-warnings 'scheme-indent-function 0)
;; End:
Reference in a new issue View git blame Copy permalink