nixo
/
guix-devel
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

scripts: lint: Handle warnings with a record type. 

Rather than emiting warnings directly to a port, have the checkers return the
warning or warnings.

This makes it easier to use the warnings in different ways, for example,
loading the data in to a database, as you can work with the <lint-warning>
records directly, rather than having to parse the output to determine the
package and location.

* guix/scripts/lint.scm (<lint-warning>): New record type.
(lint-warning): New macro.
(lint-warning?, lint-warning-package, lint-warning-message,
lint-warning-location, package-file, make-warning): New procedures.
(call-with-accumulated-warnings, with-accumulated-warnings): Remove.
(emit-warning): Rename to emit-warnings, and switch to displaying multiple
warnings.
(check-description-style)[check-not-empty-description, check-texinfo-markup,
check-trademarks, check-quotes, check-proper-start,
check-end-of-sentence-space]: Switch to generating a list of warnings, and
using make-warning, rather than emit-warning.
(check-inputs-should-be-native, check-inputs-should-not-be-an-input-at-all):
Switch to generating a list of warnings, and using make-warning, rather than
emit-warning.
(check-synopsis): Switch to generating a list of warnings, and using
make-warning, rather than emit-warning.
[check-not-empty]: Remove, this is handled in the match clause
to avoid other warnings being emitted.
[check-final-period, check-start-article, check-synopsis-length,
check-proper-start, check-start-with-package-name, check-texinfo-markup]:
Switch to generating a list of warnings, and using make-warning, rather than
emit-warning.
[checks]: Remove check-not-empty.
(validate-uri, check-home-page, check-patch-file-names,
check-gnu-synopsis+description): Switch to generating a list of warnings, and
using make-warning, rather than emit-warning.
(check-source): Switch to generating a list of warnings, and using
make-warning, rather than emit-warning.
[try-uris]: Remove.
[warnings-for-uris]: New procedure, replacing try-uris.
(check-source-file-name, check-source-unstable-tarball, check-mirror-url,
check-github-url, check-derivation, check-vulnerabilities, check-for-updates,
report-tabulations, report-trailing-white-space, report-long-line,
report-lone-parentheses, report-formatting-issues, check-formatting): Switch
to generating a list of warnings, and using make-warning, rather than
emit-warning.
(run-checkers): Call emit-warnings on the warnings returned from the checker.
* tests/lint.scm (string-match-or-error, single-lint-warning-message): New
procedures.
(call-with-warnings, with-warnings): Remove.
("description: not a string", "description: not empty", "description: invalid
Texinfo markup", "description: does not start with an upper-case letter",
"description: may start with a digit", "description: may start with lower-case
package name", "description: two spaces after end of sentence", "description:
end-of-sentence detection with abbreviations", "description: may not contain
trademark signs: ™", "description: may not contain trademark signs: ®",
"description: suggest ornament instead of quotes", "synopsis: not a string",
"synopsis: not empty", "synopsis: valid Texinfo markup", "synopsis: does not
start with an upper-case letter", "synopsis: may start with a digit",
"synopsis: ends with a period", "synopsis: ends with 'etc.'", "synopsis:
starts with 'A'", "synopsis: starts with 'a'", "synopsis: starts with 'an'",
"synopsis: too long", "synopsis: start with package name", "synopsis: start
with package name prefix", "synopsis: start with abbreviation", "inputs:
pkg-config is probably a native input", "inputs: glib:bin is probably a native
input", "inputs: python-setuptools should not be an input at all (input)",
"inputs: python-setuptools should not be an input at all (native-input)",
"inputs: python-setuptools should not be an input at all (propagated-input)",
"patches: file names", "patches: file name too long", "patches: not found",
"derivation: invalid arguments", "license: invalid license", "home-page: wrong
home-page", "home-page: invalid URI", "home-page: host not found", "home-page:
Connection refused", "home-page: 200", "home-page: 200 but short length",
"home-page: 404", "home-page: 301, invalid", "home-page: 301 -> 200",
"home-page: 301 -> 404", "source-file-name", "source-file-name: v prefix",
"source-file-name: bad checkout", "source-file-name: good checkout",
"source-file-name: valid", "source-unstable-tarball",
"source-unstable-tarball: source #f", "source-unstable-tarball: valid",
"source-unstable-tarball: package named archive", "source-unstable-tarball:
not-github", "source-unstable-tarball: git-fetch", "source: 200", "source: 200
but short length", "source: 404", "source: 301 -> 200", "source: 301 -> 404",
"mirror-url", "mirror-url: one suggestion", "github-url", "github-url: one
suggestion", "github-url: already the correct github url", "cve", "cve: one
vulnerability", "cve: one patched vulnerability", "cve: known safe from
vulnerability", "cve: vulnerability fixed in replacement version", "cve:
patched vulnerability in replacement", "formatting: lonely parentheses",
"formatting: alright"): Change test-assert to test-equal, and adjust to work
with the changes above.
("formatting: tabulation", "formatting: trailing white space", "formatting:
long line"): Use string-match-or-error rather than string-contains.
This commit is contained in:
Christopher Baines 2019-05-06 19:00:58 +01:00
parent 5b524f448c
commit 50fc2384fe
No known key found for this signature in database
GPG Key ID: 5E28A33B0B84F577
2 changed files with 1042 additions and 1048 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

523
guix/scripts/lint.scm
View File

@ -84,6 +84,12 @@
check-formatting check-formatting
run-checkers run-checkers
lint-warning
lint-warning?
lint-warning-package
lint-warning-message
lint-warning-location
%checkers %checkers
lint-checker lint-checker
lint-checker? lint-checker?
@ -93,42 +99,48 @@
;;; ;;;
;;; Helpers ;;; Warnings
;;; ;;;
(define* (emit-warning package message #:optional field)
(define-record-type* <lint-warning>
lint-warning make-lint-warning
lint-warning?
(package lint-warning-package)
(message lint-warning-message)
(location lint-warning-location
(default #f)))
(define (package-file package)
(location-file
(package-location package)))
(define* (make-warning package message
#:key field location)
(make-lint-warning
package
message
(or location
(package-field-location package field)
(package-location package))))
(define (emit-warnings warnings)
;; Emit a warning about PACKAGE, printing the location of FIELD if it is ;; Emit a warning about PACKAGE, printing the location of FIELD if it is
;; given, the location of PACKAGE otherwise, the full name of PACKAGE and the ;; given, the location of PACKAGE otherwise, the full name of PACKAGE and the
;; provided MESSAGE. ;; provided MESSAGE.
(let ((loc (or (package-field-location package field) (for-each
(package-location package)))) (match-lambda
(($ <lint-warning> package message loc)
(format (guix-warning-port) "~a: ~a@~a: ~a~%" (format (guix-warning-port) "~a: ~a@~a: ~a~%"
(location->string loc) (location->string loc)
(package-name package) (package-version package) (package-name package) (package-version package)
message))) message)))
warnings))
(define (call-with-accumulated-warnings thunk)
"Call THUNK, accumulating any warnings in the current state, using the state
monad."
(let ((port (open-output-string)))
(mlet %state-monad ((state (current-state))
(result -> (parameterize ((guix-warning-port port))
(thunk)))
(warning -> (get-output-string port)))
(mbegin %state-monad
(munless (string=? "" warning)
(set-current-state (cons warning state)))
(return result)))))
(define-syntax-rule (with-accumulated-warnings exp ...)
"Evaluate EXP and accumulate warnings in the state monad."
(call-with-accumulated-warnings
(lambda ()
exp ...)))
;;; ;;;
;;; Checkers ;;; Checkers
;;; ;;;
(define-record-type* <lint-checker> (define-record-type* <lint-checker>
lint-checker make-lint-checker lint-checker make-lint-checker
lint-checker? lint-checker?
@ -163,10 +175,12 @@ monad."
(define (check-description-style package) (define (check-description-style package)
;; Emit a warning if stylistic issues are found in the description of PACKAGE. ;; Emit a warning if stylistic issues are found in the description of PACKAGE.
(define (check-not-empty description) (define (check-not-empty description)
(when (string-null? description) (if (string-null? description)
(emit-warning package (list
(make-warning package
(G_ "description should not be empty") (G_ "description should not be empty")
'description))) #:field 'description))
'()))
(define (check-texinfo-markup description) (define (check-texinfo-markup description)
"Check that DESCRIPTION can be parsed as a Texinfo fragment. If the "Check that DESCRIPTION can be parsed as a Texinfo fragment. If the
@ -174,39 +188,44 @@ markup is valid return a plain-text version of DESCRIPTION, otherwise #f."
(catch #t (catch #t
(lambda () (texi->plain-text description)) (lambda () (texi->plain-text description))
(lambda (keys . args) (lambda (keys . args)
(emit-warning package (make-warning package
(G_ "Texinfo markup in description is invalid") (G_ "Texinfo markup in description is invalid")
'description) #:field 'description))))
#f)))
(define (check-trademarks description) (define (check-trademarks description)
"Check that DESCRIPTION does not contain '™' or '®' characters. See "Check that DESCRIPTION does not contain '™' or '®' characters. See
http://www.gnu.org/prep/standards/html_node/Trademarks.html." http://www.gnu.org/prep/standards/html_node/Trademarks.html."
(match (string-index description (char-set #\™ #\®)) (match (string-index description (char-set #\™ #\®))
((and (? number?) index) ((and (? number?) index)
(emit-warning package (list
(make-warning package
(format #f (G_ "description should not contain ~ (format #f (G_ "description should not contain ~
trademark sign '~a' at ~d") trademark sign '~a' at ~d")
(string-ref description index) index) (string-ref description index) index)
'description)) #:field 'description)))
(else #t))) (else '())))
(define (check-quotes description) (define (check-quotes description)
"Check whether DESCRIPTION contains single quotes and suggest @code." "Check whether DESCRIPTION contains single quotes and suggest @code."
(when (regexp-exec %quoted-identifier-rx description) (if (regexp-exec %quoted-identifier-rx description)
(emit-warning package (list
(make-warning package
;; TRANSLATORS: '@code' is Texinfo markup and must be kept ;; TRANSLATORS: '@code' is Texinfo markup and must be kept
;; as is. ;; as is.
(G_ "use @code or similar ornament instead of quotes") (G_ "use @code or similar ornament instead of quotes")
'description))) #:field 'description))
'()))
(define (check-proper-start description) (define (check-proper-start description)
(unless (or (properly-starts-sentence? description) (if (or (string-null? description)
(properly-starts-sentence? description)
(string-prefix-ci? (package-name package) description)) (string-prefix-ci? (package-name package) description))
(emit-warning package '()
(list
(make-warning
package
(G_ "description should start with an upper-case letter or digit") (G_ "description should start with an upper-case letter or digit")
'description))) #:field 'description))))
(define (check-end-of-sentence-space description) (define (check-end-of-sentence-space description)
"Check that an end-of-sentence period is followed by two spaces." "Check that an end-of-sentence period is followed by two spaces."
@ -219,28 +238,33 @@ trademark sign '~a' at ~d")
(string-suffix-ci? s (match:prefix m))) (string-suffix-ci? s (match:prefix m)))
'("i.e" "e.g" "a.k.a" "resp")) '("i.e" "e.g" "a.k.a" "resp"))
r (cons (match:start m) r))))))) r (cons (match:start m) r)))))))
(unless (null? infractions) (if (null? infractions)
(emit-warning package '()
(list
(make-warning package
(format #f (G_ "sentences in description should be followed ~ (format #f (G_ "sentences in description should be followed ~
by two spaces; possible infraction~p at ~{~a~^, ~}") by two spaces; possible infraction~p at ~{~a~^, ~}")
(length infractions) (length infractions)
infractions) infractions)
'description)))) #:field 'description)))))
(let ((description (package-description package))) (let ((description (package-description package)))
(if (string? description) (if (string? description)
(begin (append
(check-not-empty description) (check-not-empty description)
(check-quotes description) (check-quotes description)
(check-trademarks description) (check-trademarks description)
;; Use raw description for this because Texinfo rendering ;; Use raw description for this because Texinfo rendering
;; automatically fixes end of sentence space. ;; automatically fixes end of sentence space.
(check-end-of-sentence-space description) (check-end-of-sentence-space description)
(and=> (check-texinfo-markup description) (match (check-texinfo-markup description)
check-proper-start)) ((and warning (? lint-warning?)) (list warning))
(emit-warning package (plain-description
(check-proper-start plain-description))))
(list
(make-warning package
(format #f (G_ "invalid description: ~s") description) (format #f (G_ "invalid description: ~s") description)
'description)))) #:field 'description)))))
(define (package-input-intersection inputs-to-check input-names) (define (package-input-intersection inputs-to-check input-names)
"Return the intersection between INPUTS-TO-CHECK, the list of input tuples "Return the intersection between INPUTS-TO-CHECK, the list of input tuples
@ -281,12 +305,12 @@ of a package, and INPUT-NAMES, a list of package specifications such as
"python-pytest-cov" "python2-pytest-cov" "python-pytest-cov" "python2-pytest-cov"
"python-setuptools-scm" "python2-setuptools-scm" "python-setuptools-scm" "python2-setuptools-scm"
"python-sphinx" "python2-sphinx"))) "python-sphinx" "python2-sphinx")))
(for-each (lambda (input) (map (lambda (input)
(emit-warning (make-warning
package package
(format #f (G_ "'~a' should probably be a native input") (format #f (G_ "'~a' should probably be a native input")
input) input)
'inputs-to-check)) #:field 'inputs))
(package-input-intersection inputs input-names)))) (package-input-intersection inputs input-names))))
(define (check-inputs-should-not-be-an-input-at-all package) (define (check-inputs-should-not-be-an-input-at-all package)
@ -296,12 +320,13 @@ of a package, and INPUT-NAMES, a list of package specifications such as
"python2-setuptools" "python2-setuptools"
"python-pip" "python-pip"
"python2-pip"))) "python2-pip")))
(for-each (lambda (input) (map (lambda (input)
(emit-warning (make-warning
package package
(format #f (format #f
(G_ "'~a' should probably not be an input at all") (G_ "'~a' should probably not be an input at all")
input))) input)
#:field 'inputs))
(package-input-intersection (package-direct-inputs package) (package-input-intersection (package-direct-inputs package)
input-names)))) input-names))))
@ -314,66 +339,71 @@ line."
(define (check-synopsis-style package) (define (check-synopsis-style package)
;; Emit a warning if stylistic issues are found in the synopsis of PACKAGE. ;; Emit a warning if stylistic issues are found in the synopsis of PACKAGE.
(define (check-not-empty synopsis)
(when (string-null? synopsis)
(emit-warning package
(G_ "synopsis should not be empty")
'synopsis)))
(define (check-final-period synopsis) (define (check-final-period synopsis)
;; Synopsis should not end with a period, except for some special cases. ;; Synopsis should not end with a period, except for some special cases.
(when (and (string-suffix? "." synopsis) (if (and (string-suffix? "." synopsis)
(not (string-suffix? "etc." synopsis))) (not (string-suffix? "etc." synopsis)))
(emit-warning package (list
(make-warning package
(G_ "no period allowed at the end of the synopsis") (G_ "no period allowed at the end of the synopsis")
'synopsis))) #:field 'synopsis))
'()))
(define check-start-article (define check-start-article
;; Skip this check for GNU packages, as suggested by Karl Berry's reply to ;; Skip this check for GNU packages, as suggested by Karl Berry's reply to
;; <http://lists.gnu.org/archive/html/bug-womb/2014-11/msg00000.html>. ;; <http://lists.gnu.org/archive/html/bug-womb/2014-11/msg00000.html>.
(if (false-if-exception (gnu-package? package)) (if (false-if-exception (gnu-package? package))
(const #t) (const '())
(lambda (synopsis) (lambda (synopsis)
(when (or (string-prefix-ci? "A " synopsis) (if (or (string-prefix-ci? "A " synopsis)
(string-prefix-ci? "An " synopsis)) (string-prefix-ci? "An " synopsis))
(emit-warning package (list
(make-warning package
(G_ "no article allowed at the beginning of \ (G_ "no article allowed at the beginning of \
the synopsis") the synopsis")
'synopsis))))) #:field 'synopsis))
'()))))
(define (check-synopsis-length synopsis) (define (check-synopsis-length synopsis)
(when (>= (string-length synopsis) 80) (if (>= (string-length synopsis) 80)
(emit-warning package (list
(make-warning package
(G_ "synopsis should be less than 80 characters long") (G_ "synopsis should be less than 80 characters long")
'synopsis))) #:field 'synopsis))
'()))
(define (check-proper-start synopsis) (define (check-proper-start synopsis)
(unless (properly-starts-sentence? synopsis) (if (properly-starts-sentence? synopsis)
(emit-warning package '()
(list
(make-warning package
(G_ "synopsis should start with an upper-case letter or digit") (G_ "synopsis should start with an upper-case letter or digit")
'synopsis))) #:field 'synopsis))))
(define (check-start-with-package-name synopsis) (define (check-start-with-package-name synopsis)
(when (and (regexp-exec (package-name-regexp package) synopsis) (if (and (regexp-exec (package-name-regexp package) synopsis)
(not (starts-with-abbreviation? synopsis))) (not (starts-with-abbreviation? synopsis)))
(emit-warning package (list
(make-warning package
(G_ "synopsis should not start with the package name") (G_ "synopsis should not start with the package name")
'synopsis))) #:field 'synopsis))
'()))
(define (check-texinfo-markup synopsis) (define (check-texinfo-markup synopsis)
"Check that SYNOPSIS can be parsed as a Texinfo fragment. If the "Check that SYNOPSIS can be parsed as a Texinfo fragment. If the
markup is valid return a plain-text version of SYNOPSIS, otherwise #f." markup is valid return a plain-text version of SYNOPSIS, otherwise #f."
(catch #t (catch #t
(lambda () (texi->plain-text synopsis)) (lambda ()
(texi->plain-text synopsis)
'())
(lambda (keys . args) (lambda (keys . args)
(emit-warning package (list
(make-warning package
(G_ "Texinfo markup in synopsis is invalid") (G_ "Texinfo markup in synopsis is invalid")
'synopsis) #:field 'synopsis)))))
#f)))
(define checks (define checks
(list check-not-empty (list check-proper-start
check-proper-start
check-final-period check-final-period
check-start-article check-start-article
check-start-with-package-name check-start-with-package-name
@ -381,13 +411,20 @@ markup is valid return a plain-text version of SYNOPSIS, otherwise #f."
check-texinfo-markup)) check-texinfo-markup))
(match (package-synopsis package) (match (package-synopsis package)
(""
(list
(make-warning package
(G_ "synopsis should not be empty")
#:field 'synopsis)))
((? string? synopsis) ((? string? synopsis)
(for-each (lambda (proc) (append-map
(lambda (proc)
(proc synopsis)) (proc synopsis))
checks)) checks))
(invalid (invalid
(emit-warning package (format #f (G_ "invalid synopsis: ~s") invalid) (list
'synopsis)))) (make-warning package (format #f (G_ "invalid synopsis: ~s") invalid)
#:field 'synopsis)))))
(define* (probe-uri uri #:key timeout) (define* (probe-uri uri #:key timeout)
"Probe URI, a URI object, and return two values: a symbol denoting the "Probe URI, a URI object, and return two values: a symbol denoting the
@ -489,8 +526,8 @@ for connections to complete; when TIMEOUT is #f, wait as long as needed."
'tls-certificate-error args)))) 'tls-certificate-error args))))
(define (validate-uri uri package field) (define (validate-uri uri package field)
"Return #t if the given URI can be reached, otherwise return #f and emit a "Return #t if the given URI can be reached, otherwise return a warning for
warning for PACKAGE mentionning the FIELD." PACKAGE mentionning the FIELD."
(let-values (((status argument) (let-values (((status argument)
(probe-uri uri #:timeout 3))) ;wait at most 3 seconds (probe-uri uri #:timeout 3))) ;wait at most 3 seconds
(case status (case status
@ -502,71 +539,66 @@ warning for PACKAGE mentionning the FIELD."
;; with a small HTML page upon failure. Attempt to detect ;; with a small HTML page upon failure. Attempt to detect
;; such malicious behavior. ;; such malicious behavior.
(or (> length 1000) (or (> length 1000)
(begin (make-warning package
(emit-warning package
(format #f (format #f
(G_ "URI ~a returned \ (G_ "URI ~a returned \
suspiciously small file (~a bytes)") suspiciously small file (~a bytes)")
(uri->string uri) (uri->string uri)
length)) length)
#f))) #:field field)))
(_ #t))) (_ #t)))
((= 301 (response-code argument)) ((= 301 (response-code argument))
(if (response-location argument) (if (response-location argument)
(begin (make-warning package
(emit-warning package
(format #f (G_ "permanent redirect from ~a to ~a") (format #f (G_ "permanent redirect from ~a to ~a")
(uri->string uri) (uri->string uri)
(uri->string (uri->string
(response-location argument)))) (response-location argument)))
#t) #:field field)
(begin (make-warning package
(emit-warning package
(format #f (G_ "invalid permanent redirect \ (format #f (G_ "invalid permanent redirect \
from ~a") from ~a")
(uri->string uri))) (uri->string uri))
#f))) #:field field)))
(else (else
(emit-warning package (make-warning package
(format #f (format #f
(G_ "URI ~a not reachable: ~a (~s)") (G_ "URI ~a not reachable: ~a (~s)")
(uri->string uri) (uri->string uri)
(response-code argument) (response-code argument)
(response-reason-phrase argument)) (response-reason-phrase argument))
field) #:field field))))
#f)))
((ftp-response) ((ftp-response)
(match argument (match argument
(('ok) #t) (('ok) #t)
(('error port command code message) (('error port command code message)
(emit-warning package (make-warning package
(format #f (format #f
(G_ "URI ~a not reachable: ~a (~s)") (G_ "URI ~a not reachable: ~a (~s)")
(uri->string uri) (uri->string uri)
code (string-trim-both message))) code (string-trim-both message))
#f))) #:field field))))
((getaddrinfo-error) ((getaddrinfo-error)
(emit-warning package (make-warning package
(format #f (format #f
(G_ "URI ~a domain not found: ~a") (G_ "URI ~a domain not found: ~a")
(uri->string uri) (uri->string uri)
(gai-strerror (car argument))) (gai-strerror (car argument)))
field) #:field field))
#f)
((system-error) ((system-error)
(emit-warning package (make-warning package
(format #f (format #f
(G_ "URI ~a unreachable: ~a") (G_ "URI ~a unreachable: ~a")
(uri->string uri) (uri->string uri)
(strerror (strerror
(system-error-errno (system-error-errno
(cons status argument)))) (cons status argument))))
field) #:field field))
#f)
((tls-certificate-error) ((tls-certificate-error)
(emit-warning package (make-warning package
(format #f (G_ "TLS certificate error: ~a") (format #f (G_ "TLS certificate error: ~a")
(tls-certificate-error-string argument)))) (tls-certificate-error-string argument))
#:field field))
((invalid-http-response gnutls-error) ((invalid-http-response gnutls-error)
;; Probably a misbehaving server; ignore. ;; Probably a misbehaving server; ignore.
#f) #f)
@ -581,17 +613,23 @@ from ~a")
(let ((uri (and=> (package-home-page package) string->uri))) (let ((uri (and=> (package-home-page package) string->uri)))
(cond (cond
((uri? uri) ((uri? uri)
(validate-uri uri package 'home-page)) (match (validate-uri uri package 'home-page)
((and (? lint-warning? warning) warning)
(list warning))
(_ '())))
((not (package-home-page package)) ((not (package-home-page package))
(unless (or (string-contains (package-name package) "bootstrap") (if (or (string-contains (package-name package) "bootstrap")
(string=? (package-name package) "ld-wrapper")) (string=? (package-name package) "ld-wrapper"))
(emit-warning package '()
(list
(make-warning package
(G_ "invalid value for home page") (G_ "invalid value for home page")
'home-page))) #:field 'home-page))))
(else (else
(emit-warning package (format #f (G_ "invalid home page URL: ~s") (list
(make-warning package (format #f (G_ "invalid home page URL: ~s")
(package-home-page package)) (package-home-page package))
'home-page))))) #:field 'home-page))))))
(define %distro-directory (define %distro-directory
(mlambda () (mlambda ()
@ -601,42 +639,47 @@ from ~a")
"Emit a warning if the patches requires by PACKAGE are badly named or if the "Emit a warning if the patches requires by PACKAGE are badly named or if the
patch could not be found." patch could not be found."
(guard (c ((message-condition? c) ;raised by 'search-patch' (guard (c ((message-condition? c) ;raised by 'search-patch'
(emit-warning package (condition-message c) (list
'patch-file-names))) (make-warning package (condition-message c)
#:field 'patch-file-names))))
(define patches (define patches
(or (and=> (package-source package) origin-patches) (or (and=> (package-source package) origin-patches)
'())) '()))
(unless (every (match-lambda ;patch starts with package name? (append
(if (every (match-lambda ;patch starts with package name?
((? string? patch) ((? string? patch)
(and=> (string-contains (basename patch) (and=> (string-contains (basename patch)
(package-name package)) (package-name package))
zero?)) zero?))
(_ #f)) ;must be an <origin> or something like that. (_ #f)) ;must be an <origin> or something like that.
patches) patches)
(emit-warning '()
(list
(make-warning
package package
(G_ "file names of patches should start with the package name") (G_ "file names of patches should start with the package name")
'patch-file-names)) #:field 'patch-file-names)))
;; Check whether we're reaching tar's maximum file name length. ;; Check whether we're reaching tar's maximum file name length.
(let ((prefix (string-length (%distro-directory))) (let ((prefix (string-length (%distro-directory)))
(margin (string-length "guix-0.13.0-10-123456789/")) (margin (string-length "guix-0.13.0-10-123456789/"))
(max 99)) (max 99))
(for-each (match-lambda (filter-map (match-lambda
((? string? patch) ((? string? patch)
(when (> (+ margin (if (string-prefix? (%distro-directory) (if (> (+ margin (if (string-prefix? (%distro-directory)
patch) patch)
(- (string-length patch) prefix) (- (string-length patch) prefix)
(string-length patch))) (string-length patch)))
max) max)
(emit-warning (make-warning
package package
(format #f (G_ "~a: file name is too long") (format #f (G_ "~a: file name is too long")
(basename patch)) (basename patch))
'patch-file-names))) #:field 'patch-file-names)
#f))
(_ #f)) (_ #f))
patches)))) patches)))))
(define (escape-quotes str) (define (escape-quotes str)
"Replace any quote character in STR by an escaped quote character." "Replace any quote character in STR by an escaped quote character."
@ -663,32 +706,35 @@ descriptions maintained upstream."
(package-name package))) (package-name package)))
(official-gnu-packages*)) (official-gnu-packages*))
(#f ;not a GNU package, so nothing to do (#f ;not a GNU package, so nothing to do
#t) '())
(descriptor ;a genuine GNU package (descriptor ;a genuine GNU package
(append
(let ((upstream (gnu-package-doc-summary descriptor)) (let ((upstream (gnu-package-doc-summary descriptor))
(downstream (package-synopsis package)) (downstream (package-synopsis package)))
(loc (or (package-field-location package 'synopsis) (if (and upstream
(package-location package))))
(when (and upstream
(or (not (string? downstream)) (or (not (string? downstream))
(not (string=? upstream downstream)))) (not (string=? upstream downstream))))
(format (guix-warning-port) (list
(G_ "~a: ~a: proposed synopsis: ~s~%") (make-warning package
(location->string loc) (package-full-name package) (format #f (G_ "proposed synopsis: ~s~%")
upstream))) upstream)
#:field 'synopsis))
'()))
(let ((upstream (gnu-package-doc-description descriptor)) (let ((upstream (gnu-package-doc-description descriptor))
(downstream (package-description package)) (downstream (package-description package)))
(loc (or (package-field-location package 'description) (if (and upstream
(package-location package))))
(when (and upstream
(or (not (string? downstream)) (or (not (string? downstream))
(not (string=? (fill-paragraph upstream 100) (not (string=? (fill-paragraph upstream 100)
(fill-paragraph downstream 100))))) (fill-paragraph downstream 100)))))
(format (guix-warning-port) (list
(G_ "~a: ~a: proposed description:~% \"~a\"~%") (make-warning
(location->string loc) (package-full-name package) package
(fill-paragraph (escape-quotes upstream) 77 7))))))) (format #f
(G_ "proposed description:~% \"~a\"~%")
(fill-paragraph (escape-quotes upstream) 77 7))
#:field 'description))
'()))))))
(define (origin-uris origin) (define (origin-uris origin)
"Return the list of URIs (strings) for ORIGIN." "Return the list of URIs (strings) for ORIGIN."
@ -701,38 +747,35 @@ descriptions maintained upstream."
(define (check-source package) (define (check-source package)
"Emit a warning if PACKAGE has an invalid 'source' field, or if that "Emit a warning if PACKAGE has an invalid 'source' field, or if that
'source' is not reachable." 'source' is not reachable."
(define (try-uris uris) (define (warnings-for-uris uris)
(run-with-state (filter lint-warning?
(anym %state-monad (map
(lambda (uri) (lambda (uri)
(with-accumulated-warnings (validate-uri uri package 'source))
(validate-uri uri package 'source)))
(append-map (cut maybe-expand-mirrors <> %mirrors) (append-map (cut maybe-expand-mirrors <> %mirrors)
uris)) uris))))
'()))
(let ((origin (package-source package))) (let ((origin (package-source package)))
(when (and origin (if (and origin
(eqv? (origin-method origin) url-fetch)) (eqv? (origin-method origin) url-fetch))
(let ((uris (map string->uri (origin-uris origin)))) (let* ((uris (map string->uri (origin-uris origin)))
(warnings (warnings-for-uris uris)))
;; Just make sure that at least one of the URIs is valid. ;; Just make sure that at least one of the URIs is valid.
(call-with-values (if (eq? (length uris) (length warnings))
(lambda () (try-uris uris))
(lambda (success? warnings)
;; When everything fails, report all of WARNINGS, otherwise don't ;; When everything fails, report all of WARNINGS, otherwise don't
;; report anything. ;; report anything.
;; ;;
;; XXX: Ideally we'd still allow warnings to be raised if *some* ;; XXX: Ideally we'd still allow warnings to be raised if *some*
;; URIs are unreachable, but distinguish that from the error case ;; URIs are unreachable, but distinguish that from the error case
;; where *all* the URIs are unreachable. ;; where *all* the URIs are unreachable.
(unless success? (cons*
(emit-warning package (make-warning package
(G_ "all the source URIs are unreachable:") (G_ "all the source URIs are unreachable:")
'source) #:field 'source)
(for-each (lambda (warning) warnings)
(display warning (guix-warning-port))) '()))
(reverse warnings))))))))) '())))
(define (check-source-file-name package) (define (check-source-file-name package)
"Emit a warning if PACKAGE's origin has no meaningful file name." "Emit a warning if PACKAGE's origin has no meaningful file name."
@ -748,27 +791,32 @@ descriptions maintained upstream."
(not (string-match (string-append "^v?" version) file-name))))) (not (string-match (string-append "^v?" version) file-name)))))
(let ((origin (package-source package))) (let ((origin (package-source package)))
(unless (or (not origin) (origin-file-name-valid? origin)) (if (or (not origin) (origin-file-name-valid? origin))
(emit-warning package '()
(list
(make-warning package
(G_ "the source file name should contain the package name") (G_ "the source file name should contain the package name")
'source)))) #:field 'source)))))
(define (check-source-unstable-tarball package) (define (check-source-unstable-tarball package)
"Emit a warning if PACKAGE's source is an autogenerated tarball." "Emit a warning if PACKAGE's source is an autogenerated tarball."
(define (check-source-uri uri) (define (check-source-uri uri)
(when (and (string=? (uri-host (string->uri uri)) "github.com") (if (and (string=? (uri-host (string->uri uri)) "github.com")
(match (split-and-decode-uri-path (match (split-and-decode-uri-path
(uri-path (string->uri uri))) (uri-path (string->uri uri)))
((_ _ "archive" _ ...) #t) ((_ _ "archive" _ ...) #t)
(_ #f))) (_ #f)))
(emit-warning package (make-warning package
(G_ "the source URI should not be an autogenerated tarball") (G_ "the source URI should not be an autogenerated tarball")
'source))) #:field 'source)
#f))
(let ((origin (package-source package))) (let ((origin (package-source package)))
(when (and (origin? origin) (if (and (origin? origin)
(eqv? (origin-method origin) url-fetch)) (eqv? (origin-method origin) url-fetch))
(let ((uris (origin-uris origin))) (filter-map check-source-uri
(for-each check-source-uri uris))))) (origin-uris origin))
'())))
(define (check-mirror-url package) (define (check-mirror-url package)
"Check whether PACKAGE uses source URLs that should be 'mirror://'." "Check whether PACKAGE uses source URLs that should be 'mirror://'."
@ -776,24 +824,25 @@ descriptions maintained upstream."
(let loop ((mirrors %mirrors)) (let loop ((mirrors %mirrors))
(match mirrors (match mirrors
(() (()
#t) #f)
(((mirror-id mirror-urls ...) rest ...) (((mirror-id mirror-urls ...) rest ...)
(match (find (cut string-prefix? <> uri) mirror-urls) (match (find (cut string-prefix? <> uri) mirror-urls)
(#f (#f
(loop rest)) (loop rest))
(prefix (prefix
(emit-warning package (make-warning package
(format #f (G_ "URL should be \ (format #f (G_ "URL should be \
'mirror://~a/~a'") 'mirror://~a/~a'")
mirror-id mirror-id
(string-drop uri (string-length prefix))) (string-drop uri (string-length prefix)))
'source))))))) #:field 'source)))))))
(let ((origin (package-source package))) (let ((origin (package-source package)))
(when (and (origin? origin) (if (and (origin? origin)
(eqv? (origin-method origin) url-fetch)) (eqv? (origin-method origin) url-fetch))
(let ((uris (origin-uris origin))) (let ((uris (origin-uris origin)))
(for-each check-mirror-uri uris))))) (filter-map check-mirror-uri uris))
'())))
(define* (check-github-url package #:key (timeout 3)) (define* (check-github-url package #:key (timeout 3))
"Check whether PACKAGE uses source URLs that redirect to GitHub." "Check whether PACKAGE uses source URLs that redirect to GitHub."
@ -817,18 +866,20 @@ descriptions maintained upstream."
(else #f))) (else #f)))
(let ((origin (package-source package))) (let ((origin (package-source package)))
(when (and (origin? origin) (if (and (origin? origin)
(eqv? (origin-method origin) url-fetch)) (eqv? (origin-method origin) url-fetch))
(for-each (filter-map
(lambda (uri) (lambda (uri)
(and=> (follow-redirects-to-github uri) (and=> (follow-redirects-to-github uri)
(lambda (github-uri) (lambda (github-uri)
(unless (string=? github-uri uri) (if (string=? github-uri uri)
(emit-warning #f
(make-warning
package package
(format #f (G_ "URL should be '~a'") github-uri) (format #f (G_ "URL should be '~a'") github-uri)
'source))))) #:field 'source)))))
(origin-uris origin))))) (origin-uris origin))
'())))
(define (check-derivation package) (define (check-derivation package)
"Emit a warning if we fail to compile PACKAGE to a derivation." "Emit a warning if we fail to compile PACKAGE to a derivation."
@ -836,12 +887,12 @@ descriptions maintained upstream."
(catch #t (catch #t
(lambda () (lambda ()
(guard (c ((store-protocol-error? c) (guard (c ((store-protocol-error? c)
(emit-warning package (make-warning package
(format #f (G_ "failed to create ~a derivation: ~a") (format #f (G_ "failed to create ~a derivation: ~a")
system system
(store-protocol-error-message c)))) (store-protocol-error-message c))))
((message-condition? c) ((message-condition? c)
(emit-warning package (make-warning package
(format #f (G_ "failed to create ~a derivation: ~a") (format #f (G_ "failed to create ~a derivation: ~a")
system system
(condition-message c))))) (condition-message c)))))
@ -858,21 +909,23 @@ descriptions maintained upstream."
(package-derivation store replacement system (package-derivation store replacement system
#:graft? #f))))))) #:graft? #f)))))))
(lambda args (lambda args
(emit-warning package (make-warning package
(format #f (G_ "failed to create ~a derivation: ~s") (format #f (G_ "failed to create ~a derivation: ~s")
system args))))) system args)))))
(for-each try (package-supported-systems package))) (filter lint-warning?
(map try (package-supported-systems package))))
(define (check-license package) (define (check-license package)
"Warn about type errors of the 'license' field of PACKAGE." "Warn about type errors of the 'license' field of PACKAGE."
(match (package-license package) (match (package-license package)
((or (? license?) ((or (? license?)
((? license?) ...)) ((? license?) ...))
#t) '())
(x (x
(emit-warning package (G_ "invalid license field") (list
'license)))) (make-warning package (G_ "invalid license field")
#:field 'license)))))
(define (call-with-networking-fail-safe message error-value proc) (define (call-with-networking-fail-safe message error-value proc)
"Call PROC catching any network-related errors. Upon a networking error, "Call PROC catching any network-related errors. Upon a networking error,
@ -932,7 +985,7 @@ the NIST server non-fatal."
(let ((package (or (package-replacement package) package))) (let ((package (or (package-replacement package) package)))
(match (package-vulnerabilities package) (match (package-vulnerabilities package)
(() (()
#t) '())
((vulnerabilities ...) ((vulnerabilities ...)
(let* ((patched (package-patched-vulnerabilities package)) (let* ((patched (package-patched-vulnerabilities package))
(known-safe (or (assq-ref (package-properties package) (known-safe (or (assq-ref (package-properties package)
@ -943,11 +996,14 @@ the NIST server non-fatal."
(or (member id patched) (or (member id patched)
(member id known-safe)))) (member id known-safe))))
vulnerabilities))) vulnerabilities)))
(unless (null? unpatched) (if (null? unpatched)
(emit-warning package '()
(list
(make-warning
package
(format #f (G_ "probably vulnerable to ~a") (format #f (G_ "probably vulnerable to ~a")
(string-join (map vulnerability-id unpatched) (string-join (map vulnerability-id unpatched)
", "))))))))) ", "))))))))))
(define (check-for-updates package) (define (check-for-updates package)
"Check if there is an update available for PACKAGE." "Check if there is an update available for PACKAGE."
@ -957,12 +1013,15 @@ the NIST server non-fatal."
#f #f
(package-latest-release* package (force %updaters))) (package-latest-release* package (force %updaters)))
((? upstream-source? source) ((? upstream-source? source)
(when (version>? (upstream-source-version source) (if (version>? (upstream-source-version source)
(package-version package)) (package-version package))
(emit-warning package (list
(make-warning package
(format #f (G_ "can be upgraded to ~a") (format #f (G_ "can be upgraded to ~a")
(upstream-source-version source))))) (upstream-source-version source))
(#f #f))) ; cannot find newer upstream release #:field 'version))
'()))
(#f '()))) ; cannot find newer upstream release
;;; ;;;
@ -974,18 +1033,26 @@ the NIST server non-fatal."
(match (string-index line #\tab) (match (string-index line #\tab)
(#f #t) (#f #t)
(index (index
(emit-warning package (make-warning package
(format #f (G_ "tabulation on line ~a, column ~a") (format #f (G_ "tabulation on line ~a, column ~a")
line-number index))))) line-number index)
#:location
(location (package-file package)
line-number
index)))))
(define (report-trailing-white-space package line line-number) (define (report-trailing-white-space package line line-number)
"Warn about trailing white space in LINE." "Warn about trailing white space in LINE."
(unless (or (string=? line (string-trim-right line)) (unless (or (string=? line (string-trim-right line))
(string=? line (string #\page))) (string=? line (string #\page)))
(emit-warning package (make-warning package
(format #f (format #f
(G_ "trailing white space on line ~a") (G_ "trailing white space on line ~a")
line-number)))) line-number)
#:location
(location (package-file package)
line-number
0))))
(define (report-long-line package line line-number) (define (report-long-line package line line-number)
"Emit a warning if LINE is too long." "Emit a warning if LINE is too long."
@ -993,9 +1060,13 @@ the NIST server non-fatal."
;; make it hard to fit within that limit and we want to avoid making too ;; make it hard to fit within that limit and we want to avoid making too
;; much noise. ;; much noise.
(when (> (string-length line) 90) (when (> (string-length line) 90)
(emit-warning package (make-warning package
(format #f (G_ "line ~a is way too long (~a characters)") (format #f (G_ "line ~a is way too long (~a characters)")
line-number (string-length line))))) line-number (string-length line))
#:location
(location (package-file package)
line-number
0))))
(define %hanging-paren-rx (define %hanging-paren-rx
(make-regexp "^[[:blank:]]*[()]+[[:blank:]]*$")) (make-regexp "^[[:blank:]]*[()]+[[:blank:]]*$"))
@ -1003,11 +1074,15 @@ the NIST server non-fatal."
(define (report-lone-parentheses package line line-number) (define (report-lone-parentheses package line line-number)
"Emit a warning if LINE contains hanging parentheses." "Emit a warning if LINE contains hanging parentheses."
(when (regexp-exec %hanging-paren-rx line) (when (regexp-exec %hanging-paren-rx line)
(emit-warning package (make-warning package
(format #f (format #f
(G_ "line ~a: parentheses feel lonely, \ (G_ "parentheses feel lonely, \
move to the previous or next line") move to the previous or next line")
line-number)))) line-number)
#:location
(location (package-file package)
line-number
0))))
(define %formatting-reporters (define %formatting-reporters
;; List of procedures that report formatting issues. These are not separate ;; List of procedures that report formatting issues. These are not separate
@ -1040,31 +1115,40 @@ them for PACKAGE."
(call-with-input-file file (call-with-input-file file
(lambda (port) (lambda (port)
(let loop ((line-number 1) (let loop ((line-number 1)
(last-line #f)) (last-line #f)
(warnings '()))
(let ((line (read-line port))) (let ((line (read-line port)))
(or (eof-object? line) (if (or (eof-object? line)
(and last-line (> line-number last-line)) (and last-line (> line-number last-line)))
warnings
(if (and (= line-number starting-line) (if (and (= line-number starting-line)
(not last-line)) (not last-line))
(loop (+ 1 line-number) (loop (+ 1 line-number)
(+ 1 (sexp-last-line port))) (+ 1 (sexp-last-line port))
(begin warnings)
(unless (< line-number starting-line) (loop (+ 1 line-number)
(for-each (lambda (report) last-line
(append
warnings
(if (< line-number starting-line)
'()
(filter
lint-warning?
(map (lambda (report)
(report package line line-number)) (report package line line-number))
reporters)) reporters))))))))))))
(loop (+ 1 line-number) last-line)))))))))
(define (check-formatting package) (define (check-formatting package)
"Check the formatting of the source code of PACKAGE." "Check the formatting of the source code of PACKAGE."
(let ((location (package-location package))) (let ((location (package-location package)))
(when location (if location
(and=> (search-path %load-path (location-file location)) (and=> (search-path %load-path (location-file location))
(lambda (file) (lambda (file)
;; Report issues starting from the line before the 'package' ;; Report issues starting from the line before the 'package'
;; form, which usually contains the 'define' form. ;; form, which usually contains the 'define' form.
(report-formatting-issues package file (report-formatting-issues package file
(- (location-line location) 1))))))) (- (location-line location) 1))))
'())))
;;; ;;;
@ -1155,7 +1239,8 @@ or a list thereof")
(package-name package) (package-version package) (package-name package) (package-version package)
(lint-checker-name checker)) (lint-checker-name checker))
(force-output (current-error-port))) (force-output (current-error-port)))
((lint-checker-check checker) package)) (emit-warnings
((lint-checker-check checker) package)))
checkers) checkers)
(when tty? (when tty?
(format (current-error-port) "\x1b[K") (format (current-error-port) "\x1b[K")

753
tests/lint.scm
View File

File diff suppressed because it is too large Load Diff