* [bug#35790] [PATCH] scripts: lint: Handle warnings with a record type.
@ 2019-05-18 9:32 Christopher Baines
2019-05-21 14:41 ` Ludovic Courtès
0 siblings, 1 reply; 37+ messages in thread
From: Christopher Baines @ 2019-05-18 9:32 UTC (permalink / raw)
To: 35790
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 | 544 +++++++++-------
tests/lint.scm | 1436 +++++++++++++++++++----------------------
2 files changed, 974 insertions(+), 1006 deletions(-)
diff --git a/guix/scripts/lint.scm b/guix/scripts/lint.scm
index dc338a1d7b..37b17cefb4 100644
--- a/guix/scripts/lint.scm
+++ b/guix/scripts/lint.scm
@@ -84,6 +84,14 @@
check-formatting
run-checkers
+ <lint-warning>
+ lint-warning
+ lint-warning-package
+ lint-warning-message
+ lint-warning-location
+
+ append-warnings
+
%checkers
lint-checker
lint-checker?
@@ -93,42 +101,65 @@
\f
;;;
-;;; 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
;; given, the location of PACKAGE otherwise, the full name of PACKAGE and the
;; provided MESSAGE.
- (let ((loc (or (package-field-location package field)
- (package-location package))))
- (format (guix-warning-port) "~a: ~a@~a: ~a~%"
- (location->string loc)
- (package-name package) (package-version package)
- message)))
-
-(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 ...)))
+ (for-each
+ (match-lambda
+ (($ <lint-warning> package message loc)
+ (format (guix-warning-port) "~a: ~a@~a: ~a~%"
+ (location->string loc)
+ (package-name package) (package-version package)
+ message)))
+ (match warnings
+ ((? lint-warning?) (list warnings))
+ ((? list?) (apply append-warnings warnings))
+ (_ '()))))
+
+(define (append-warnings . args)
+ (fold (lambda (arg warnings)
+ (cond
+ ((list? arg)
+ (append warnings
+ (filter lint-warning?
+ arg)))
+ ((lint-warning? arg)
+ (append warnings
+ (list arg)))
+ (else warnings)))
+ '()
+ args))
\f
;;;
;;; Checkers
;;;
+
(define-record-type* <lint-checker>
lint-checker make-lint-checker
lint-checker?
@@ -164,9 +195,9 @@ monad."
;; Emit a warning if stylistic issues are found in the description of PACKAGE.
(define (check-not-empty description)
(when (string-null? description)
- (emit-warning package
+ (make-warning package
(G_ "description should not be empty")
- 'description)))
+ #:field 'description)))
(define (check-texinfo-markup description)
"Check that DESCRIPTION can be parsed as a Texinfo fragment. If the
@@ -174,39 +205,39 @@ markup is valid return a plain-text version of DESCRIPTION, otherwise #f."
(catch #t
(lambda () (texi->plain-text description))
(lambda (keys . args)
- (emit-warning package
+ (make-warning package
(G_ "Texinfo markup in description is invalid")
- 'description)
- #f)))
+ #:field 'description))))
(define (check-trademarks description)
"Check that DESCRIPTION does not contain '™' or '®' characters. See
http://www.gnu.org/prep/standards/html_node/Trademarks.html."
(match (string-index description (char-set #\™ #\®))
((and (? number?) index)
- (emit-warning package
+ (make-warning package
(format #f (G_ "description should not contain ~
trademark sign '~a' at ~d")
(string-ref description index) index)
- 'description))
+ #:field 'description))
(else #t)))
(define (check-quotes description)
"Check whether DESCRIPTION contains single quotes and suggest @code."
(when (regexp-exec %quoted-identifier-rx description)
- (emit-warning package
-
+ (make-warning package
;; TRANSLATORS: '@code' is Texinfo markup and must be kept
;; as is.
(G_ "use @code or similar ornament instead of quotes")
- 'description)))
+ #:field 'description)))
(define (check-proper-start description)
- (unless (or (properly-starts-sentence? description)
+ (unless (or (string-null? description)
+ (properly-starts-sentence? description)
(string-prefix-ci? (package-name package) description))
- (emit-warning package
- (G_ "description should start with an upper-case letter or digit")
- 'description)))
+ (make-warning
+ package
+ (G_ "description should start with an upper-case letter or digit")
+ #:field 'description)))
(define (check-end-of-sentence-space description)
"Check that an end-of-sentence period is followed by two spaces."
@@ -220,27 +251,30 @@ trademark sign '~a' at ~d")
'("i.e" "e.g" "a.k.a" "resp"))
r (cons (match:start m) r)))))))
(unless (null? infractions)
- (emit-warning package
+ (make-warning package
(format #f (G_ "sentences in description should be followed ~
by two spaces; possible infraction~p at ~{~a~^, ~}")
(length infractions)
infractions)
- 'description))))
+ #:field 'description))))
(let ((description (package-description package)))
(if (string? description)
- (begin
- (check-not-empty description)
- (check-quotes description)
- (check-trademarks description)
- ;; Use raw description for this because Texinfo rendering
- ;; automatically fixes end of sentence space.
- (check-end-of-sentence-space description)
- (and=> (check-texinfo-markup description)
- check-proper-start))
- (emit-warning package
+ (append-warnings
+ (check-not-empty description)
+ (check-quotes description)
+ (check-trademarks description)
+ ;; Use raw description for this because Texinfo rendering
+ ;; automatically fixes end of sentence space.
+ (check-end-of-sentence-space description)
+ (and=> (check-texinfo-markup description)
+ (match-lambda
+ ((and warning (? lint-warning?)) warning)
+ (description
+ (check-proper-start description)))))
+ (make-warning package
(format #f (G_ "invalid description: ~s") description)
- 'description))))
+ #:field 'description))))
(define (package-input-intersection inputs-to-check input-names)
"Return the intersection between INPUTS-TO-CHECK, the list of input tuples
@@ -281,13 +315,13 @@ of a package, and INPUT-NAMES, a list of package specifications such as
"python-pytest-cov" "python2-pytest-cov"
"python-setuptools-scm" "python2-setuptools-scm"
"python-sphinx" "python2-sphinx")))
- (for-each (lambda (input)
- (emit-warning
- package
- (format #f (G_ "'~a' should probably be a native input")
- input)
- 'inputs-to-check))
- (package-input-intersection inputs input-names))))
+ (map (lambda (input)
+ (make-warning
+ package
+ (format #f (G_ "'~a' should probably be a native input")
+ input)
+ #:field 'inputs))
+ (package-input-intersection inputs input-names))))
(define (check-inputs-should-not-be-an-input-at-all package)
;; Emit a warning if some inputs of PACKAGE are likely to should not be
@@ -296,14 +330,15 @@ of a package, and INPUT-NAMES, a list of package specifications such as
"python2-setuptools"
"python-pip"
"python2-pip")))
- (for-each (lambda (input)
- (emit-warning
- package
- (format #f
- (G_ "'~a' should probably not be an input at all")
- input)))
- (package-input-intersection (package-direct-inputs package)
- input-names))))
+ (map (lambda (input)
+ (make-warning
+ package
+ (format #f
+ (G_ "'~a' should probably not be an input at all")
+ input)
+ #:field 'inputs))
+ (package-input-intersection (package-direct-inputs package)
+ input-names))))
(define (package-name-regexp package)
"Return a regexp that matches PACKAGE's name as a word at the beginning of a
@@ -314,19 +349,13 @@ line."
(define (check-synopsis-style 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)
;; Synopsis should not end with a period, except for some special cases.
(when (and (string-suffix? "." synopsis)
(not (string-suffix? "etc." synopsis)))
- (emit-warning package
+ (make-warning package
(G_ "no period allowed at the end of the synopsis")
- 'synopsis)))
+ #:field 'synopsis)))
(define check-start-article
;; Skip this check for GNU packages, as suggested by Karl Berry's reply to
@@ -336,29 +365,29 @@ line."
(lambda (synopsis)
(when (or (string-prefix-ci? "A " synopsis)
(string-prefix-ci? "An " synopsis))
- (emit-warning package
+ (make-warning package
(G_ "no article allowed at the beginning of \
the synopsis")
- 'synopsis)))))
+ #:field 'synopsis)))))
(define (check-synopsis-length synopsis)
(when (>= (string-length synopsis) 80)
- (emit-warning package
+ (make-warning package
(G_ "synopsis should be less than 80 characters long")
- 'synopsis)))
+ #:field 'synopsis)))
(define (check-proper-start synopsis)
(unless (properly-starts-sentence? synopsis)
- (emit-warning package
+ (make-warning package
(G_ "synopsis should start with an upper-case letter or digit")
- 'synopsis)))
+ #:field 'synopsis)))
(define (check-start-with-package-name synopsis)
(when (and (regexp-exec (package-name-regexp package) synopsis)
(not (starts-with-abbreviation? synopsis)))
- (emit-warning package
+ (make-warning package
(G_ "synopsis should not start with the package name")
- 'synopsis)))
+ #:field 'synopsis)))
(define (check-texinfo-markup synopsis)
"Check that SYNOPSIS can be parsed as a Texinfo fragment. If the
@@ -366,14 +395,12 @@ markup is valid return a plain-text version of SYNOPSIS, otherwise #f."
(catch #t
(lambda () (texi->plain-text synopsis))
(lambda (keys . args)
- (emit-warning package
+ (make-warning package
(G_ "Texinfo markup in synopsis is invalid")
- 'synopsis)
- #f)))
+ #:field 'synopsis))))
(define checks
- (list check-not-empty
- check-proper-start
+ (list check-proper-start
check-final-period
check-start-article
check-start-with-package-name
@@ -381,13 +408,18 @@ markup is valid return a plain-text version of SYNOPSIS, otherwise #f."
check-texinfo-markup))
(match (package-synopsis package)
+ (""
+ (make-warning package
+ (G_ "synopsis should not be empty")
+ #:field 'synopsis))
((? string? synopsis)
- (for-each (lambda (proc)
- (proc synopsis))
- checks))
+ (apply append-warnings
+ (map (lambda (proc)
+ (proc synopsis))
+ checks)))
(invalid
- (emit-warning package (format #f (G_ "invalid synopsis: ~s") invalid)
- 'synopsis))))
+ (make-warning package (format #f (G_ "invalid synopsis: ~s") invalid)
+ #:field 'synopsis))))
(define* (probe-uri uri #:key timeout)
"Probe URI, a URI object, and return two values: a symbol denoting the
@@ -502,71 +534,66 @@ warning for PACKAGE mentionning the FIELD."
;; with a small HTML page upon failure. Attempt to detect
;; such malicious behavior.
(or (> length 1000)
- (begin
- (emit-warning package
- (format #f
- (G_ "URI ~a returned \
+ (make-warning package
+ (format #f
+ (G_ "URI ~a returned \
suspiciously small file (~a bytes)")
- (uri->string uri)
- length))
- #f)))
+ (uri->string uri)
+ length)
+ #:field field)))
(_ #t)))
((= 301 (response-code argument))
(if (response-location argument)
- (begin
- (emit-warning package
- (format #f (G_ "permanent redirect from ~a to ~a")
- (uri->string uri)
- (uri->string
- (response-location argument))))
- #t)
- (begin
- (emit-warning package
- (format #f (G_ "invalid permanent redirect \
+ (make-warning package
+ (format #f (G_ "permanent redirect from ~a to ~a")
+ (uri->string uri)
+ (uri->string
+ (response-location argument)))
+ #:field field)
+ (make-warning package
+ (format #f (G_ "invalid permanent redirect \
from ~a")
- (uri->string uri)))
- #f)))
+ (uri->string uri))
+ #:field field)))
(else
- (emit-warning package
+ (make-warning package
(format #f
(G_ "URI ~a not reachable: ~a (~s)")
(uri->string uri)
(response-code argument)
(response-reason-phrase argument))
- field)
- #f)))
+ #:field field))))
((ftp-response)
(match argument
(('ok) #t)
(('error port command code message)
- (emit-warning package
+ (make-warning package
(format #f
(G_ "URI ~a not reachable: ~a (~s)")
(uri->string uri)
- code (string-trim-both message)))
- #f)))
+ code (string-trim-both message))
+ #:field field))))
((getaddrinfo-error)
- (emit-warning package
+ (make-warning package
(format #f
(G_ "URI ~a domain not found: ~a")
(uri->string uri)
(gai-strerror (car argument)))
- field)
- #f)
+ #:field field))
((system-error)
- (emit-warning package
+ (make-warning package
(format #f
(G_ "URI ~a unreachable: ~a")
(uri->string uri)
(strerror
(system-error-errno
(cons status argument))))
- field)
- #f)
+ #:field field))
((tls-certificate-error)
- (emit-warning package
+ (make-warning package
(format #f (G_ "TLS certificate error: ~a")
- (tls-certificate-error-string argument))))
+ (tls-certificate-error-string argument))
+ #:field field))
((invalid-http-response gnutls-error)
;; Probably a misbehaving server; ignore.
#f)
@@ -585,13 +612,13 @@ from ~a")
((not (package-home-page package))
(unless (or (string-contains (package-name package) "bootstrap")
(string=? (package-name package) "ld-wrapper"))
- (emit-warning package
+ (make-warning package
(G_ "invalid value for home page")
- 'home-page)))
+ #:field 'home-page)))
(else
- (emit-warning package (format #f (G_ "invalid home page URL: ~s")
+ (make-warning package (format #f (G_ "invalid home page URL: ~s")
(package-home-page package))
- 'home-page)))))
+ #:field 'home-page)))))
(define %distro-directory
(mlambda ()
@@ -601,42 +628,43 @@ from ~a")
"Emit a warning if the patches requires by PACKAGE are badly named or if the
patch could not be found."
(guard (c ((message-condition? c) ;raised by 'search-patch'
- (emit-warning package (condition-message c)
- 'patch-file-names)))
+ (make-warning package (condition-message c)
+ #:field 'patch-file-names)))
(define patches
(or (and=> (package-source package) origin-patches)
'()))
- (unless (every (match-lambda ;patch starts with package name?
+ (append-warnings
+ (unless (every (match-lambda ;patch starts with package name?
+ ((? string? patch)
+ (and=> (string-contains (basename patch)
+ (package-name package))
+ zero?))
+ (_ #f)) ;must be an <origin> or something like that.
+ patches)
+ (make-warning
+ package
+ (G_ "file names of patches should start with the package name")
+ #:field 'patch-file-names))
+
+ ;; Check whether we're reaching tar's maximum file name length.
+ (let ((prefix (string-length (%distro-directory)))
+ (margin (string-length "guix-0.13.0-10-123456789/"))
+ (max 99))
+ (filter-map (match-lambda
((? string? patch)
- (and=> (string-contains (basename patch)
- (package-name package))
- zero?))
- (_ #f)) ;must be an <origin> or something like that.
- patches)
- (emit-warning
- package
- (G_ "file names of patches should start with the package name")
- 'patch-file-names))
-
- ;; Check whether we're reaching tar's maximum file name length.
- (let ((prefix (string-length (%distro-directory)))
- (margin (string-length "guix-0.13.0-10-123456789/"))
- (max 99))
- (for-each (match-lambda
- ((? string? patch)
- (when (> (+ margin (if (string-prefix? (%distro-directory)
- patch)
- (- (string-length patch) prefix)
- (string-length patch)))
- max)
- (emit-warning
- package
- (format #f (G_ "~a: file name is too long")
- (basename patch))
- 'patch-file-names)))
- (_ #f))
- patches))))
+ (when (> (+ margin (if (string-prefix? (%distro-directory)
+ patch)
+ (- (string-length patch) prefix)
+ (string-length patch)))
+ max)
+ (make-warning
+ package
+ (format #f (G_ "~a: file name is too long")
+ (basename patch))
+ #:field 'patch-file-names)))
+ (_ #f))
+ patches)))))
(define (escape-quotes str)
"Replace any quote character in STR by an escaped quote character."
@@ -665,30 +693,29 @@ descriptions maintained upstream."
(#f ;not a GNU package, so nothing to do
#t)
(descriptor ;a genuine GNU package
- (let ((upstream (gnu-package-doc-summary descriptor))
- (downstream (package-synopsis package))
- (loc (or (package-field-location package 'synopsis)
- (package-location package))))
- (when (and upstream
- (or (not (string? downstream))
- (not (string=? upstream downstream))))
- (format (guix-warning-port)
- (G_ "~a: ~a: proposed synopsis: ~s~%")
- (location->string loc) (package-full-name package)
- upstream)))
-
- (let ((upstream (gnu-package-doc-description descriptor))
- (downstream (package-description package))
- (loc (or (package-field-location package 'description)
- (package-location package))))
- (when (and upstream
- (or (not (string? downstream))
- (not (string=? (fill-paragraph upstream 100)
- (fill-paragraph downstream 100)))))
- (format (guix-warning-port)
- (G_ "~a: ~a: proposed description:~% \"~a\"~%")
- (location->string loc) (package-full-name package)
- (fill-paragraph (escape-quotes upstream) 77 7)))))))
+ (list
+ (let ((upstream (gnu-package-doc-summary descriptor))
+ (downstream (package-synopsis package)))
+ (when (and upstream
+ (or (not (string? downstream))
+ (not (string=? upstream downstream))))
+ (make-warning package
+ (format #f (G_ "proposed synopsis: ~s~%")
+ upstream)
+ #:field 'synopsis)))
+
+ (let ((upstream (gnu-package-doc-description descriptor))
+ (downstream (package-description package)))
+ (when (and upstream
+ (or (not (string? downstream))
+ (not (string=? (fill-paragraph upstream 100)
+ (fill-paragraph downstream 100)))))
+ (make-warning
+ package
+ (format #f
+ (G_ "proposed description:~% \"~a\"~%")
+ (fill-paragraph (escape-quotes upstream) 77 7))
+ #:field 'description)))))))
(define (origin-uris origin)
"Return the list of URIs (strings) for ORIGIN."
@@ -701,38 +728,34 @@ descriptions maintained upstream."
(define (check-source package)
"Emit a warning if PACKAGE has an invalid 'source' field, or if that
'source' is not reachable."
- (define (try-uris uris)
- (run-with-state
- (anym %state-monad
- (lambda (uri)
- (with-accumulated-warnings
- (validate-uri uri package 'source)))
- (append-map (cut maybe-expand-mirrors <> %mirrors)
- uris))
- '()))
+ (define (warnings-for-uris uris)
+ (apply
+ append-warnings
+ (map
+ (lambda (uri)
+ (validate-uri uri package 'source))
+ (append-map (cut maybe-expand-mirrors <> %mirrors)
+ uris))))
(let ((origin (package-source package)))
(when (and origin
(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.
- (call-with-values
- (lambda () (try-uris uris))
- (lambda (success? warnings)
+ (if (eq? (length uris) (length warnings))
;; When everything fails, report all of WARNINGS, otherwise don't
;; report anything.
;;
;; XXX: Ideally we'd still allow warnings to be raised if *some*
;; URIs are unreachable, but distinguish that from the error case
;; where *all* the URIs are unreachable.
- (unless success?
- (emit-warning package
- (G_ "all the source URIs are unreachable:")
- 'source)
- (for-each (lambda (warning)
- (display warning (guix-warning-port)))
- (reverse warnings)))))))))
+ (cons*
+ (make-warning package
+ (G_ "all the source URIs are unreachable:")
+ #:field 'source)
+ warnings))))))
(define (check-source-file-name package)
"Emit a warning if PACKAGE's origin has no meaningful file name."
@@ -749,9 +772,9 @@ descriptions maintained upstream."
(let ((origin (package-source package)))
(unless (or (not origin) (origin-file-name-valid? origin))
- (emit-warning package
+ (make-warning package
(G_ "the source file name should contain the package name")
- 'source))))
+ #:field 'source))))
(define (check-source-unstable-tarball package)
"Emit a warning if PACKAGE's source is an autogenerated tarball."
@@ -761,14 +784,14 @@ descriptions maintained upstream."
(uri-path (string->uri uri)))
((_ _ "archive" _ ...) #t)
(_ #f)))
- (emit-warning package
+ (make-warning package
(G_ "the source URI should not be an autogenerated tarball")
- 'source)))
+ #:field 'source)))
(let ((origin (package-source package)))
(when (and (origin? origin)
(eqv? (origin-method origin) url-fetch))
(let ((uris (origin-uris origin)))
- (for-each check-source-uri uris)))))
+ (filter-map check-source-uri uris)))))
(define (check-mirror-url package)
"Check whether PACKAGE uses source URLs that should be 'mirror://'."
@@ -782,18 +805,18 @@ descriptions maintained upstream."
(#f
(loop rest))
(prefix
- (emit-warning package
+ (make-warning package
(format #f (G_ "URL should be \
'mirror://~a/~a'")
mirror-id
(string-drop uri (string-length prefix)))
- 'source)))))))
+ #:field 'source)))))))
(let ((origin (package-source package)))
(when (and (origin? origin)
(eqv? (origin-method origin) url-fetch))
(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))
"Check whether PACKAGE uses source URLs that redirect to GitHub."
@@ -819,15 +842,15 @@ descriptions maintained upstream."
(let ((origin (package-source package)))
(when (and (origin? origin)
(eqv? (origin-method origin) url-fetch))
- (for-each
+ (filter-map
(lambda (uri)
(and=> (follow-redirects-to-github uri)
(lambda (github-uri)
(unless (string=? github-uri uri)
- (emit-warning
+ (make-warning
package
(format #f (G_ "URL should be '~a'") github-uri)
- 'source)))))
+ #:field 'source)))))
(origin-uris origin)))))
(define (check-derivation package)
@@ -836,12 +859,12 @@ descriptions maintained upstream."
(catch #t
(lambda ()
(guard (c ((store-protocol-error? c)
- (emit-warning package
+ (make-warning package
(format #f (G_ "failed to create ~a derivation: ~a")
system
(store-protocol-error-message c))))
((message-condition? c)
- (emit-warning package
+ (make-warning package
(format #f (G_ "failed to create ~a derivation: ~a")
system
(condition-message c)))))
@@ -858,11 +881,11 @@ descriptions maintained upstream."
(package-derivation store replacement system
#:graft? #f)))))))
(lambda args
- (emit-warning package
+ (make-warning package
(format #f (G_ "failed to create ~a derivation: ~s")
system args)))))
- (for-each try (package-supported-systems package)))
+ (filter-map try (package-supported-systems package)))
(define (check-license package)
"Warn about type errors of the 'license' field of PACKAGE."
@@ -871,8 +894,8 @@ descriptions maintained upstream."
((? license?) ...))
#t)
(x
- (emit-warning package (G_ "invalid license field")
- 'license))))
+ (make-warning package (G_ "invalid license field")
+ #:field 'license))))
(define (call-with-networking-fail-safe message error-value proc)
"Call PROC catching any network-related errors. Upon a networking error,
@@ -944,10 +967,10 @@ the NIST server non-fatal."
(member id known-safe))))
vulnerabilities)))
(unless (null? unpatched)
- (emit-warning package
- (format #f (G_ "probably vulnerable to ~a")
- (string-join (map vulnerability-id unpatched)
- ", ")))))))))
+ (make-warning package
+ (format #f (G_ "probably vulnerable to ~a")
+ (string-join (map vulnerability-id unpatched)
+ ", ")))))))))
(define (check-for-updates package)
"Check if there is an update available for PACKAGE."
@@ -959,9 +982,10 @@ the NIST server non-fatal."
((? upstream-source? source)
(when (version>? (upstream-source-version source)
(package-version package))
- (emit-warning package
+ (make-warning package
(format #f (G_ "can be upgraded to ~a")
- (upstream-source-version source)))))
+ (upstream-source-version source))
+ #:field 'version)))
(#f #f))) ; cannot find newer upstream release
\f
@@ -974,18 +998,26 @@ the NIST server non-fatal."
(match (string-index line #\tab)
(#f #t)
(index
- (emit-warning package
+ (make-warning package
(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)
"Warn about trailing white space in LINE."
(unless (or (string=? line (string-trim-right line))
(string=? line (string #\page)))
- (emit-warning package
+ (make-warning package
(format #f
(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)
"Emit a warning if LINE is too long."
@@ -993,9 +1025,13 @@ the NIST server non-fatal."
;; make it hard to fit within that limit and we want to avoid making too
;; much noise.
(when (> (string-length line) 90)
- (emit-warning package
+ (make-warning package
(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
(make-regexp "^[[:blank:]]*[()]+[[:blank:]]*$"))
@@ -1003,11 +1039,15 @@ the NIST server non-fatal."
(define (report-lone-parentheses package line line-number)
"Emit a warning if LINE contains hanging parentheses."
(when (regexp-exec %hanging-paren-rx line)
- (emit-warning package
+ (make-warning package
(format #f
- (G_ "line ~a: parentheses feel lonely, \
+ (G_ "parentheses feel lonely, \
move to the previous or next line")
- line-number))))
+ line-number)
+ #:location
+ (location (package-file package)
+ line-number
+ 0))))
(define %formatting-reporters
;; List of procedures that report formatting issues. These are not separate
@@ -1040,20 +1080,25 @@ them for PACKAGE."
(call-with-input-file file
(lambda (port)
(let loop ((line-number 1)
- (last-line #f))
+ (last-line #f)
+ (warnings '()))
(let ((line (read-line port)))
- (or (eof-object? line)
- (and last-line (> line-number last-line))
+ (if (or (eof-object? line)
+ (and last-line (> line-number last-line)))
+ warnings
(if (and (= line-number starting-line)
(not last-line))
(loop (+ 1 line-number)
- (+ 1 (sexp-last-line port)))
- (begin
- (unless (< line-number starting-line)
- (for-each (lambda (report)
+ (+ 1 (sexp-last-line port))
+ warnings)
+ (loop (+ 1 line-number)
+ last-line
+ (append-warnings
+ warnings
+ (unless (< line-number starting-line)
+ (map (lambda (report)
(report package line line-number))
- reporters))
- (loop (+ 1 line-number) last-line)))))))))
+ reporters)))))))))))
(define (check-formatting package)
"Check the formatting of the source code of PACKAGE."
@@ -1155,7 +1200,8 @@ or a list thereof")
(package-name package) (package-version package)
(lint-checker-name checker))
(force-output (current-error-port)))
- ((lint-checker-check checker) package))
+ (emit-warnings
+ ((lint-checker-check checker) package)))
checkers)
(when tty?
(format (current-error-port) "\x1b[K")
diff --git a/tests/lint.scm b/tests/lint.scm
index dc2b17aeec..7d99090d6b 100644
--- a/tests/lint.scm
+++ b/tests/lint.scm
@@ -44,7 +44,12 @@
#: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.
@@ -60,781 +65,705 @@
(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)))
+
\f
(test-begin "lint")
-(define (call-with-warnings thunk)
- (let ((port (open-output-string)))
- (parameterize ((guix-warning-port port))
- (thunk))
- (get-output-string port)))
-
-(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
- (let ((pkg (dummy-package "x"
- (description ""))))
- (check-description-style pkg)))
- "description should not be empty")))
-
-(test-assert "description: valid Texinfo markup"
- (->bool
- (string-contains
- (with-warnings
- (check-description-style (dummy-package "x" (description "f{oo}b@r"))))
- "Texinfo markup in description is invalid")))
-
-(test-assert "description: does not start with an upper-case letter"
- (->bool
- (string-contains (with-warnings
- (let ((pkg (dummy-package "x"
+(test-equal "description: not a string"
+ "invalid description: foobar"
+ (lint-warning-message
+ (check-description-style
+ (dummy-package "x" (description 'foobar)))))
+
+(test-equal "description: not empty"
+ "description should not be empty"
+ (match (check-description-style
+ (dummy-package "x" (description "")))
+ ((($ <lint-warning> package message location)) message)))
+
+(test-equal "description: invalid Texinfo markup"
+ "Texinfo markup in description is invalid"
+ (match (check-description-style
+ (dummy-package "x" (description "f{oo}b@r")))
+ ((($ <lint-warning> package message location)) message)))
+
+(test-equal "description: does not start with an upper-case letter"
+ "description should start with an upper-case letter or digit"
+ (match (let ((pkg (dummy-package "x"
(description "bad description."))))
- (check-description-style pkg)))
- "description should start with an upper-case letter")))
-
-(test-assert "description: may start with a digit"
- (string-null?
- (with-warnings
- (let ((pkg (dummy-package "x"
- (description "2-component library."))))
- (check-description-style pkg)))))
-
-(test-assert "description: may start with lower-case package name"
- (string-null?
- (with-warnings
- (let ((pkg (dummy-package "x"
- (description "x is a dummy package."))))
- (check-description-style pkg)))))
-
-(test-assert "description: two spaces after end of sentence"
- (->bool
- (string-contains (with-warnings
- (let ((pkg (dummy-package "x"
+ (check-description-style pkg))
+ ((($ <lint-warning> package message location)) message)))
+
+(test-equal "description: may start with a digit"
+ '()
+ (append-warnings
+ (let ((pkg (dummy-package "x"
+ (description "2-component library."))))
+ (check-description-style pkg))))
+
+(test-equal "description: may start with lower-case package name"
+ '()
+ (append-warnings
+ (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"
+ (match (let ((pkg (dummy-package "x"
(description "Bad. Quite bad."))))
- (check-description-style pkg)))
- "sentences in description should be followed by two spaces")))
-
-(test-assert "description: end-of-sentence detection with abbreviations"
- (string-null?
- (with-warnings
- (let ((pkg (dummy-package "x"
- (description
- "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 "description: suggest ornament instead of quotes"
- (->bool
- (string-contains (with-warnings
- (let ((pkg (dummy-package "x"
+ (check-description-style pkg))
+ ((($ <lint-warning> package message location)) message)))
+
+(test-equal "description: end-of-sentence detection with abbreviations"
+ '()
+ (append-warnings
+ (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"
+ (match (let ((pkg (dummy-package "x"
+ (description "Does The Right Thing™"))))
+ (check-description-style pkg))
+ ((($ <lint-warning> package message location)) message)))
+
+(test-equal "description: may not contain trademark signs: ®"
+ "description should not contain trademark sign '®' at 17"
+ (match (let ((pkg (dummy-package "x"
+ (description "Works with Format®"))))
+ (check-description-style pkg))
+ ((($ <lint-warning> package message location)) message)))
+
+(test-equal "description: suggest ornament instead of quotes"
+ "use @code or similar ornament instead of quotes"
+ (match (let ((pkg (dummy-package "x"
(description "This is a 'quoted' thing."))))
- (check-description-style pkg)))
- "use @code")))
+ (check-description-style pkg))
+ ((($ <lint-warning> package message location)) message)))
-(test-assert "synopsis: not a string"
- (->bool
- (string-contains (with-warnings
- (let ((pkg (dummy-package "x"
+(test-equal "synopsis: not a string"
+ "invalid synopsis: #f"
+ (match (let ((pkg (dummy-package "x"
(synopsis #f))))
- (check-synopsis-style pkg)))
- "invalid synopsis")))
+ (append-warnings (check-synopsis-style pkg)))
+ ((($ <lint-warning> package message location)) message)))
-(test-assert "synopsis: not empty"
- (->bool
- (string-contains (with-warnings
- (let ((pkg (dummy-package "x"
+(test-equal "synopsis: not empty"
+ "synopsis should not be empty"
+ (match (let ((pkg (dummy-package "x"
(synopsis ""))))
- (check-synopsis-style pkg)))
- "synopsis should not be empty")))
-
-(test-assert "synopsis: valid Texinfo markup"
- (->bool
- (string-contains
- (with-warnings
- (check-synopsis-style (dummy-package "x" (synopsis "Bad $@ texinfo"))))
- "Texinfo markup in synopsis is invalid")))
-
-(test-assert "synopsis: does not start with an upper-case letter"
- (->bool
- (string-contains (with-warnings
- (let ((pkg (dummy-package "x"
- (synopsis "bad synopsis."))))
- (check-synopsis-style pkg)))
- "synopsis should start with an upper-case letter")))
-
-(test-assert "synopsis: may start with a digit"
- (string-null?
- (with-warnings
- (let ((pkg (dummy-package "x"
- (synopsis "5-dimensional frobnicator"))))
- (check-synopsis-style pkg)))))
-
-(test-assert "synopsis: ends with a period"
- (->bool
- (string-contains (with-warnings
- (let ((pkg (dummy-package "x"
+ (check-synopsis-style pkg))
+ (($ <lint-warning> package message location) message)))
+
+(test-equal "synopsis: valid Texinfo markup"
+ "Texinfo markup in synopsis is invalid"
+ (match (check-synopsis-style
+ (dummy-package "x" (synopsis "Bad $@ texinfo")))
+ ((($ <lint-warning> package message location)) message)))
+
+(test-equal "synopsis: does not start with an upper-case letter"
+ "synopsis should start with an upper-case letter or digit"
+ (match (let ((pkg (dummy-package "x"
+ (synopsis "bad synopsis"))))
+ (check-synopsis-style pkg))
+ ((($ <lint-warning> package message location)) message)))
+
+(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"
+ (match (let ((pkg (dummy-package "x"
(synopsis "Bad synopsis."))))
- (check-synopsis-style pkg)))
- "no period allowed at the end of the synopsis")))
-
-(test-assert "synopsis: ends with 'etc.'"
- (string-null? (with-warnings
- (let ((pkg (dummy-package "x"
- (synopsis "Foo, bar, etc."))))
- (check-synopsis-style pkg)))))
-
-(test-assert "synopsis: starts with 'A'"
- (->bool
- (string-contains (with-warnings
- (let ((pkg (dummy-package "x"
+ (check-synopsis-style pkg))
+ ((($ <lint-warning> package message location)) message)))
+
+(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"
+ (match (let ((pkg (dummy-package "x"
(synopsis "A bad synopŝis"))))
- (check-synopsis-style pkg)))
- "no article allowed at the beginning of the synopsis")))
+ (check-synopsis-style pkg))
+ ((($ <lint-warning> package message location)) message)))
-(test-assert "synopsis: starts with 'An'"
- (->bool
- (string-contains (with-warnings
- (let ((pkg (dummy-package "x"
+(test-equal "synopsis: starts with 'An'"
+ "no article allowed at the beginning of the synopsis"
+ (match (let ((pkg (dummy-package "x"
(synopsis "An awful synopsis"))))
- (check-synopsis-style pkg)))
- "no article allowed at the beginning of the synopsis")))
-
-(test-assert "synopsis: starts with 'a'"
- (->bool
- (string-contains (with-warnings
- (let ((pkg (dummy-package "x"
- (synopsis "a bad synopsis"))))
- (check-synopsis-style pkg)))
- "no article allowed at the beginning of the synopsis")))
-
-(test-assert "synopsis: starts with 'an'"
- (->bool
- (string-contains (with-warnings
- (let ((pkg (dummy-package "x"
- (synopsis "an awful synopsis"))))
- (check-synopsis-style pkg)))
- "no article allowed at the beginning of the synopsis")))
-
-(test-assert "synopsis: too long"
- (->bool
- (string-contains (with-warnings
- (let ((pkg (dummy-package "x"
- (synopsis (make-string 80 #\x)))))
- (check-synopsis-style pkg)))
- "synopsis should be less than 80 characters long")))
-
-(test-assert "synopsis: start with package name"
- (->bool
- (string-contains (with-warnings
- (let ((pkg (dummy-package "x"
- (name "foo")
- (synopsis "foo, a nice package"))))
- (check-synopsis-style pkg)))
- "synopsis should not start with the package name")))
-
-(test-assert "synopsis: start with package name prefix"
- (string-null?
- (with-warnings
- (let ((pkg (dummy-package "arb"
- (synopsis "Arbitrary precision"))))
- (check-synopsis-style pkg)))))
-
-(test-assert "synopsis: start with abbreviation"
- (string-null?
- (with-warnings
- (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-assert "inputs: pkg-config is probably a native input"
- (->bool
- (string-contains
- (with-warnings
- (let ((pkg (dummy-package "x"
- (inputs `(("pkg-config" ,pkg-config))))))
- (check-inputs-should-be-native pkg)))
- "'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
+ (check-synopsis-style pkg))
+ ((($ <lint-warning> package message location)) message)))
+
+(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"
+ (match (let ((pkg (dummy-package "x"
+ (synopsis (make-string 80 #\X)))))
+ (check-synopsis-style pkg))
+ ((($ <lint-warning> package message location)) message)))
+
+(test-equal "synopsis: start with package name"
+ "synopsis should not start with the package name"
+ (match (let ((pkg (dummy-package "x"
+ (name "Foo")
+ (synopsis "Foo, a nice package"))))
+ (check-synopsis-style pkg))
+ ((($ <lint-warning> package message location)) message)))
+
+(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"
+ (match (let ((pkg (dummy-package "x"
+ (inputs `(("pkg-config" ,pkg-config))))))
+ (check-inputs-should-be-native pkg))
+ ((($ <lint-warning> package message location)) message)))
+
+(test-equal "inputs: glib:bin is probably a native input"
+ "'glib:bin' should probably be a native input"
+ (match (let ((pkg (dummy-package "x"
+ (inputs `(("glib" ,glib "bin"))))))
+ (check-inputs-should-be-native pkg))
+ ((($ <lint-warning> package message location)) message)))
+
+(test-equal
"inputs: python-setuptools should not be an input at all (input)"
- (->bool
- (string-contains
- (with-warnings
- (let ((pkg (dummy-package "x"
- (inputs `(("python-setuptools" ,python-setuptools))))))
- (check-inputs-should-not-be-an-input-at-all pkg)))
- "'python-setuptools' should probably not be an input at all")))
-
-(test-assert
+ "'python-setuptools' should probably not be an input at all"
+ (match (let ((pkg (dummy-package "x"
+ (inputs `(("python-setuptools"
+ ,python-setuptools))))))
+ (check-inputs-should-not-be-an-input-at-all pkg))
+ ((($ <lint-warning> package message location)) message)))
+
+
+(test-equal
"inputs: python-setuptools should not be an input at all (native-input)"
- (->bool
- (string-contains
- (with-warnings
- (let ((pkg (dummy-package "x"
- (native-inputs
- `(("python-setuptools" ,python-setuptools))))))
- (check-inputs-should-not-be-an-input-at-all pkg)))
- "'python-setuptools' should probably not be an input at all")))
-
-(test-assert
+ "'python-setuptools' should probably not be an input at all"
+ (match (let ((pkg (dummy-package "x"
+ (native-inputs
+ `(("python-setuptools"
+ ,python-setuptools))))))
+ (check-inputs-should-not-be-an-input-at-all pkg))
+ ((($ <lint-warning> package message location)) message)))
+
+(test-equal
"inputs: python-setuptools should not be an input at all (propagated-input)"
- (->bool
- (string-contains
- (with-warnings
- (let ((pkg (dummy-package "x"
- (propagated-inputs
- `(("python-setuptools" ,python-setuptools))))))
- (check-inputs-should-not-be-an-input-at-all pkg)))
- "'python-setuptools' should probably not be an input at all")))
-
-(test-assert "patches: file names"
- (->bool
- (string-contains
- (with-warnings
- (let ((pkg (dummy-package "x"
- (source
- (dummy-origin
- (patches (list "/path/to/y.patch")))))))
- (check-patch-file-names pkg)))
- "file names of patches should start with the package name")))
-
-(test-assert "patches: file name too long"
- (->bool
- (string-contains
- (with-warnings
- (let ((pkg (dummy-package "x"
- (source
- (dummy-origin
- (patches (list (string-append "x-"
- (make-string 100 #\a)
- ".patch"))))))))
- (check-patch-file-names pkg)))
- "file name is too long")))
-
-(test-assert "patches: not found"
- (->bool
- (string-contains
- (with-warnings
- (let ((pkg (dummy-package "x"
- (source
- (dummy-origin
+ "'python-setuptools' should probably not be an input at all"
+ (match (let ((pkg (dummy-package "x"
+ (propagated-inputs
+ `(("python-setuptools" ,python-setuptools))))))
+ (check-inputs-should-not-be-an-input-at-all pkg))
+ ((($ <lint-warning> package message location)) message)))
+
+(test-equal "patches: file names"
+ "file names of patches should start with the package name"
+ (match (let ((pkg (dummy-package "x"
+ (source
+ (dummy-origin
+ (patches (list "/path/to/y.patch")))))))
+ (check-patch-file-names pkg))
+ ((($ <lint-warning> package message location)) message)))
+
+(test-equal "patches: file name too long"
+ (string-append "x-"
+ (make-string 100 #\a)
+ ".patch: file name is too long")
+ (match (let ((pkg (dummy-package
+ "x"
+ (source
+ (dummy-origin
+ (patches (list (string-append "x-"
+ (make-string 100 #\a)
+ ".patch"))))))))
+ (check-patch-file-names pkg))
+ ((($ <lint-warning> package message location)) message)))
+
+(test-equal "patches: not found"
+ "this-patch-does-not-exist!: patch not found"
+ (match (let ((pkg (dummy-package
+ "x"
+ (source
+ (dummy-origin
(patches
(list (search-patch "this-patch-does-not-exist!"))))))))
- (check-patch-file-names pkg)))
- "patch not found")))
-
-(test-assert "derivation: invalid arguments"
- (->bool
- (string-contains
- (with-warnings
- (let ((pkg (dummy-package "x"
- (arguments
- '(#:imported-modules (invalid-module))))))
- (check-derivation pkg)))
- "failed to create")))
-
-(test-assert "license: invalid license"
- (string-contains
- (with-warnings
- (check-license (dummy-package "x" (license #f))))
- "invalid license"))
-
-(test-assert "home-page: wrong home-page"
- (->bool
- (string-contains
- (with-warnings
- (let ((pkg (package
- (inherit (dummy-package "x"))
- (home-page #f))))
- (check-home-page pkg)))
- "invalid")))
-
-(test-assert "home-page: invalid URI"
- (->bool
- (string-contains
- (with-warnings
- (let ((pkg (package
- (inherit (dummy-package "x"))
- (home-page "foobar"))))
- (check-home-page pkg)))
- "invalid home page URL")))
-
-(test-assert "home-page: host not found"
- (->bool
- (string-contains
- (with-warnings
- (let ((pkg (package
- (inherit (dummy-package "x"))
- (home-page "http://does-not-exist"))))
- (check-home-page pkg)))
- "domain not found")))
+ (check-patch-file-names pkg))
+ (($ <lint-warning> package message location) message)))
+
+(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))
+ ((($ <lint-warning> package message location) others ...) message)))
+
+(test-equal "license: invalid license"
+ "invalid license field"
+ (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))))
+ (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"))))
+ (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"))))
+ (lint-warning-message
+ (check-home-page pkg))))
(test-skip (if (http-server-can-listen?) 0 1))
-(test-assert "home-page: Connection refused"
- (->bool
- (string-contains
- (with-warnings
- (let ((pkg (package
- (inherit (dummy-package "x"))
- (home-page (%local-url)))))
- (check-home-page pkg)))
- "Connection refused")))
+(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)))))
+ (lint-warning-message
+ (check-home-page pkg))))
(test-skip (if (http-server-can-listen?) 0 1))
(test-equal "home-page: 200"
- ""
- (with-warnings
- (with-http-server 200 %long-string
- (let ((pkg (package
- (inherit (dummy-package "x"))
- (home-page (%local-url)))))
+ '()
+ (with-http-server 200 %long-string
+ (let ((pkg (package
+ (inherit (dummy-package "x"))
+ (home-page (%local-url)))))
+ (append-warnings
(check-home-page pkg)))))
(test-skip (if (http-server-can-listen?) 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-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)))))
+
+ (lint-warning-message
+ (check-home-page pkg)))))
(test-skip (if (http-server-can-listen?) 0 1))
-(test-assert "home-page: 404"
- (->bool
- (string-contains
- (with-warnings
- (with-http-server 404 %long-string
- (let ((pkg (package
- (inherit (dummy-package "x"))
- (home-page (%local-url)))))
- (check-home-page pkg))))
- "not reachable: 404")))
+(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)))))
+ (lint-warning-message
+ (check-home-page pkg)))))
(test-skip (if (http-server-can-listen?) 0 1))
-(test-assert "home-page: 301, invalid"
- (->bool
- (string-contains
- (with-warnings
- (with-http-server 301 %long-string
- (let ((pkg (package
- (inherit (dummy-package "x"))
- (home-page (%local-url)))))
- (check-home-page pkg))))
- "invalid permanent redirect")))
+(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)))))
+ (lint-warning-message
+ (check-home-page pkg)))))
(test-skip (if (http-server-can-listen?) 0 1))
-(test-assert "home-page: 301 -> 200"
- (->bool
- (string-contains
- (with-warnings
- (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)))))
- (check-home-page pkg)))))))
- "permanent redirect")))
+(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)))))
+ (lint-warning-message
+ (check-home-page pkg))))))))
(test-skip (if (http-server-can-listen?) 0 1))
-(test-assert "home-page: 301 -> 404"
- (->bool
- (string-contains
- (with-warnings
- (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)))))
- (check-home-page pkg)))))))
- "not reachable: 404")))
-
-(test-assert "source-file-name"
- (->bool
- (string-contains
- (with-warnings
- (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))))))
- (check-source-file-name pkg)))
- "file name should contain the package name")))
-
-(test-assert "source-file-name: v prefix"
- (->bool
- (string-contains
- (with-warnings
- (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))))))
- (check-source-file-name pkg)))
- "file name should contain the package name")))
-
-(test-assert "source-file-name: bad checkout"
- (->bool
- (string-contains
- (with-warnings
- (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))))))
- (check-source-file-name pkg)))
- "file name should contain the package name")))
-
-(test-assert "source-file-name: good checkout"
- (not
- (->bool
- (string-contains
- (with-warnings
- (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)))
- "file name should contain the package name"))))
-
-(test-assert "source-file-name: valid"
- (not
- (->bool
- (string-contains
- (with-warnings
- (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)))
- "file name should contain the package name"))))
-
-(test-assert "source-unstable-tarball"
- (string-contains
- (with-warnings
- (let ((pkg (dummy-package "x"
- (source
- (origin
- (method url-fetch)
- (uri "https://github.com/example/example/archive/v0.0.tar.gz")
- (sha256 %null-sha256))))))
- (check-source-unstable-tarball pkg)))
- "source URI should not be an autogenerated tarball"))
-
-(test-assert "source-unstable-tarball: source #f"
- (not
- (->bool
- (string-contains
- (with-warnings
- (let ((pkg (dummy-package "x"
- (source #f))))
- (check-source-unstable-tarball pkg)))
- "source URI should not be an autogenerated tarball"))))
-
-(test-assert "source-unstable-tarball: valid"
- (not
- (->bool
- (string-contains
- (with-warnings
- (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)))
- "source URI should not be an autogenerated tarball"))))
-
-(test-assert "source-unstable-tarball: package named archive"
- (not
- (->bool
- (string-contains
- (with-warnings
- (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)))
- "source URI should not be an autogenerated tarball"))))
-
-(test-assert "source-unstable-tarball: not-github"
- (not
- (->bool
- (string-contains
- (with-warnings
- (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)))
- "source URI should not be an autogenerated tarball"))))
-
-(test-assert "source-unstable-tarball: git-fetch"
- (not
- (->bool
- (string-contains
- (with-warnings
- (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)))
- "source URI should not be an autogenerated tarball"))))
+(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)))))
+ (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))))))
+ (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))))))
+ (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))))))
+ (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))))))
+ (append-warnings
+ (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))))))
+ (append-warnings
+ (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))))))
+ (match (check-source-unstable-tarball pkg)
+ ((($ <lint-warning> package message comment)) message))))
+
+(test-equal "source-unstable-tarball: source #f"
+ '()
+ (let ((pkg (dummy-package "x"
+ (source #f))))
+ (append-warnings
+ (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))))))
+ (append-warnings
+ (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))))))
+ (append-warnings
+ (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))))))
+ (append-warnings
+ (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))))))
+ (append-warnings
+ (check-source-unstable-tarball pkg))))
(test-skip (if (http-server-can-listen?) 0 1))
(test-equal "source: 200"
- ""
- (with-warnings
- (with-http-server 200 %long-string
- (let ((pkg (package
- (inherit (dummy-package "x"))
- (source (origin
- (method url-fetch)
- (uri (%local-url))
- (sha256 %null-sha256))))))
+ '()
+ (with-http-server 200 %long-string
+ (let ((pkg (package
+ (inherit (dummy-package "x"))
+ (source (origin
+ (method url-fetch)
+ (uri (%local-url))
+ (sha256 %null-sha256))))))
+ (append-warnings
(check-source pkg)))))
(test-skip (if (http-server-can-listen?) 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-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
+ ($ <lint-warning> package message location)) message)))))
(test-skip (if (http-server-can-listen?) 0 1))
-(test-assert "source: 404"
- (->bool
- (string-contains
- (with-warnings
- (with-http-server 404 %long-string
- (let ((pkg (package
- (inherit (dummy-package "x"))
- (source (origin
- (method url-fetch)
- (uri (%local-url))
- (sha256 %null-sha256))))))
- (check-source pkg))))
- "not reachable: 404")))
+(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
+ ($ <lint-warning> package message location)) message)))))
(test-skip (if (http-server-can-listen?) 0 1))
(test-equal "source: 301 -> 200"
- ""
- (with-warnings
- (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))))))
- (check-source pkg))))))))
+ "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
+ ($ <lint-warning> package message location)) message))))))))
(test-skip (if (http-server-can-listen?) 0 1))
-(test-assert "source: 301 -> 404"
- (->bool
- (string-contains
- (with-warnings
- (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))))))
- (check-source pkg)))))))
- "not reachable: 404")))
-
-(test-assert "mirror-url"
- (string-null?
- (with-warnings
- (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-assert "mirror-url: one suggestion"
- (string-contains
- (with-warnings
- (let ((source (origin
- (method url-fetch)
- (uri "http://ftp.gnu.org/pub/gnu/foo/foo.tar.gz")
- (sha256 %null-sha256))))
- (check-mirror-url (dummy-package "x" (source source)))))
- "mirror://gnu/foo/foo.tar.gz"))
-
-(test-assert "github-url"
- (string-null?
- (with-warnings
- (with-http-server 200 %long-string
- (check-github-url
- (dummy-package "x" (source
- (origin
- (method url-fetch)
- (uri (%local-url))
- (sha256 %null-sha256)))))))))
+(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
+ ($ <lint-warning> package message location)) message))))))))
+
+(test-equal "mirror-url"
+ '()
+ (let ((source (origin
+ (method url-fetch)
+ (uri "http://example.org/foo/bar.tar.gz")
+ (sha256 %null-sha256))))
+ (append-warnings
+ (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))))
+ (match (check-mirror-url (dummy-package "x" (source source)))
+ ((($ <lint-warning> package message location)) message))))
+
+(test-equal "github-url"
+ '()
+ (with-http-server 200 %long-string
+ (append-warnings
+ (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-assert "github-url: one suggestion"
- (string-contains
- (with-warnings
- (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)))) ""
- (check-github-url
- (dummy-package "x" (source
- (origin
- (method url-fetch)
- (uri (%local-url))
- (sha256 %null-sha256))))))))))
- github-url))
- (test-assert "github-url: already the correct github url"
- (string-null?
- (with-warnings
- (check-github-url
- (dummy-package "x" (source
- (origin
- (method url-fetch)
- (uri github-url)
- (sha256 %null-sha256)))))))))
-
-(test-assert "cve"
+ (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)))) ""
+ (match (check-github-url
+ (dummy-package "x" (source
+ (origin
+ (method url-fetch)
+ (uri (%local-url))
+ (sha256 %null-sha256)))))
+ ((($ <lint-warning> package message location)) message)))))))
+ (test-equal "github-url: already the correct github url"
+ '()
+ (append-warnings
+ (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 '()))
- (string-null?
- (with-warnings (check-vulnerabilities (dummy-package "x"))))))
+ (append-warnings
+ (check-vulnerabilities (dummy-package "x")))))
-(test-assert "cve: one vulnerability"
+(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)))))))
- (string-contains
- (with-warnings
- (check-vulnerabilities (dummy-package "pi" (version "3.14"))))
- "vulnerable to CVE-2015-1234")))
+ (match (check-vulnerabilities (dummy-package "pi" (version "3.14")))
+ (($ <lint-warning> package message location) message))))
-(test-assert "cve: one patched vulnerability"
+(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)))))))
- (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: known safe from vulnerability"
+ (append-warnings
+ (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)))))))
- (string-null?
- (with-warnings
- (check-vulnerabilities
- (dummy-package "pi"
- (version "3.14")
- (properties `((lint-hidden-cve . ("CVE-2015-1234"))))))))))
-
-(test-assert "cve: vulnerability fixed in replacement version"
+ (append-warnings
+ (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)
@@ -845,71 +774,64 @@
(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"
+ (append-warnings
+ (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)))))))
- (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
- (check-formatting
- (
- dummy-package "ugly as hell!"
- )
- ))
- "lonely"))
+ (append-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-equal "formatting: lonely parentheses"
+ "parentheses feel lonely, move to the previous or next line"
+ (match (check-formatting
+ (dummy-package "ugly as hell!"
+ )
+ )
+ ((($ <lint-warning> package message location)) message)))
(test-assert "formatting: tabulation"
- (string-contains
- (with-warnings
- (check-formatting (dummy-package "leave the tab here: ")))
- "tabulation"))
+ (string-match-or-error
+ "tabulation on line [0-9]+, column [0-9]+"
+ (match (check-formatting (dummy-package "leave the tab here: "))
+ ((($ <lint-warning> package message location))
+ message))))
(test-assert "formatting: trailing white space"
- (string-contains
- (with-warnings
- ;; Leave the trailing white space on the next line!
- (check-formatting (dummy-package "x")))
- "trailing white space"))
+ (string-match-or-error
+ "trailing white space .*"
+ ;; Leave the trailing white space on the next line!
+ (match (check-formatting (dummy-package "x"))
+ ((($ <lint-warning> package message location))
+ message))))
(test-assert "formatting: long line"
- (string-contains
- (with-warnings
- (check-formatting
- (dummy-package "x" ;here is a stupid comment just to make a long line
- )))
- "too long"))
-
-(test-assert "formatting: alright"
- (string-null?
- (with-warnings
- (check-formatting (dummy-package "x")))))
+ (string-match-or-error
+ "line [0-9]+ is way too long \\([0-9]+ characters\\)"
+ (match (check-formatting
+ (dummy-package "x")) ;here is a stupid comment just to make a long line
+ ((($ <lint-warning> package message location)) message))))
+
+(test-equal "formatting: alright"
+ '()
+ (append-warnings (check-formatting (dummy-package "x"))))
(test-end "lint")
--
2.21.0
^ permalink raw reply related [flat|nested] 37+ messages in thread
* [bug#35790] [PATCH] scripts: lint: Handle warnings with a record type.
2019-05-18 9:32 [bug#35790] [PATCH] scripts: lint: Handle warnings with a record type Christopher Baines
@ 2019-05-21 14:41 ` Ludovic Courtès
2019-06-01 18:31 ` Christopher Baines
2019-06-01 19:09 ` Christopher Baines
0 siblings, 2 replies; 37+ messages in thread
From: Ludovic Courtès @ 2019-05-21 14:41 UTC (permalink / raw)
To: Christopher Baines; +Cc: 35790
Hello!
Christopher Baines <mail@cbaines.net> skribis:
> 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.
Yay!
> + <lint-warning>
As a rule of thumb, it’s best to not export the record type descriptor
(RTD) because then anything could happen. In this case, I think the
tests would be just as readable if we used ‘lint-warning-message’ &
co. instead of matching on the record.
WDYT?
> +(define* (make-warning package message
> + #:key field location)
> + (make-lint-warning
> + package
> + message
In practice MESSAGE is already translated. I think it would be more
flexible if it were not; ‘lint-warning-message’ would always return the
English message, and it’d be up to the user to call ‘gettext’ on it,
like we do for package descriptions.
To achieve this, you’d need a little trick so that ‘xgettext’ can still
extract the messages, like:
(define-syntax-rule make-warning
(syntax-rule (G_)
((_ package (G_ message) rest ...)
(%make-warning package message rest ...))))
where ‘%make-warning’ is the procedure you define above.
Then you need an explicit call to ‘G_’ at the point where messages are
displayed.
Does that make sense?
> +(define (append-warnings . args)
> + (fold (lambda (arg warnings)
> + (cond
> + ((list? arg)
> + (append warnings
> + (filter lint-warning?
> + arg)))
> + ((lint-warning? arg)
> + (append warnings
> + (list arg)))
> + (else warnings)))
> + '()
> + args))
I always feel that we should have procedures that operate on lists of
anything, like ‘append’, and thus ‘append-warnings’ looks like an
anti-pattern to me.
What about simply ensuring that every checker returns a list of
<lint-warning>s? That way, we wouldn’t have to do such things, I think.
That’s all!
Thanks,
Ludo’.
^ permalink raw reply [flat|nested] 37+ messages in thread
* [bug#35790] [PATCH] scripts: lint: Handle warnings with a record type.
2019-05-21 14:41 ` Ludovic Courtès
@ 2019-06-01 18:31 ` Christopher Baines
2019-06-07 7:44 ` Ludovic Courtès
2019-06-01 19:09 ` Christopher Baines
1 sibling, 1 reply; 37+ messages in thread
From: Christopher Baines @ 2019-06-01 18:31 UTC (permalink / raw)
To: 35790
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 | 757 +++++++++++----------
tests/lint.scm | 1453 +++++++++++++++++++----------------------
2 files changed, 1102 insertions(+), 1108 deletions(-)
diff --git a/guix/scripts/lint.scm b/guix/scripts/lint.scm
index dc338a1d7b..1b08068669 100644
--- a/guix/scripts/lint.scm
+++ b/guix/scripts/lint.scm
@@ -84,6 +84,12 @@
check-formatting
run-checkers
+ lint-warning
+ lint-warning?
+ lint-warning-package
+ lint-warning-message
+ lint-warning-location
+
%checkers
lint-checker
lint-checker?
@@ -93,42 +99,48 @@
\f
;;;
-;;; 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
;; given, the location of PACKAGE otherwise, the full name of PACKAGE and the
;; provided MESSAGE.
- (let ((loc (or (package-field-location package field)
- (package-location package))))
- (format (guix-warning-port) "~a: ~a@~a: ~a~%"
- (location->string loc)
- (package-name package) (package-version package)
- message)))
-
-(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 ...)))
+ (for-each
+ (match-lambda
+ (($ <lint-warning> package message loc)
+ (format (guix-warning-port) "~a: ~a@~a: ~a~%"
+ (location->string loc)
+ (package-name package) (package-version package)
+ message)))
+ warnings))
\f
;;;
;;; Checkers
;;;
+
(define-record-type* <lint-checker>
lint-checker make-lint-checker
lint-checker?
@@ -163,10 +175,12 @@ monad."
(define (check-description-style package)
;; Emit a warning if stylistic issues are found in the description of PACKAGE.
(define (check-not-empty description)
- (when (string-null? description)
- (emit-warning package
- (G_ "description should not be empty")
- 'description)))
+ (if (string-null? description)
+ (list
+ (make-warning package
+ (G_ "description should not be empty")
+ #:field 'description))
+ '()))
(define (check-texinfo-markup description)
"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
(lambda () (texi->plain-text description))
(lambda (keys . args)
- (emit-warning package
+ (make-warning package
(G_ "Texinfo markup in description is invalid")
- 'description)
- #f)))
+ #:field 'description))))
(define (check-trademarks description)
"Check that DESCRIPTION does not contain '™' or '®' characters. See
http://www.gnu.org/prep/standards/html_node/Trademarks.html."
(match (string-index description (char-set #\™ #\®))
((and (? number?) index)
- (emit-warning package
- (format #f (G_ "description should not contain ~
+ (list
+ (make-warning package
+ (format #f (G_ "description should not contain ~
trademark sign '~a' at ~d")
- (string-ref description index) index)
- 'description))
- (else #t)))
+ (string-ref description index) index)
+ #:field 'description)))
+ (else '())))
(define (check-quotes description)
"Check whether DESCRIPTION contains single quotes and suggest @code."
- (when (regexp-exec %quoted-identifier-rx description)
- (emit-warning package
-
- ;; TRANSLATORS: '@code' is Texinfo markup and must be kept
- ;; as is.
- (G_ "use @code or similar ornament instead of quotes")
- 'description)))
+ (if (regexp-exec %quoted-identifier-rx description)
+ (list
+ (make-warning package
+ ;; TRANSLATORS: '@code' is Texinfo markup and must be kept
+ ;; as is.
+ (G_ "use @code or similar ornament instead of quotes")
+ #:field 'description))
+ '()))
(define (check-proper-start description)
- (unless (or (properly-starts-sentence? description)
- (string-prefix-ci? (package-name package) description))
- (emit-warning package
- (G_ "description should start with an upper-case letter or digit")
- 'description)))
+ (if (or (string-null? description)
+ (properly-starts-sentence? description)
+ (string-prefix-ci? (package-name package) description))
+ '()
+ (list
+ (make-warning
+ package
+ (G_ "description should start with an upper-case letter or digit")
+ #:field 'description))))
(define (check-end-of-sentence-space description)
"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)))
'("i.e" "e.g" "a.k.a" "resp"))
r (cons (match:start m) r)))))))
- (unless (null? infractions)
- (emit-warning package
- (format #f (G_ "sentences in description should be followed ~
+ (if (null? infractions)
+ '()
+ (list
+ (make-warning package
+ (format #f (G_ "sentences in description should be followed ~
by two spaces; possible infraction~p at ~{~a~^, ~}")
- (length infractions)
- infractions)
- 'description))))
+ (length infractions)
+ infractions)
+ #:field 'description)))))
(let ((description (package-description package)))
(if (string? description)
- (begin
- (check-not-empty description)
- (check-quotes description)
- (check-trademarks description)
- ;; Use raw description for this because Texinfo rendering
- ;; automatically fixes end of sentence space.
- (check-end-of-sentence-space description)
- (and=> (check-texinfo-markup description)
- check-proper-start))
- (emit-warning package
- (format #f (G_ "invalid description: ~s") description)
- 'description))))
+ (append
+ (check-not-empty description)
+ (check-quotes description)
+ (check-trademarks description)
+ ;; Use raw description for this because Texinfo rendering
+ ;; automatically fixes end of sentence space.
+ (check-end-of-sentence-space description)
+ (match (check-texinfo-markup description)
+ ((and warning (? lint-warning?)) (list warning))
+ (plain-description
+ (check-proper-start plain-description))))
+ (list
+ (make-warning package
+ (format #f (G_ "invalid description: ~s") description)
+ #:field 'description)))))
(define (package-input-intersection inputs-to-check input-names)
"Return the intersection between INPUTS-TO-CHECK, the list of input tuples
@@ -281,13 +305,13 @@ of a package, and INPUT-NAMES, a list of package specifications such as
"python-pytest-cov" "python2-pytest-cov"
"python-setuptools-scm" "python2-setuptools-scm"
"python-sphinx" "python2-sphinx")))
- (for-each (lambda (input)
- (emit-warning
- package
- (format #f (G_ "'~a' should probably be a native input")
- input)
- 'inputs-to-check))
- (package-input-intersection inputs input-names))))
+ (map (lambda (input)
+ (make-warning
+ package
+ (format #f (G_ "'~a' should probably be a native input")
+ input)
+ #:field 'inputs))
+ (package-input-intersection inputs input-names))))
(define (check-inputs-should-not-be-an-input-at-all package)
;; Emit a warning if some inputs of PACKAGE are likely to should not be
@@ -296,14 +320,15 @@ of a package, and INPUT-NAMES, a list of package specifications such as
"python2-setuptools"
"python-pip"
"python2-pip")))
- (for-each (lambda (input)
- (emit-warning
- package
- (format #f
- (G_ "'~a' should probably not be an input at all")
- input)))
- (package-input-intersection (package-direct-inputs package)
- input-names))))
+ (map (lambda (input)
+ (make-warning
+ package
+ (format #f
+ (G_ "'~a' should probably not be an input at all")
+ input)
+ #:field 'inputs))
+ (package-input-intersection (package-direct-inputs package)
+ input-names))))
(define (package-name-regexp package)
"Return a regexp that matches PACKAGE's name as a word at the beginning of a
@@ -314,66 +339,71 @@ line."
(define (check-synopsis-style 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)
;; Synopsis should not end with a period, except for some special cases.
- (when (and (string-suffix? "." synopsis)
- (not (string-suffix? "etc." synopsis)))
- (emit-warning package
- (G_ "no period allowed at the end of the synopsis")
- 'synopsis)))
+ (if (and (string-suffix? "." synopsis)
+ (not (string-suffix? "etc." synopsis)))
+ (list
+ (make-warning package
+ (G_ "no period allowed at the end of the synopsis")
+ #:field 'synopsis))
+ '()))
(define check-start-article
;; 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>.
(if (false-if-exception (gnu-package? package))
- (const #t)
+ (const '())
(lambda (synopsis)
- (when (or (string-prefix-ci? "A " synopsis)
- (string-prefix-ci? "An " synopsis))
- (emit-warning package
- (G_ "no article allowed at the beginning of \
+ (if (or (string-prefix-ci? "A " synopsis)
+ (string-prefix-ci? "An " synopsis))
+ (list
+ (make-warning package
+ (G_ "no article allowed at the beginning of \
the synopsis")
- 'synopsis)))))
+ #:field 'synopsis))
+ '()))))
(define (check-synopsis-length synopsis)
- (when (>= (string-length synopsis) 80)
- (emit-warning package
- (G_ "synopsis should be less than 80 characters long")
- 'synopsis)))
+ (if (>= (string-length synopsis) 80)
+ (list
+ (make-warning package
+ (G_ "synopsis should be less than 80 characters long")
+ #:field 'synopsis))
+ '()))
(define (check-proper-start synopsis)
- (unless (properly-starts-sentence? synopsis)
- (emit-warning package
- (G_ "synopsis should start with an upper-case letter or digit")
- 'synopsis)))
+ (if (properly-starts-sentence? synopsis)
+ '()
+ (list
+ (make-warning package
+ (G_ "synopsis should start with an upper-case letter or digit")
+ #:field '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)))
- (emit-warning package
- (G_ "synopsis should not start with the package name")
- 'synopsis)))
+ (list
+ (make-warning package
+ (G_ "synopsis should not start with the package name")
+ #:field 'synopsis))
+ '()))
(define (check-texinfo-markup synopsis)
"Check that SYNOPSIS can be parsed as a Texinfo fragment. If the
markup is valid return a plain-text version of SYNOPSIS, otherwise #f."
(catch #t
- (lambda () (texi->plain-text synopsis))
+ (lambda ()
+ (texi->plain-text synopsis)
+ '())
(lambda (keys . args)
- (emit-warning package
- (G_ "Texinfo markup in synopsis is invalid")
- 'synopsis)
- #f)))
+ (list
+ (make-warning package
+ (G_ "Texinfo markup in synopsis is invalid")
+ #:field 'synopsis)))))
(define checks
- (list check-not-empty
- check-proper-start
+ (list check-proper-start
check-final-period
check-start-article
check-start-with-package-name
@@ -381,13 +411,20 @@ markup is valid return a plain-text version of SYNOPSIS, otherwise #f."
check-texinfo-markup))
(match (package-synopsis package)
+ (""
+ (list
+ (make-warning package
+ (G_ "synopsis should not be empty")
+ #:field 'synopsis)))
((? string? synopsis)
- (for-each (lambda (proc)
- (proc synopsis))
- checks))
+ (append-map
+ (lambda (proc)
+ (proc synopsis))
+ checks))
(invalid
- (emit-warning package (format #f (G_ "invalid synopsis: ~s") invalid)
- 'synopsis))))
+ (list
+ (make-warning package (format #f (G_ "invalid synopsis: ~s") invalid)
+ #:field 'synopsis)))))
(define* (probe-uri uri #:key timeout)
"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))))
(define (validate-uri uri package field)
- "Return #t if the given URI can be reached, otherwise return #f and emit a
-warning for PACKAGE mentionning the FIELD."
+ "Return #t if the given URI can be reached, otherwise return a warning for
+PACKAGE mentionning the FIELD."
(let-values (((status argument)
(probe-uri uri #:timeout 3))) ;wait at most 3 seconds
(case status
@@ -502,71 +539,66 @@ warning for PACKAGE mentionning the FIELD."
;; with a small HTML page upon failure. Attempt to detect
;; such malicious behavior.
(or (> length 1000)
- (begin
- (emit-warning package
- (format #f
- (G_ "URI ~a returned \
+ (make-warning package
+ (format #f
+ (G_ "URI ~a returned \
suspiciously small file (~a bytes)")
- (uri->string uri)
- length))
- #f)))
+ (uri->string uri)
+ length)
+ #:field field)))
(_ #t)))
((= 301 (response-code argument))
(if (response-location argument)
- (begin
- (emit-warning package
- (format #f (G_ "permanent redirect from ~a to ~a")
- (uri->string uri)
- (uri->string
- (response-location argument))))
- #t)
- (begin
- (emit-warning package
- (format #f (G_ "invalid permanent redirect \
+ (make-warning package
+ (format #f (G_ "permanent redirect from ~a to ~a")
+ (uri->string uri)
+ (uri->string
+ (response-location argument)))
+ #:field field)
+ (make-warning package
+ (format #f (G_ "invalid permanent redirect \
from ~a")
- (uri->string uri)))
- #f)))
+ (uri->string uri))
+ #:field field)))
(else
- (emit-warning package
+ (make-warning package
(format #f
(G_ "URI ~a not reachable: ~a (~s)")
(uri->string uri)
(response-code argument)
(response-reason-phrase argument))
- field)
- #f)))
+ #:field field))))
((ftp-response)
(match argument
(('ok) #t)
(('error port command code message)
- (emit-warning package
+ (make-warning package
(format #f
(G_ "URI ~a not reachable: ~a (~s)")
(uri->string uri)
- code (string-trim-both message)))
- #f)))
+ code (string-trim-both message))
+ #:field field))))
((getaddrinfo-error)
- (emit-warning package
+ (make-warning package
(format #f
(G_ "URI ~a domain not found: ~a")
(uri->string uri)
(gai-strerror (car argument)))
- field)
- #f)
+ #:field field))
((system-error)
- (emit-warning package
+ (make-warning package
(format #f
(G_ "URI ~a unreachable: ~a")
(uri->string uri)
(strerror
(system-error-errno
(cons status argument))))
- field)
- #f)
+ #:field field))
((tls-certificate-error)
- (emit-warning package
+ (make-warning package
(format #f (G_ "TLS certificate error: ~a")
- (tls-certificate-error-string argument))))
+ (tls-certificate-error-string argument))
+ #:field field))
((invalid-http-response gnutls-error)
;; Probably a misbehaving server; ignore.
#f)
@@ -581,17 +613,23 @@ from ~a")
(let ((uri (and=> (package-home-page package) string->uri)))
(cond
((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))
- (unless (or (string-contains (package-name package) "bootstrap")
- (string=? (package-name package) "ld-wrapper"))
- (emit-warning package
- (G_ "invalid value for home page")
- 'home-page)))
+ (if (or (string-contains (package-name package) "bootstrap")
+ (string=? (package-name package) "ld-wrapper"))
+ '()
+ (list
+ (make-warning package
+ (G_ "invalid value for home page")
+ #:field 'home-page))))
(else
- (emit-warning package (format #f (G_ "invalid home page URL: ~s")
- (package-home-page package))
- 'home-page)))))
+ (list
+ (make-warning package (format #f (G_ "invalid home page URL: ~s")
+ (package-home-page package))
+ #:field 'home-page))))))
(define %distro-directory
(mlambda ()
@@ -601,42 +639,47 @@ from ~a")
"Emit a warning if the patches requires by PACKAGE are badly named or if the
patch could not be found."
(guard (c ((message-condition? c) ;raised by 'search-patch'
- (emit-warning package (condition-message c)
- 'patch-file-names)))
+ (list
+ (make-warning package (condition-message c)
+ #:field 'patch-file-names))))
(define patches
(or (and=> (package-source package) origin-patches)
'()))
- (unless (every (match-lambda ;patch starts with package name?
- ((? string? patch)
- (and=> (string-contains (basename patch)
- (package-name package))
- zero?))
- (_ #f)) ;must be an <origin> or something like that.
- patches)
- (emit-warning
- package
- (G_ "file names of patches should start with the package name")
- 'patch-file-names))
-
- ;; Check whether we're reaching tar's maximum file name length.
- (let ((prefix (string-length (%distro-directory)))
- (margin (string-length "guix-0.13.0-10-123456789/"))
- (max 99))
- (for-each (match-lambda
+ (append
+ (if (every (match-lambda ;patch starts with package name?
((? string? patch)
- (when (> (+ margin (if (string-prefix? (%distro-directory)
- patch)
- (- (string-length patch) prefix)
- (string-length patch)))
- max)
- (emit-warning
- package
- (format #f (G_ "~a: file name is too long")
- (basename patch))
- 'patch-file-names)))
- (_ #f))
- patches))))
+ (and=> (string-contains (basename patch)
+ (package-name package))
+ zero?))
+ (_ #f)) ;must be an <origin> or something like that.
+ patches)
+ '()
+ (list
+ (make-warning
+ package
+ (G_ "file names of patches should start with the package name")
+ #:field 'patch-file-names)))
+
+ ;; Check whether we're reaching tar's maximum file name length.
+ (let ((prefix (string-length (%distro-directory)))
+ (margin (string-length "guix-0.13.0-10-123456789/"))
+ (max 99))
+ (filter-map (match-lambda
+ ((? string? patch)
+ (if (> (+ margin (if (string-prefix? (%distro-directory)
+ patch)
+ (- (string-length patch) prefix)
+ (string-length patch)))
+ max)
+ (make-warning
+ package
+ (format #f (G_ "~a: file name is too long")
+ (basename patch))
+ #:field 'patch-file-names)
+ #f))
+ (_ #f))
+ patches)))))
(define (escape-quotes str)
"Replace any quote character in STR by an escaped quote character."
@@ -663,32 +706,35 @@ descriptions maintained upstream."
(package-name package)))
(official-gnu-packages*))
(#f ;not a GNU package, so nothing to do
- #t)
+ '())
(descriptor ;a genuine GNU package
- (let ((upstream (gnu-package-doc-summary descriptor))
- (downstream (package-synopsis package))
- (loc (or (package-field-location package 'synopsis)
- (package-location package))))
- (when (and upstream
- (or (not (string? downstream))
- (not (string=? upstream downstream))))
- (format (guix-warning-port)
- (G_ "~a: ~a: proposed synopsis: ~s~%")
- (location->string loc) (package-full-name package)
- upstream)))
-
- (let ((upstream (gnu-package-doc-description descriptor))
- (downstream (package-description package))
- (loc (or (package-field-location package 'description)
- (package-location package))))
- (when (and upstream
- (or (not (string? downstream))
- (not (string=? (fill-paragraph upstream 100)
- (fill-paragraph downstream 100)))))
- (format (guix-warning-port)
- (G_ "~a: ~a: proposed description:~% \"~a\"~%")
- (location->string loc) (package-full-name package)
- (fill-paragraph (escape-quotes upstream) 77 7)))))))
+ (append
+ (let ((upstream (gnu-package-doc-summary descriptor))
+ (downstream (package-synopsis package)))
+ (if (and upstream
+ (or (not (string? downstream))
+ (not (string=? upstream downstream))))
+ (list
+ (make-warning package
+ (format #f (G_ "proposed synopsis: ~s~%")
+ upstream)
+ #:field 'synopsis))
+ '()))
+
+ (let ((upstream (gnu-package-doc-description descriptor))
+ (downstream (package-description package)))
+ (if (and upstream
+ (or (not (string? downstream))
+ (not (string=? (fill-paragraph upstream 100)
+ (fill-paragraph downstream 100)))))
+ (list
+ (make-warning
+ package
+ (format #f
+ (G_ "proposed description:~% \"~a\"~%")
+ (fill-paragraph (escape-quotes upstream) 77 7))
+ #:field 'description))
+ '()))))))
(define (origin-uris origin)
"Return the list of URIs (strings) for ORIGIN."
@@ -701,38 +747,35 @@ descriptions maintained upstream."
(define (check-source package)
"Emit a warning if PACKAGE has an invalid 'source' field, or if that
'source' is not reachable."
- (define (try-uris uris)
- (run-with-state
- (anym %state-monad
- (lambda (uri)
- (with-accumulated-warnings
- (validate-uri uri package 'source)))
- (append-map (cut maybe-expand-mirrors <> %mirrors)
- uris))
- '()))
+ (define (warnings-for-uris uris)
+ (filter lint-warning?
+ (map
+ (lambda (uri)
+ (validate-uri uri package 'source))
+ (append-map (cut maybe-expand-mirrors <> %mirrors)
+ uris))))
(let ((origin (package-source package)))
- (when (and origin
- (eqv? (origin-method origin) url-fetch))
- (let ((uris (map string->uri (origin-uris origin))))
-
- ;; Just make sure that at least one of the URIs is valid.
- (call-with-values
- (lambda () (try-uris uris))
- (lambda (success? warnings)
- ;; When everything fails, report all of WARNINGS, otherwise don't
- ;; report anything.
- ;;
- ;; XXX: Ideally we'd still allow warnings to be raised if *some*
- ;; URIs are unreachable, but distinguish that from the error case
- ;; where *all* the URIs are unreachable.
- (unless success?
- (emit-warning package
- (G_ "all the source URIs are unreachable:")
- 'source)
- (for-each (lambda (warning)
- (display warning (guix-warning-port)))
- (reverse warnings)))))))))
+ (if (and origin
+ (eqv? (origin-method origin) url-fetch))
+ (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.
+ (if (eq? (length uris) (length warnings))
+ ;; When everything fails, report all of WARNINGS, otherwise don't
+ ;; report anything.
+ ;;
+ ;; XXX: Ideally we'd still allow warnings to be raised if *some*
+ ;; URIs are unreachable, but distinguish that from the error case
+ ;; where *all* the URIs are unreachable.
+ (cons*
+ (make-warning package
+ (G_ "all the source URIs are unreachable:")
+ #:field 'source)
+ warnings)
+ '()))
+ '())))
(define (check-source-file-name package)
"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)))))
(let ((origin (package-source package)))
- (unless (or (not origin) (origin-file-name-valid? origin))
- (emit-warning package
- (G_ "the source file name should contain the package name")
- 'source))))
+ (if (or (not origin) (origin-file-name-valid? origin))
+ '()
+ (list
+ (make-warning package
+ (G_ "the source file name should contain the package name")
+ #:field 'source)))))
(define (check-source-unstable-tarball package)
"Emit a warning if PACKAGE's source is an autogenerated tarball."
(define (check-source-uri uri)
- (when (and (string=? (uri-host (string->uri uri)) "github.com")
- (match (split-and-decode-uri-path
- (uri-path (string->uri uri)))
- ((_ _ "archive" _ ...) #t)
- (_ #f)))
- (emit-warning package
- (G_ "the source URI should not be an autogenerated tarball")
- 'source)))
+ (if (and (string=? (uri-host (string->uri uri)) "github.com")
+ (match (split-and-decode-uri-path
+ (uri-path (string->uri uri)))
+ ((_ _ "archive" _ ...) #t)
+ (_ #f)))
+ (make-warning package
+ (G_ "the source URI should not be an autogenerated tarball")
+ #:field 'source)
+ #f))
+
(let ((origin (package-source package)))
- (when (and (origin? origin)
- (eqv? (origin-method origin) url-fetch))
- (let ((uris (origin-uris origin)))
- (for-each check-source-uri uris)))))
+ (if (and (origin? origin)
+ (eqv? (origin-method origin) url-fetch))
+ (filter-map check-source-uri
+ (origin-uris origin))
+ '())))
(define (check-mirror-url package)
"Check whether PACKAGE uses source URLs that should be 'mirror://'."
@@ -776,24 +824,25 @@ descriptions maintained upstream."
(let loop ((mirrors %mirrors))
(match mirrors
(()
- #t)
+ #f)
(((mirror-id mirror-urls ...) rest ...)
(match (find (cut string-prefix? <> uri) mirror-urls)
(#f
(loop rest))
(prefix
- (emit-warning package
+ (make-warning package
(format #f (G_ "URL should be \
'mirror://~a/~a'")
mirror-id
(string-drop uri (string-length prefix)))
- 'source)))))))
+ #:field 'source)))))))
(let ((origin (package-source package)))
- (when (and (origin? origin)
- (eqv? (origin-method origin) url-fetch))
- (let ((uris (origin-uris origin)))
- (for-each check-mirror-uri uris)))))
+ (if (and (origin? origin)
+ (eqv? (origin-method origin) url-fetch))
+ (let ((uris (origin-uris origin)))
+ (filter-map check-mirror-uri uris))
+ '())))
(define* (check-github-url package #:key (timeout 3))
"Check whether PACKAGE uses source URLs that redirect to GitHub."
@@ -817,18 +866,20 @@ descriptions maintained upstream."
(else #f)))
(let ((origin (package-source package)))
- (when (and (origin? origin)
- (eqv? (origin-method origin) url-fetch))
- (for-each
- (lambda (uri)
- (and=> (follow-redirects-to-github uri)
- (lambda (github-uri)
- (unless (string=? github-uri uri)
- (emit-warning
- package
- (format #f (G_ "URL should be '~a'") github-uri)
- 'source)))))
- (origin-uris origin)))))
+ (if (and (origin? origin)
+ (eqv? (origin-method origin) url-fetch))
+ (filter-map
+ (lambda (uri)
+ (and=> (follow-redirects-to-github uri)
+ (lambda (github-uri)
+ (if (string=? github-uri uri)
+ #f
+ (make-warning
+ package
+ (format #f (G_ "URL should be '~a'") github-uri)
+ #:field 'source)))))
+ (origin-uris origin))
+ '())))
(define (check-derivation package)
"Emit a warning if we fail to compile PACKAGE to a derivation."
@@ -836,12 +887,12 @@ descriptions maintained upstream."
(catch #t
(lambda ()
(guard (c ((store-protocol-error? c)
- (emit-warning package
+ (make-warning package
(format #f (G_ "failed to create ~a derivation: ~a")
system
(store-protocol-error-message c))))
((message-condition? c)
- (emit-warning package
+ (make-warning package
(format #f (G_ "failed to create ~a derivation: ~a")
system
(condition-message c)))))
@@ -858,21 +909,23 @@ descriptions maintained upstream."
(package-derivation store replacement system
#:graft? #f)))))))
(lambda args
- (emit-warning package
+ (make-warning package
(format #f (G_ "failed to create ~a derivation: ~s")
system args)))))
- (for-each try (package-supported-systems package)))
+ (filter lint-warning?
+ (map try (package-supported-systems package))))
(define (check-license package)
"Warn about type errors of the 'license' field of PACKAGE."
(match (package-license package)
((or (? license?)
((? license?) ...))
- #t)
+ '())
(x
- (emit-warning package (G_ "invalid license field")
- 'license))))
+ (list
+ (make-warning package (G_ "invalid license field")
+ #:field 'license)))))
(define (call-with-networking-fail-safe message error-value proc)
"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)))
(match (package-vulnerabilities package)
(()
- #t)
+ '())
((vulnerabilities ...)
(let* ((patched (package-patched-vulnerabilities package))
(known-safe (or (assq-ref (package-properties package)
@@ -943,11 +996,14 @@ the NIST server non-fatal."
(or (member id patched)
(member id known-safe))))
vulnerabilities)))
- (unless (null? unpatched)
- (emit-warning package
- (format #f (G_ "probably vulnerable to ~a")
- (string-join (map vulnerability-id unpatched)
- ", ")))))))))
+ (if (null? unpatched)
+ '()
+ (list
+ (make-warning
+ package
+ (format #f (G_ "probably vulnerable to ~a")
+ (string-join (map vulnerability-id unpatched)
+ ", "))))))))))
(define (check-for-updates package)
"Check if there is an update available for PACKAGE."
@@ -957,12 +1013,15 @@ the NIST server non-fatal."
#f
(package-latest-release* package (force %updaters)))
((? upstream-source? source)
- (when (version>? (upstream-source-version source)
- (package-version package))
- (emit-warning package
- (format #f (G_ "can be upgraded to ~a")
- (upstream-source-version source)))))
- (#f #f))) ; cannot find newer upstream release
+ (if (version>? (upstream-source-version source)
+ (package-version package))
+ (list
+ (make-warning package
+ (format #f (G_ "can be upgraded to ~a")
+ (upstream-source-version source))
+ #:field 'version))
+ '()))
+ (#f '()))) ; cannot find newer upstream release
\f
;;;
@@ -974,18 +1033,26 @@ the NIST server non-fatal."
(match (string-index line #\tab)
(#f #t)
(index
- (emit-warning package
+ (make-warning package
(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)
"Warn about trailing white space in LINE."
(unless (or (string=? line (string-trim-right line))
(string=? line (string #\page)))
- (emit-warning package
+ (make-warning package
(format #f
(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)
"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
;; much noise.
(when (> (string-length line) 90)
- (emit-warning package
+ (make-warning package
(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
(make-regexp "^[[:blank:]]*[()]+[[:blank:]]*$"))
@@ -1003,11 +1074,15 @@ the NIST server non-fatal."
(define (report-lone-parentheses package line line-number)
"Emit a warning if LINE contains hanging parentheses."
(when (regexp-exec %hanging-paren-rx line)
- (emit-warning package
+ (make-warning package
(format #f
- (G_ "line ~a: parentheses feel lonely, \
+ (G_ "parentheses feel lonely, \
move to the previous or next line")
- line-number))))
+ line-number)
+ #:location
+ (location (package-file package)
+ line-number
+ 0))))
(define %formatting-reporters
;; List of procedures that report formatting issues. These are not separate
@@ -1040,31 +1115,40 @@ them for PACKAGE."
(call-with-input-file file
(lambda (port)
(let loop ((line-number 1)
- (last-line #f))
+ (last-line #f)
+ (warnings '()))
(let ((line (read-line port)))
- (or (eof-object? line)
- (and last-line (> line-number last-line))
+ (if (or (eof-object? line)
+ (and last-line (> line-number last-line)))
+ warnings
(if (and (= line-number starting-line)
(not last-line))
(loop (+ 1 line-number)
- (+ 1 (sexp-last-line port)))
- (begin
- (unless (< line-number starting-line)
- (for-each (lambda (report)
- (report package line line-number))
- reporters))
- (loop (+ 1 line-number) last-line)))))))))
+ (+ 1 (sexp-last-line port))
+ warnings)
+ (loop (+ 1 line-number)
+ last-line
+ (append
+ warnings
+ (if (< line-number starting-line)
+ '()
+ (filter
+ lint-warning?
+ (map (lambda (report)
+ (report package line line-number))
+ reporters))))))))))))
(define (check-formatting package)
"Check the formatting of the source code of PACKAGE."
(let ((location (package-location package)))
- (when location
- (and=> (search-path %load-path (location-file location))
- (lambda (file)
- ;; Report issues starting from the line before the 'package'
- ;; form, which usually contains the 'define' form.
- (report-formatting-issues package file
- (- (location-line location) 1)))))))
+ (if location
+ (and=> (search-path %load-path (location-file location))
+ (lambda (file)
+ ;; Report issues starting from the line before the 'package'
+ ;; form, which usually contains the 'define' form.
+ (report-formatting-issues package file
+ (- (location-line location) 1))))
+ '())))
\f
;;;
@@ -1155,7 +1239,8 @@ or a list thereof")
(package-name package) (package-version package)
(lint-checker-name checker))
(force-output (current-error-port)))
- ((lint-checker-check checker) package))
+ (emit-warnings
+ ((lint-checker-check checker) package)))
checkers)
(when tty?
(format (current-error-port) "\x1b[K")
diff --git a/tests/lint.scm b/tests/lint.scm
index dc2b17aeec..d8b2ca54cd 100644
--- a/tests/lint.scm
+++ b/tests/lint.scm
@@ -44,7 +44,12 @@
#: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.
@@ -60,781 +65,696 @@
(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))))
+
\f
(test-begin "lint")
-(define (call-with-warnings thunk)
- (let ((port (open-output-string)))
- (parameterize ((guix-warning-port port))
- (thunk))
- (get-output-string port)))
-
-(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
- (let ((pkg (dummy-package "x"
- (description ""))))
- (check-description-style pkg)))
- "description should not be empty")))
-
-(test-assert "description: valid Texinfo markup"
- (->bool
- (string-contains
- (with-warnings
- (check-description-style (dummy-package "x" (description "f{oo}b@r"))))
- "Texinfo markup in description is invalid")))
-
-(test-assert "description: does not start with an upper-case letter"
- (->bool
- (string-contains (with-warnings
- (let ((pkg (dummy-package "x"
- (description "bad description."))))
- (check-description-style pkg)))
- "description should start with an upper-case letter")))
-
-(test-assert "description: may start with a digit"
- (string-null?
- (with-warnings
- (let ((pkg (dummy-package "x"
- (description "2-component library."))))
- (check-description-style pkg)))))
-
-(test-assert "description: may start with lower-case package name"
- (string-null?
- (with-warnings
- (let ((pkg (dummy-package "x"
- (description "x is a dummy package."))))
- (check-description-style pkg)))))
-
-(test-assert "description: two spaces after end of sentence"
- (->bool
- (string-contains (with-warnings
- (let ((pkg (dummy-package "x"
- (description "Bad. Quite bad."))))
- (check-description-style pkg)))
- "sentences in description should be followed by two spaces")))
-
-(test-assert "description: end-of-sentence detection with abbreviations"
- (string-null?
- (with-warnings
- (let ((pkg (dummy-package "x"
- (description
- "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 "description: suggest ornament instead of quotes"
- (->bool
- (string-contains (with-warnings
- (let ((pkg (dummy-package "x"
- (description "This is a 'quoted' thing."))))
- (check-description-style pkg)))
- "use @code")))
-
-(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
- (let ((pkg (dummy-package "x"
- (synopsis ""))))
- (check-synopsis-style pkg)))
- "synopsis should not be empty")))
-
-(test-assert "synopsis: valid Texinfo markup"
- (->bool
- (string-contains
- (with-warnings
- (check-synopsis-style (dummy-package "x" (synopsis "Bad $@ texinfo"))))
- "Texinfo markup in synopsis is invalid")))
-
-(test-assert "synopsis: does not start with an upper-case letter"
- (->bool
- (string-contains (with-warnings
- (let ((pkg (dummy-package "x"
- (synopsis "bad synopsis."))))
- (check-synopsis-style pkg)))
- "synopsis should start with an upper-case letter")))
-
-(test-assert "synopsis: may start with a digit"
- (string-null?
- (with-warnings
- (let ((pkg (dummy-package "x"
- (synopsis "5-dimensional frobnicator"))))
- (check-synopsis-style pkg)))))
-
-(test-assert "synopsis: ends with a period"
- (->bool
- (string-contains (with-warnings
- (let ((pkg (dummy-package "x"
- (synopsis "Bad synopsis."))))
- (check-synopsis-style pkg)))
- "no period allowed at the end of the synopsis")))
-
-(test-assert "synopsis: ends with 'etc.'"
- (string-null? (with-warnings
- (let ((pkg (dummy-package "x"
- (synopsis "Foo, bar, etc."))))
- (check-synopsis-style pkg)))))
-
-(test-assert "synopsis: starts with 'A'"
- (->bool
- (string-contains (with-warnings
- (let ((pkg (dummy-package "x"
- (synopsis "A bad synopŝis"))))
- (check-synopsis-style pkg)))
- "no article allowed at the beginning of the synopsis")))
-
-(test-assert "synopsis: starts with 'An'"
- (->bool
- (string-contains (with-warnings
- (let ((pkg (dummy-package "x"
- (synopsis "An awful synopsis"))))
- (check-synopsis-style pkg)))
- "no article allowed at the beginning of the synopsis")))
-
-(test-assert "synopsis: starts with 'a'"
- (->bool
- (string-contains (with-warnings
- (let ((pkg (dummy-package "x"
- (synopsis "a bad synopsis"))))
- (check-synopsis-style pkg)))
- "no article allowed at the beginning of the synopsis")))
-
-(test-assert "synopsis: starts with 'an'"
- (->bool
- (string-contains (with-warnings
- (let ((pkg (dummy-package "x"
- (synopsis "an awful synopsis"))))
- (check-synopsis-style pkg)))
- "no article allowed at the beginning of the synopsis")))
-
-(test-assert "synopsis: too long"
- (->bool
- (string-contains (with-warnings
- (let ((pkg (dummy-package "x"
- (synopsis (make-string 80 #\x)))))
- (check-synopsis-style pkg)))
- "synopsis should be less than 80 characters long")))
-
-(test-assert "synopsis: start with package name"
- (->bool
- (string-contains (with-warnings
- (let ((pkg (dummy-package "x"
- (name "foo")
- (synopsis "foo, a nice package"))))
- (check-synopsis-style pkg)))
- "synopsis should not start with the package name")))
-
-(test-assert "synopsis: start with package name prefix"
- (string-null?
- (with-warnings
- (let ((pkg (dummy-package "arb"
- (synopsis "Arbitrary precision"))))
- (check-synopsis-style pkg)))))
-
-(test-assert "synopsis: start with abbreviation"
- (string-null?
- (with-warnings
- (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-assert "inputs: pkg-config is probably a native input"
- (->bool
- (string-contains
- (with-warnings
- (let ((pkg (dummy-package "x"
- (inputs `(("pkg-config" ,pkg-config))))))
- (check-inputs-should-be-native pkg)))
- "'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
+(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)"
- (->bool
- (string-contains
- (with-warnings
- (let ((pkg (dummy-package "x"
- (inputs `(("python-setuptools" ,python-setuptools))))))
- (check-inputs-should-not-be-an-input-at-all pkg)))
- "'python-setuptools' should probably not be an input at all")))
-
-(test-assert
+ "'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)"
- (->bool
- (string-contains
- (with-warnings
- (let ((pkg (dummy-package "x"
- (native-inputs
- `(("python-setuptools" ,python-setuptools))))))
- (check-inputs-should-not-be-an-input-at-all pkg)))
- "'python-setuptools' should probably not be an input at all")))
-
-(test-assert
+ "'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)"
- (->bool
- (string-contains
- (with-warnings
- (let ((pkg (dummy-package "x"
- (propagated-inputs
- `(("python-setuptools" ,python-setuptools))))))
- (check-inputs-should-not-be-an-input-at-all pkg)))
- "'python-setuptools' should probably not be an input at all")))
-
-(test-assert "patches: file names"
- (->bool
- (string-contains
- (with-warnings
- (let ((pkg (dummy-package "x"
- (source
- (dummy-origin
- (patches (list "/path/to/y.patch")))))))
- (check-patch-file-names pkg)))
- "file names of patches should start with the package name")))
-
-(test-assert "patches: file name too long"
- (->bool
- (string-contains
- (with-warnings
- (let ((pkg (dummy-package "x"
- (source
- (dummy-origin
- (patches (list (string-append "x-"
- (make-string 100 #\a)
- ".patch"))))))))
- (check-patch-file-names pkg)))
- "file name is too long")))
-
-(test-assert "patches: not found"
- (->bool
- (string-contains
- (with-warnings
- (let ((pkg (dummy-package "x"
- (source
- (dummy-origin
- (patches
- (list (search-patch "this-patch-does-not-exist!"))))))))
- (check-patch-file-names pkg)))
- "patch not found")))
-
-(test-assert "derivation: invalid arguments"
- (->bool
- (string-contains
- (with-warnings
- (let ((pkg (dummy-package "x"
- (arguments
- '(#:imported-modules (invalid-module))))))
- (check-derivation pkg)))
- "failed to create")))
-
-(test-assert "license: invalid license"
- (string-contains
- (with-warnings
- (check-license (dummy-package "x" (license #f))))
- "invalid license"))
-
-(test-assert "home-page: wrong home-page"
- (->bool
- (string-contains
- (with-warnings
- (let ((pkg (package
- (inherit (dummy-package "x"))
- (home-page #f))))
- (check-home-page pkg)))
- "invalid")))
-
-(test-assert "home-page: invalid URI"
- (->bool
- (string-contains
- (with-warnings
- (let ((pkg (package
- (inherit (dummy-package "x"))
- (home-page "foobar"))))
- (check-home-page pkg)))
- "invalid home page URL")))
-
-(test-assert "home-page: host not found"
- (->bool
- (string-contains
- (with-warnings
- (let ((pkg (package
- (inherit (dummy-package "x"))
- (home-page "http://does-not-exist"))))
- (check-home-page pkg)))
- "domain not found")))
+ "'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-assert "home-page: Connection refused"
- (->bool
- (string-contains
- (with-warnings
- (let ((pkg (package
- (inherit (dummy-package "x"))
- (home-page (%local-url)))))
- (check-home-page pkg)))
- "Connection refused")))
+(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-warnings
- (with-http-server 200 %long-string
- (let ((pkg (package
- (inherit (dummy-package "x"))
- (home-page (%local-url)))))
- (check-home-page pkg)))))
+ '()
+ (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-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-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-assert "home-page: 404"
- (->bool
- (string-contains
- (with-warnings
- (with-http-server 404 %long-string
- (let ((pkg (package
- (inherit (dummy-package "x"))
- (home-page (%local-url)))))
- (check-home-page pkg))))
- "not reachable: 404")))
+(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-assert "home-page: 301, invalid"
- (->bool
- (string-contains
- (with-warnings
- (with-http-server 301 %long-string
- (let ((pkg (package
- (inherit (dummy-package "x"))
- (home-page (%local-url)))))
- (check-home-page pkg))))
- "invalid permanent redirect")))
+(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-assert "home-page: 301 -> 200"
- (->bool
- (string-contains
- (with-warnings
- (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)))))
- (check-home-page pkg)))))))
- "permanent redirect")))
+(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-assert "home-page: 301 -> 404"
- (->bool
- (string-contains
- (with-warnings
- (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)))))
- (check-home-page pkg)))))))
- "not reachable: 404")))
-
-(test-assert "source-file-name"
- (->bool
- (string-contains
- (with-warnings
- (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))))))
- (check-source-file-name pkg)))
- "file name should contain the package name")))
-
-(test-assert "source-file-name: v prefix"
- (->bool
- (string-contains
- (with-warnings
- (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))))))
- (check-source-file-name pkg)))
- "file name should contain the package name")))
-
-(test-assert "source-file-name: bad checkout"
- (->bool
- (string-contains
- (with-warnings
- (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))))))
- (check-source-file-name pkg)))
- "file name should contain the package name")))
-
-(test-assert "source-file-name: good checkout"
- (not
- (->bool
- (string-contains
- (with-warnings
- (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)))
- "file name should contain the package name"))))
-
-(test-assert "source-file-name: valid"
- (not
- (->bool
- (string-contains
- (with-warnings
- (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)))
- "file name should contain the package name"))))
-
-(test-assert "source-unstable-tarball"
- (string-contains
- (with-warnings
- (let ((pkg (dummy-package "x"
- (source
- (origin
- (method url-fetch)
- (uri "https://github.com/example/example/archive/v0.0.tar.gz")
- (sha256 %null-sha256))))))
- (check-source-unstable-tarball pkg)))
- "source URI should not be an autogenerated tarball"))
-
-(test-assert "source-unstable-tarball: source #f"
- (not
- (->bool
- (string-contains
- (with-warnings
- (let ((pkg (dummy-package "x"
- (source #f))))
- (check-source-unstable-tarball pkg)))
- "source URI should not be an autogenerated tarball"))))
-
-(test-assert "source-unstable-tarball: valid"
- (not
- (->bool
- (string-contains
- (with-warnings
- (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)))
- "source URI should not be an autogenerated tarball"))))
-
-(test-assert "source-unstable-tarball: package named archive"
- (not
- (->bool
- (string-contains
- (with-warnings
- (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)))
- "source URI should not be an autogenerated tarball"))))
-
-(test-assert "source-unstable-tarball: not-github"
- (not
- (->bool
- (string-contains
- (with-warnings
- (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)))
- "source URI should not be an autogenerated tarball"))))
-
-(test-assert "source-unstable-tarball: git-fetch"
- (not
- (->bool
- (string-contains
- (with-warnings
- (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)))
- "source URI should not be an autogenerated tarball"))))
+(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-skip (if (http-server-can-listen?) 0 1))
-(test-equal "source: 200"
- ""
- (with-warnings
- (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-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-skip (if (http-server-can-listen?) 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
+(test-equal "source-unstable-tarball: package named archive"
+ '()
+ (let ((pkg (dummy-package "x"
+ (source
+ (origin
(method url-fetch)
- (uri (%local-url))
+ (uri "https://github.com/example/archive/releases/download/x-0.0/x-0.0.tar.gz")
(sha256 %null-sha256))))))
- (check-source pkg))))
- "suspiciously small")))
+ (check-source-unstable-tarball pkg)))
-(test-skip (if (http-server-can-listen?) 0 1))
-(test-assert "source: 404"
- (->bool
- (string-contains
- (with-warnings
- (with-http-server 404 %long-string
- (let ((pkg (package
- (inherit (dummy-package "x"))
- (source (origin
+(test-equal "source-unstable-tarball: not-github"
+ '()
+ (let ((pkg (dummy-package "x"
+ (source
+ (origin
(method url-fetch)
- (uri (%local-url))
+ (uri "https://bitbucket.org/archive/example/download/x-0.0.tar.gz")
(sha256 %null-sha256))))))
- (check-source pkg))))
- "not reachable: 404")))
+ (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"
- ""
- (with-warnings
- (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))))))
- (check-source pkg))))))))
+ "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-assert "source: 301 -> 404"
- (->bool
- (string-contains
- (with-warnings
- (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))))))
- (check-source pkg)))))))
- "not reachable: 404")))
-
-(test-assert "mirror-url"
- (string-null?
- (with-warnings
- (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-assert "mirror-url: one suggestion"
- (string-contains
- (with-warnings
- (let ((source (origin
- (method url-fetch)
- (uri "http://ftp.gnu.org/pub/gnu/foo/foo.tar.gz")
- (sha256 %null-sha256))))
- (check-mirror-url (dummy-package "x" (source source)))))
- "mirror://gnu/foo/foo.tar.gz"))
-
-(test-assert "github-url"
- (string-null?
- (with-warnings
- (with-http-server 200 %long-string
- (check-github-url
- (dummy-package "x" (source
- (origin
- (method url-fetch)
- (uri (%local-url))
- (sha256 %null-sha256)))))))))
+(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-assert "github-url: one suggestion"
- (string-contains
- (with-warnings
- (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)))) ""
- (check-github-url
- (dummy-package "x" (source
- (origin
- (method url-fetch)
- (uri (%local-url))
- (sha256 %null-sha256))))))))))
- github-url))
- (test-assert "github-url: already the correct github url"
- (string-null?
- (with-warnings
- (check-github-url
- (dummy-package "x" (source
- (origin
- (method url-fetch)
- (uri github-url)
- (sha256 %null-sha256)))))))))
-
-(test-assert "cve"
+ (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 '()))
- (string-null?
- (with-warnings (check-vulnerabilities (dummy-package "x"))))))
+ (check-vulnerabilities (dummy-package "x"))))
-(test-assert "cve: one vulnerability"
+(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)))))))
- (string-contains
- (with-warnings
- (check-vulnerabilities (dummy-package "pi" (version "3.14"))))
- "vulnerable to CVE-2015-1234")))
+ (single-lint-warning-message
+ (check-vulnerabilities (dummy-package "pi" (version "3.14"))))))
-(test-assert "cve: one patched vulnerability"
+(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)))))))
- (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: known safe from vulnerability"
+ (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)))))))
- (string-null?
- (with-warnings
- (check-vulnerabilities
- (dummy-package "pi"
- (version "3.14")
- (properties `((lint-hidden-cve . ("CVE-2015-1234"))))))))))
-
-(test-assert "cve: vulnerability fixed in replacement version"
+ (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)
@@ -845,71 +765,60 @@
(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"
+ (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)))))))
- (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
- (check-formatting
- (
- dummy-package "ugly as hell!"
- )
- ))
- "lonely"))
+ (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-contains
- (with-warnings
- (check-formatting (dummy-package "leave the tab here: ")))
- "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-contains
- (with-warnings
- ;; Leave the trailing white space on the next line!
- (check-formatting (dummy-package "x")))
- "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-contains
- (with-warnings
- (check-formatting
- (dummy-package "x" ;here is a stupid comment just to make a long line
- )))
- "too long"))
-
-(test-assert "formatting: alright"
- (string-null?
- (with-warnings
- (check-formatting (dummy-package "x")))))
+ (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")
--
2.21.0
^ permalink raw reply related [flat|nested] 37+ messages in thread
* [bug#35790] [PATCH] scripts: lint: Handle warnings with a record type.
2019-05-21 14:41 ` Ludovic Courtès
2019-06-01 18:31 ` Christopher Baines
@ 2019-06-01 19:09 ` Christopher Baines
2019-06-07 7:38 ` Ludovic Courtès
1 sibling, 1 reply; 37+ messages in thread
From: Christopher Baines @ 2019-06-01 19:09 UTC (permalink / raw)
To: Ludovic Courtès; +Cc: 35790
[-- Attachment #1: Type: text/plain, Size: 3570 bytes --]
Ludovic Courtès <ludo@gnu.org> writes:
> Hello!
>
> Christopher Baines <mail@cbaines.net> skribis:
>
>> 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.
>
> Yay!
>
>> + <lint-warning>
>
> As a rule of thumb, it’s best to not export the record type descriptor
> (RTD) because then anything could happen. In this case, I think the
> tests would be just as readable if we used ‘lint-warning-message’ &
> co. instead of matching on the record.
>
> WDYT?
Interesting. I've now adjusted the tests accordingly and sent an updated
patch.
I've stuck with using match, as this gives much better error messages
than using car, or lint-warning-message without checking the thing your
working with is actually a list with a single warning. I've wrapped this
up as a single-lint-warning-message that many of the tests use.
>> +(define* (make-warning package message
>> + #:key field location)
>> + (make-lint-warning
>> + package
>> + message
>
> In practice MESSAGE is already translated. I think it would be more
> flexible if it were not; ‘lint-warning-message’ would always return the
> English message, and it’d be up to the user to call ‘gettext’ on it,
> like we do for package descriptions.
>
> To achieve this, you’d need a little trick so that ‘xgettext’ can still
> extract the messages, like:
>
>
> (define-syntax-rule make-warning
> (syntax-rule (G_)
> ((_ package (G_ message) rest ...)
> (%make-warning package message rest ...))))
>
> where ‘%make-warning’ is the procedure you define above.
>
> Then you need an explicit call to ‘G_’ at the point where messages are
> displayed.
>
> Does that make sense?
Yes, but I'm unsure it'll work for all the messages.
Some of them it translates a format string first, then uses that format
string, and that becomes the message, e.g.
(format #f (G_ "invalid description: ~s") description)
Given that you'd be trying to get the translation for "invalid
description: guile" for example, I'm not sure you can defer the
translation without also defering customising the message, if that makes
sense?
I haven't actually tried this yet, so I could be wrong.
>> +(define (append-warnings . args)
>> + (fold (lambda (arg warnings)
>> + (cond
>> + ((list? arg)
>> + (append warnings
>> + (filter lint-warning?
>> + arg)))
>> + ((lint-warning? arg)
>> + (append warnings
>> + (list arg)))
>> + (else warnings)))
>> + '()
>> + args))
>
> I always feel that we should have procedures that operate on lists of
> anything, like ‘append’, and thus ‘append-warnings’ looks like an
> anti-pattern to me.
>
> What about simply ensuring that every checker returns a list of
> <lint-warning>s? That way, we wouldn’t have to do such things, I think.
I did consider that initially, but it involved restructuring the code
even more, so I put it off. In this latest patch though, I have adjusted
it so all the checkers return lists of warnings.
Thanks for taking a look :)
Chris
[-- Attachment #2: signature.asc --]
[-- Type: application/pgp-signature, Size: 962 bytes --]
^ permalink raw reply [flat|nested] 37+ messages in thread
* [bug#35790] [PATCH] scripts: lint: Handle warnings with a record type.
2019-06-01 19:09 ` Christopher Baines
@ 2019-06-07 7:38 ` Ludovic Courtès
2019-06-16 12:56 ` [bug#35790] [PATCH] scripts: lint: Separate the message warning text and data Christopher Baines
2019-06-16 13:05 ` [bug#35790] [PATCH] scripts: lint: Handle warnings with a record type Christopher Baines
0 siblings, 2 replies; 37+ messages in thread
From: Ludovic Courtès @ 2019-06-07 7:38 UTC (permalink / raw)
To: Christopher Baines; +Cc: 35790
Hello,
Christopher Baines <mail@cbaines.net> skribis:
> Ludovic Courtès <ludo@gnu.org> writes:
[...]
>>> +(define* (make-warning package message
>>> + #:key field location)
>>> + (make-lint-warning
>>> + package
>>> + message
>>
>> In practice MESSAGE is already translated. I think it would be more
>> flexible if it were not; ‘lint-warning-message’ would always return the
>> English message, and it’d be up to the user to call ‘gettext’ on it,
>> like we do for package descriptions.
>>
>> To achieve this, you’d need a little trick so that ‘xgettext’ can still
>> extract the messages, like:
>>
>>
>> (define-syntax-rule make-warning
>> (syntax-rule (G_)
>> ((_ package (G_ message) rest ...)
>> (%make-warning package message rest ...))))
>>
>> where ‘%make-warning’ is the procedure you define above.
>>
>> Then you need an explicit call to ‘G_’ at the point where messages are
>> displayed.
>>
>> Does that make sense?
>
> Yes, but I'm unsure it'll work for all the messages.
>
> Some of them it translates a format string first, then uses that format
> string, and that becomes the message, e.g.
>
> (format #f (G_ "invalid description: ~s") description)
>
> Given that you'd be trying to get the translation for "invalid
> description: guile" for example, I'm not sure you can defer the
> translation without also defering customising the message, if that makes
> sense?
Good point!
A possibility would be to pass ‘make-warning’ a ‘format’ list instead of
a single string:
(make-warning package (list (G_ "~a is bad") 'something) …)
That’d solve the problem but it’d have to be packaged nicely to avoid
having too much boilerplate.
WDYT?
Thanks,
Ludo’.
^ permalink raw reply [flat|nested] 37+ messages in thread
* [bug#35790] [PATCH] scripts: lint: Handle warnings with a record type.
2019-06-01 18:31 ` Christopher Baines
@ 2019-06-07 7:44 ` Ludovic Courtès
2019-06-16 13:00 ` Christopher Baines
0 siblings, 1 reply; 37+ messages in thread
From: Ludovic Courtès @ 2019-06-07 7:44 UTC (permalink / raw)
To: Christopher Baines; +Cc: 35790
Hello,
Christopher Baines <mail@cbaines.net> skribis:
> 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.
I like it!
Maybe we should just ignore the i18n issue for now and keep
already-translated messages in <lint-warning>.
One question I have: before, warnings would be emitted as we go; now, we
first collect all the warnings for a given package, and emit all of them
at once. How does it look in terms of UX?
Perhaps an improvement would be to use SRFI-41 streams instead of lists
to address this issue, but… future work. :-)
WDYT?
Ludo’.
^ permalink raw reply [flat|nested] 37+ messages in thread
* [bug#35790] [PATCH] scripts: lint: Separate the message warning text and data.
2019-06-07 7:38 ` Ludovic Courtès
@ 2019-06-16 12:56 ` Christopher Baines
2019-06-24 8:36 ` Ludovic Courtès
2019-06-16 13:05 ` [bug#35790] [PATCH] scripts: lint: Handle warnings with a record type Christopher Baines
1 sibling, 1 reply; 37+ messages in thread
From: Christopher Baines @ 2019-06-16 12:56 UTC (permalink / raw)
To: 35790
So that translations can be handled more flexibly, rather than having to
translate the message text within the checker.
---
guix/scripts/lint.scm | 194 ++++++++++++++++++++++--------------------
1 file changed, 104 insertions(+), 90 deletions(-)
diff --git a/guix/scripts/lint.scm b/guix/scripts/lint.scm
index 1b08068669..d1919d8e0a 100644
--- a/guix/scripts/lint.scm
+++ b/guix/scripts/lint.scm
@@ -88,6 +88,8 @@
lint-warning?
lint-warning-package
lint-warning-message
+ lint-warning-message-text
+ lint-warning-message-data
lint-warning-location
%checkers
@@ -105,35 +107,51 @@
(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)))
+ (package lint-warning-package)
+ (message-text lint-warning-message-text)
+ (message-data lint-warning-message-data
+ (default '()))
+ (location lint-warning-location
+ (default #f)))
+
+(define (lint-warning-message warning)
+ (apply format #f
+ (G_ (lint-warning-message-text warning))
+ (lint-warning-message-data warning)))
(define (package-file package)
(location-file
(package-location package)))
-(define* (make-warning package message
- #:key field location)
+(define* (%make-warning package message-text
+ #:optional (message-data '())
+ #:key field location)
(make-lint-warning
package
- message
+ message-text
+ message-data
(or location
(package-field-location package field)
(package-location package))))
+(define-syntax make-warning
+ (syntax-rules (G_)
+ ((_ package (G_ message) rest ...)
+ (%make-warning package message rest ...))
+ ((_ package message rest ...)
+ (%make-warning package message rest ...))))
+
(define (emit-warnings warnings)
;; 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
;; provided MESSAGE.
(for-each
(match-lambda
- (($ <lint-warning> package message loc)
+ (($ <lint-warning> package message-text message-data loc)
(format (guix-warning-port) "~a: ~a@~a: ~a~%"
(location->string loc)
(package-name package) (package-version package)
- message)))
+ (apply format #f (G_ message-text) message-data))))
warnings))
\f
@@ -199,9 +217,9 @@ http://www.gnu.org/prep/standards/html_node/Trademarks.html."
((and (? number?) index)
(list
(make-warning package
- (format #f (G_ "description should not contain ~
+ (G_ "description should not contain ~
trademark sign '~a' at ~d")
- (string-ref description index) index)
+ (list (string-ref description index) index)
#:field 'description)))
(else '())))
@@ -242,10 +260,10 @@ trademark sign '~a' at ~d")
'()
(list
(make-warning package
- (format #f (G_ "sentences in description should be followed ~
+ (G_ "sentences in description should be followed ~
by two spaces; possible infraction~p at ~{~a~^, ~}")
- (length infractions)
- infractions)
+ (list (length infractions)
+ infractions)
#:field 'description)))))
(let ((description (package-description package)))
@@ -263,7 +281,8 @@ by two spaces; possible infraction~p at ~{~a~^, ~}")
(check-proper-start plain-description))))
(list
(make-warning package
- (format #f (G_ "invalid description: ~s") description)
+ (G_ "invalid description: ~s")
+ (list description)
#:field 'description)))))
(define (package-input-intersection inputs-to-check input-names)
@@ -308,8 +327,8 @@ of a package, and INPUT-NAMES, a list of package specifications such as
(map (lambda (input)
(make-warning
package
- (format #f (G_ "'~a' should probably be a native input")
- input)
+ (G_ "'~a' should probably be a native input")
+ (list input)
#:field 'inputs))
(package-input-intersection inputs input-names))))
@@ -323,9 +342,8 @@ of a package, and INPUT-NAMES, a list of package specifications such as
(map (lambda (input)
(make-warning
package
- (format #f
- (G_ "'~a' should probably not be an input at all")
- input)
+ (G_ "'~a' should probably not be an input at all")
+ (list input)
#:field 'inputs))
(package-input-intersection (package-direct-inputs package)
input-names))))
@@ -423,7 +441,9 @@ markup is valid return a plain-text version of SYNOPSIS, otherwise #f."
checks))
(invalid
(list
- (make-warning package (format #f (G_ "invalid synopsis: ~s") invalid)
+ (make-warning package
+ (G_ "invalid synopsis: ~s")
+ (list invalid)
#:field 'synopsis)))))
(define* (probe-uri uri #:key timeout)
@@ -540,64 +560,59 @@ PACKAGE mentionning the FIELD."
;; such malicious behavior.
(or (> length 1000)
(make-warning package
- (format #f
- (G_ "URI ~a returned \
+ (G_ "URI ~a returned \
suspiciously small file (~a bytes)")
- (uri->string uri)
- length)
+ (list (uri->string uri)
+ length)
#:field field)))
(_ #t)))
((= 301 (response-code argument))
(if (response-location argument)
(make-warning package
- (format #f (G_ "permanent redirect from ~a to ~a")
- (uri->string uri)
- (uri->string
- (response-location argument)))
+ (G_ "permanent redirect from ~a to ~a")
+ (list (uri->string uri)
+ (uri->string
+ (response-location argument)))
#:field field)
(make-warning package
- (format #f (G_ "invalid permanent redirect \
+ (G_ "invalid permanent redirect \
from ~a")
- (uri->string uri))
+ (list (uri->string uri))
#:field field)))
(else
(make-warning package
- (format #f
- (G_ "URI ~a not reachable: ~a (~s)")
- (uri->string uri)
- (response-code argument)
- (response-reason-phrase argument))
+ (G_ "URI ~a not reachable: ~a (~s)")
+ (list (uri->string uri)
+ (response-code argument)
+ (response-reason-phrase argument))
#:field field))))
((ftp-response)
(match argument
(('ok) #t)
(('error port command code message)
(make-warning package
- (format #f
- (G_ "URI ~a not reachable: ~a (~s)")
- (uri->string uri)
- code (string-trim-both message))
+ (G_ "URI ~a not reachable: ~a (~s)")
+ (list (uri->string uri)
+ code (string-trim-both message))
#:field field))))
((getaddrinfo-error)
(make-warning package
- (format #f
- (G_ "URI ~a domain not found: ~a")
- (uri->string uri)
- (gai-strerror (car argument)))
+ (G_ "URI ~a domain not found: ~a")
+ (list (uri->string uri)
+ (gai-strerror (car argument)))
#:field field))
((system-error)
(make-warning package
- (format #f
- (G_ "URI ~a unreachable: ~a")
- (uri->string uri)
- (strerror
- (system-error-errno
- (cons status argument))))
+ (G_ "URI ~a unreachable: ~a")
+ (list (uri->string uri)
+ (strerror
+ (system-error-errno
+ (cons status argument))))
#:field field))
((tls-certificate-error)
(make-warning package
- (format #f (G_ "TLS certificate error: ~a")
- (tls-certificate-error-string argument))
+ (G_ "TLS certificate error: ~a")
+ (list (tls-certificate-error-string argument))
#:field field))
((invalid-http-response gnutls-error)
;; Probably a misbehaving server; ignore.
@@ -627,8 +642,9 @@ from ~a")
#:field 'home-page))))
(else
(list
- (make-warning package (format #f (G_ "invalid home page URL: ~s")
- (package-home-page package))
+ (make-warning package
+ (G_ "invalid home page URL: ~s")
+ (list (package-home-page package))
#:field 'home-page))))))
(define %distro-directory
@@ -674,8 +690,8 @@ patch could not be found."
max)
(make-warning
package
- (format #f (G_ "~a: file name is too long")
- (basename patch))
+ (G_ "~a: file name is too long")
+ (list (basename patch))
#:field 'patch-file-names)
#f))
(_ #f))
@@ -716,8 +732,8 @@ descriptions maintained upstream."
(not (string=? upstream downstream))))
(list
(make-warning package
- (format #f (G_ "proposed synopsis: ~s~%")
- upstream)
+ (G_ "proposed synopsis: ~s~%")
+ (list upstream)
#:field 'synopsis))
'()))
@@ -730,9 +746,8 @@ descriptions maintained upstream."
(list
(make-warning
package
- (format #f
- (G_ "proposed description:~% \"~a\"~%")
- (fill-paragraph (escape-quotes upstream) 77 7))
+ (G_ "proposed description:~% \"~a\"~%")
+ (list (fill-paragraph (escape-quotes upstream) 77 7))
#:field 'description))
'()))))))
@@ -831,10 +846,10 @@ descriptions maintained upstream."
(loop rest))
(prefix
(make-warning package
- (format #f (G_ "URL should be \
+ (G_ "URL should be \
'mirror://~a/~a'")
- mirror-id
- (string-drop uri (string-length prefix)))
+ (list mirror-id
+ (string-drop uri (string-length prefix)))
#:field 'source)))))))
(let ((origin (package-source package)))
@@ -876,7 +891,8 @@ descriptions maintained upstream."
#f
(make-warning
package
- (format #f (G_ "URL should be '~a'") github-uri)
+ (G_ "URL should be '~a'")
+ (list github-uri)
#:field 'source)))))
(origin-uris origin))
'())))
@@ -888,14 +904,14 @@ descriptions maintained upstream."
(lambda ()
(guard (c ((store-protocol-error? c)
(make-warning package
- (format #f (G_ "failed to create ~a derivation: ~a")
- system
- (store-protocol-error-message c))))
+ (G_ "failed to create ~a derivation: ~a")
+ (list system
+ (store-protocol-error-message c))))
((message-condition? c)
(make-warning package
- (format #f (G_ "failed to create ~a derivation: ~a")
- system
- (condition-message c)))))
+ (G_ "failed to create ~a derivation: ~a")
+ (list system
+ (condition-message c)))))
(with-store store
;; Disable grafts since it can entail rebuilds.
(parameterize ((%graft? #f))
@@ -910,8 +926,8 @@ descriptions maintained upstream."
#:graft? #f)))))))
(lambda args
(make-warning package
- (format #f (G_ "failed to create ~a derivation: ~s")
- system args)))))
+ (G_ "failed to create ~a derivation: ~s")
+ (list system args)))))
(filter lint-warning?
(map try (package-supported-systems package))))
@@ -1001,15 +1017,15 @@ the NIST server non-fatal."
(list
(make-warning
package
- (format #f (G_ "probably vulnerable to ~a")
- (string-join (map vulnerability-id unpatched)
- ", "))))))))))
+ (G_ "probably vulnerable to ~a")
+ (list (string-join (map vulnerability-id unpatched)
+ ", "))))))))))
(define (check-for-updates package)
"Check if there is an update available for PACKAGE."
(match (with-networking-fail-safe
- (format #f (G_ "while retrieving upstream info for '~a'")
- (package-name package))
+ (G_ "while retrieving upstream info for '~a'")
+ (list (package-name package))
#f
(package-latest-release* package (force %updaters)))
((? upstream-source? source)
@@ -1017,8 +1033,8 @@ the NIST server non-fatal."
(package-version package))
(list
(make-warning package
- (format #f (G_ "can be upgraded to ~a")
- (upstream-source-version source))
+ (G_ "can be upgraded to ~a")
+ (list (upstream-source-version source))
#:field 'version))
'()))
(#f '()))) ; cannot find newer upstream release
@@ -1034,8 +1050,8 @@ the NIST server non-fatal."
(#f #t)
(index
(make-warning package
- (format #f (G_ "tabulation on line ~a, column ~a")
- line-number index)
+ (G_ "tabulation on line ~a, column ~a")
+ (list line-number index)
#:location
(location (package-file package)
line-number
@@ -1046,9 +1062,8 @@ the NIST server non-fatal."
(unless (or (string=? line (string-trim-right line))
(string=? line (string #\page)))
(make-warning package
- (format #f
- (G_ "trailing white space on line ~a")
- line-number)
+ (G_ "trailing white space on line ~a")
+ (list line-number)
#:location
(location (package-file package)
line-number
@@ -1061,8 +1076,8 @@ the NIST server non-fatal."
;; much noise.
(when (> (string-length line) 90)
(make-warning package
- (format #f (G_ "line ~a is way too long (~a characters)")
- line-number (string-length line))
+ (G_ "line ~a is way too long (~a characters)")
+ (list line-number (string-length line))
#:location
(location (package-file package)
line-number
@@ -1075,10 +1090,9 @@ the NIST server non-fatal."
"Emit a warning if LINE contains hanging parentheses."
(when (regexp-exec %hanging-paren-rx line)
(make-warning package
- (format #f
- (G_ "parentheses feel lonely, \
+ (G_ "parentheses feel lonely, \
move to the previous or next line")
- line-number)
+ (list line-number)
#:location
(location (package-file package)
line-number
--
2.21.0
^ permalink raw reply related [flat|nested] 37+ messages in thread
* [bug#35790] [PATCH] scripts: lint: Handle warnings with a record type.
2019-06-07 7:44 ` Ludovic Courtès
@ 2019-06-16 13:00 ` Christopher Baines
2019-06-20 11:40 ` Ludovic Courtès
0 siblings, 1 reply; 37+ messages in thread
From: Christopher Baines @ 2019-06-16 13:00 UTC (permalink / raw)
To: Ludovic Courtès; +Cc: 35790
[-- Attachment #1: Type: text/plain, Size: 1204 bytes --]
Ludovic Courtès <ludo@gnu.org> writes:
> Hello,
>
> Christopher Baines <mail@cbaines.net> skribis:
>
>> 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.
>
> I like it!
>
> Maybe we should just ignore the i18n issue for now and keep
> already-translated messages in <lint-warning>.
I want the Guix Data Service to support internationalisation at some
point, so I've had a go at doing this. I'll say more in reply to your
other email.
> One question I have: before, warnings would be emitted as we go; now, we
> first collect all the warnings for a given package, and emit all of them
> at once. How does it look in terms of UX?
Not quite, warnings are emitted once returned from each checker for each
package. The display will only be delayed if a checker takes a long time
to return the warnings, which I don't think happens (or at least happens
much).
[-- Attachment #2: signature.asc --]
[-- Type: application/pgp-signature, Size: 962 bytes --]
^ permalink raw reply [flat|nested] 37+ messages in thread
* [bug#35790] [PATCH] scripts: lint: Handle warnings with a record type.
2019-06-07 7:38 ` Ludovic Courtès
2019-06-16 12:56 ` [bug#35790] [PATCH] scripts: lint: Separate the message warning text and data Christopher Baines
@ 2019-06-16 13:05 ` Christopher Baines
2019-06-20 11:49 ` Ludovic Courtès
1 sibling, 1 reply; 37+ messages in thread
From: Christopher Baines @ 2019-06-16 13:05 UTC (permalink / raw)
To: Ludovic Courtès; +Cc: 35790
[-- Attachment #1: Type: text/plain, Size: 1253 bytes --]
Ludovic Courtès <ludo@gnu.org> writes:
> A possibility would be to pass ‘make-warning’ a ‘format’ list instead of
> a single string:
>
> (make-warning package (list (G_ "~a is bad") 'something) …)
>
> That’d solve the problem but it’d have to be packaged nicely to avoid
> having too much boilerplate.
I've now made an attempt at doing this, I've kept the changes separate
for now, and I've sent them as a separate patch.
I'm not sure I've got it working yet though. I've been testing with the
zile package, as there's a lint warning for the synopsis, however, if I
try to set the language to Spanish, it isn't translated.
I've also tried checking the existing behaviour, but that doesn't seem
to work either:
→ LC_MESSAGES=es_ES LANGUAGE=es_ES LC_ALL=es_ES ./pre-inst-env guile
...
scheme@(guile-user)> (use-modules (guix i18n))
scheme@(guile-user)> (G_ "~a: ~a: proposed synopsis: ~s~%")
$1 = "~a: ~a: proposed synopsis: ~s~%"
Many of the translated strings won't match up with the code now as I've
changed them. I did try changing the Spanish translation for this
proposed synopsis message to match the code, but it didn't seem to work.
Any ideas on what's going on here?
Chris
[-- Attachment #2: signature.asc --]
[-- Type: application/pgp-signature, Size: 962 bytes --]
^ permalink raw reply [flat|nested] 37+ messages in thread
* [bug#35790] [PATCH] scripts: lint: Handle warnings with a record type.
2019-06-16 13:00 ` Christopher Baines
@ 2019-06-20 11:40 ` Ludovic Courtès
0 siblings, 0 replies; 37+ messages in thread
From: Ludovic Courtès @ 2019-06-20 11:40 UTC (permalink / raw)
To: Christopher Baines; +Cc: 35790
Hi!
Christopher Baines <mail@cbaines.net> skribis:
> Ludovic Courtès <ludo@gnu.org> writes:
[...]
>> One question I have: before, warnings would be emitted as we go; now, we
>> first collect all the warnings for a given package, and emit all of them
>> at once. How does it look in terms of UX?
>
> Not quite, warnings are emitted once returned from each checker for each
> package. The display will only be delayed if a checker takes a long time
> to return the warnings, which I don't think happens (or at least happens
> much).
True, so that shouldn’t be much of an issue I guess.
Ludo’.
^ permalink raw reply [flat|nested] 37+ messages in thread
* [bug#35790] [PATCH] scripts: lint: Handle warnings with a record type.
2019-06-16 13:05 ` [bug#35790] [PATCH] scripts: lint: Handle warnings with a record type Christopher Baines
@ 2019-06-20 11:49 ` Ludovic Courtès
2019-06-24 6:46 ` Christopher Baines
0 siblings, 1 reply; 37+ messages in thread
From: Ludovic Courtès @ 2019-06-20 11:49 UTC (permalink / raw)
To: Christopher Baines; +Cc: 35790
Christopher Baines <mail@cbaines.net> skribis:
> Ludovic Courtès <ludo@gnu.org> writes:
>
>> A possibility would be to pass ‘make-warning’ a ‘format’ list instead of
>> a single string:
>>
>> (make-warning package (list (G_ "~a is bad") 'something) …)
>>
>> That’d solve the problem but it’d have to be packaged nicely to avoid
>> having too much boilerplate.
>
> I've now made an attempt at doing this, I've kept the changes separate
> for now, and I've sent them as a separate patch.
Nice!
> I'm not sure I've got it working yet though. I've been testing with the
> zile package, as there's a lint warning for the synopsis, however, if I
> try to set the language to Spanish, it isn't translated.
>
> I've also tried checking the existing behaviour, but that doesn't seem
> to work either:
>
> → LC_MESSAGES=es_ES LANGUAGE=es_ES LC_ALL=es_ES ./pre-inst-env guile
> ...
> scheme@(guile-user)> (use-modules (guix i18n))
> scheme@(guile-user)> (G_ "~a: ~a: proposed synopsis: ~s~%")
> $1 = "~a: ~a: proposed synopsis: ~s~%"
>
> Many of the translated strings won't match up with the code now as I've
> changed them. I did try changing the Spanish translation for this
> proposed synopsis message to match the code, but it didn't seem to work.
>
> Any ideas on what's going on here?
You need to tell libc (gettext) where to look for message catalogs.
This is normally done in scripts/guix:
(bindtextdomain "guix" "@localedir@")
For testing purposes, you can probably do:
(bindtextdomain "guix"
"/run/current-system/profile/share/locale")
HTH!
Ludo’.
^ permalink raw reply [flat|nested] 37+ messages in thread
* [bug#35790] [PATCH] scripts: lint: Handle warnings with a record type.
2019-06-20 11:49 ` Ludovic Courtès
@ 2019-06-24 6:46 ` Christopher Baines
2019-06-24 8:33 ` Ludovic Courtès
2019-06-24 8:39 ` Ludovic Courtès
0 siblings, 2 replies; 37+ messages in thread
From: Christopher Baines @ 2019-06-24 6:46 UTC (permalink / raw)
To: Ludovic Courtès; +Cc: 35790
[-- Attachment #1: Type: text/plain, Size: 2382 bytes --]
Ludovic Courtès <ludo@gnu.org> writes:
> Christopher Baines <mail@cbaines.net> skribis:
>
>> Ludovic Courtès <ludo@gnu.org> writes:
>>
>>> A possibility would be to pass ‘make-warning’ a ‘format’ list instead of
>>> a single string:
>>>
>>> (make-warning package (list (G_ "~a is bad") 'something) …)
>>>
>>> That’d solve the problem but it’d have to be packaged nicely to avoid
>>> having too much boilerplate.
>>
>> I've now made an attempt at doing this, I've kept the changes separate
>> for now, and I've sent them as a separate patch.
>
> Nice!
>
>> I'm not sure I've got it working yet though. I've been testing with the
>> zile package, as there's a lint warning for the synopsis, however, if I
>> try to set the language to Spanish, it isn't translated.
>>
>> I've also tried checking the existing behaviour, but that doesn't seem
>> to work either:
>>
>> → LC_MESSAGES=es_ES LANGUAGE=es_ES LC_ALL=es_ES ./pre-inst-env guile
>> ...
>> scheme@(guile-user)> (use-modules (guix i18n))
>> scheme@(guile-user)> (G_ "~a: ~a: proposed synopsis: ~s~%")
>> $1 = "~a: ~a: proposed synopsis: ~s~%"
>>
>> Many of the translated strings won't match up with the code now as I've
>> changed them. I did try changing the Spanish translation for this
>> proposed synopsis message to match the code, but it didn't seem to work.
>>
>> Any ideas on what's going on here?
>
> You need to tell libc (gettext) where to look for message catalogs.
> This is normally done in scripts/guix:
>
> (bindtextdomain "guix" "@localedir@")
>
> For testing purposes, you can probably do:
>
> (bindtextdomain "guix"
> "/run/current-system/profile/share/locale")
Thanks, so if I set the bindtextdomain, things do indeed work
better. So, regarding these two patches, I've got the following things
on my mind...
- As they change so many things, I'm not sure what to add for the GNU
changelog at the end of the commit message?
- Is it OK to break some of the translations, or should I fix some of
those as well?
- I'm thinking of the "proposed synopsis" related check specifically,
as I've changed what goes in to the translated string.
- How ready are these patches to merge? I don't know of any problems
with them, but I am making lots of changes.
Thanks,
Chris
[-- Attachment #2: signature.asc --]
[-- Type: application/pgp-signature, Size: 962 bytes --]
^ permalink raw reply [flat|nested] 37+ messages in thread
* [bug#35790] [PATCH] scripts: lint: Handle warnings with a record type.
2019-06-24 6:46 ` Christopher Baines
@ 2019-06-24 8:33 ` Ludovic Courtès
2019-06-24 8:39 ` Ludovic Courtès
1 sibling, 0 replies; 37+ messages in thread
From: Ludovic Courtès @ 2019-06-24 8:33 UTC (permalink / raw)
To: Christopher Baines; +Cc: 35790
Hi! :-)
Christopher Baines <mail@cbaines.net> skribis:
> - Is it OK to break some of the translations, or should I fix some of
> those as well?
>
> - I'm thinking of the "proposed synopsis" related check specifically,
> as I've changed what goes in to the translated string.
It’s OK to change strings sometimes, but this has to be done
thoughtfully as it entails more translation work and a time window
during which translations aren’t up-to-date and everyone sees the
English string.
Let me look at the other issues…
Ludo’.
^ permalink raw reply [flat|nested] 37+ messages in thread
* [bug#35790] [PATCH] scripts: lint: Separate the message warning text and data.
2019-06-16 12:56 ` [bug#35790] [PATCH] scripts: lint: Separate the message warning text and data Christopher Baines
@ 2019-06-24 8:36 ` Ludovic Courtès
2019-06-29 8:46 ` Christopher Baines
0 siblings, 1 reply; 37+ messages in thread
From: Ludovic Courtès @ 2019-06-24 8:36 UTC (permalink / raw)
To: Christopher Baines; +Cc: 35790
Hello,
Christopher Baines <mail@cbaines.net> skribis:
> +(define-syntax make-warning
> + (syntax-rules (G_)
> + ((_ package (G_ message) rest ...)
> + (%make-warning package message rest ...))
> + ((_ package message rest ...)
> + (%make-warning package message rest ...))))
I think you can remove the second clause: that will ensure we never
forget to add a G_ around messages.
Otherwise LGTM!
Ludo’.
^ permalink raw reply [flat|nested] 37+ messages in thread
* [bug#35790] [PATCH] scripts: lint: Handle warnings with a record type.
2019-06-24 6:46 ` Christopher Baines
2019-06-24 8:33 ` Ludovic Courtès
@ 2019-06-24 8:39 ` Ludovic Courtès
2019-06-29 11:25 ` [bug#35790] [PATCH 1/2] " Christopher Baines
2019-06-29 11:56 ` [bug#35790] [PATCH] scripts: lint: Handle warnings with a record type Christopher Baines
1 sibling, 2 replies; 37+ messages in thread
From: Ludovic Courtès @ 2019-06-24 8:39 UTC (permalink / raw)
To: Christopher Baines; +Cc: 35790
Hi Chris,
Christopher Baines <mail@cbaines.net> skribis:
> Thanks, so if I set the bindtextdomain, things do indeed work
> better. So, regarding these two patches, I've got the following things
> on my mind...
>
> - As they change so many things, I'm not sure what to add for the GNU
> changelog at the end of the commit message?
I think you should try to write the commit log the usual way, by
listing every changed entity. It’s a bit tedious, but it’s also a good
way to review everything (and Magit makes it relatively easy.)
Now, don’t lose your hair on it, it’s not the most important part of the
patch. :-)
> - Is it OK to break some of the translations, or should I fix some of
> those as well?
>
> - I'm thinking of the "proposed synopsis" related check specifically,
> as I've changed what goes in to the translated string.
Actually I didn’t see the change you’re referring to, but maybe it
doesn’t matter much.
> - How ready are these patches to merge? I don't know of any problems
> with them, but I am making lots of changes.
I think it’s ready.
Thanks, and sorry for the delays!
Ludo’.
^ permalink raw reply [flat|nested] 37+ messages in thread
* [bug#35790] [PATCH] scripts: lint: Separate the message warning text and data.
2019-06-24 8:36 ` Ludovic Courtès
@ 2019-06-29 8:46 ` Christopher Baines
0 siblings, 0 replies; 37+ messages in thread
From: Christopher Baines @ 2019-06-29 8:46 UTC (permalink / raw)
To: Ludovic Courtès; +Cc: 35790
[-- Attachment #1: Type: text/plain, Size: 1081 bytes --]
Ludovic Courtès <ludo@gnu.org> writes:
> Hello,
>
> Christopher Baines <mail@cbaines.net> skribis:
>
>> +(define-syntax make-warning
>> + (syntax-rules (G_)
>> + ((_ package (G_ message) rest ...)
>> + (%make-warning package message rest ...))
>> + ((_ package message rest ...)
>> + (%make-warning package message rest ...))))
>
> I think you can remove the second clause: that will ensure we never
> forget to add a G_ around messages.
Sure, there was one case where this clause was used, but I've switched
that to call %make-warning directly, and added a comment:
(define (check-patch-file-names package)
"Emit a warning if the patches requires by PACKAGE are badly named or if the
patch could not be found."
(guard (c ((message-condition? c) ;raised by 'search-patch'
(list
;; Use %make-warning, as condition-mesasge is already
;; translated.
(%make-warning package (condition-message c)
#:field 'patch-file-names))))
[-- Attachment #2: signature.asc --]
[-- Type: application/pgp-signature, Size: 962 bytes --]
^ permalink raw reply [flat|nested] 37+ messages in thread
* [bug#35790] [PATCH 1/2] scripts: lint: Handle warnings with a record type.
2019-06-24 8:39 ` Ludovic Courtès
@ 2019-06-29 11:25 ` Christopher Baines
2019-06-29 11:25 ` [bug#35790] [PATCH 2/2] scripts: lint: Separate the message warning text and data Christopher Baines
2019-06-29 11:56 ` [bug#35790] [PATCH] scripts: lint: Handle warnings with a record type Christopher Baines
1 sibling, 1 reply; 37+ messages in thread
From: Christopher Baines @ 2019-06-29 11:25 UTC (permalink / raw)
To: 35790
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.
---
guix/scripts/lint.scm | 757 +++++++++++----------
tests/lint.scm | 1453 +++++++++++++++++++----------------------
2 files changed, 1102 insertions(+), 1108 deletions(-)
diff --git a/guix/scripts/lint.scm b/guix/scripts/lint.scm
index dc338a1d7b..1b08068669 100644
--- a/guix/scripts/lint.scm
+++ b/guix/scripts/lint.scm
@@ -84,6 +84,12 @@
check-formatting
run-checkers
+ lint-warning
+ lint-warning?
+ lint-warning-package
+ lint-warning-message
+ lint-warning-location
+
%checkers
lint-checker
lint-checker?
@@ -93,42 +99,48 @@
\f
;;;
-;;; 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
;; given, the location of PACKAGE otherwise, the full name of PACKAGE and the
;; provided MESSAGE.
- (let ((loc (or (package-field-location package field)
- (package-location package))))
- (format (guix-warning-port) "~a: ~a@~a: ~a~%"
- (location->string loc)
- (package-name package) (package-version package)
- message)))
-
-(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 ...)))
+ (for-each
+ (match-lambda
+ (($ <lint-warning> package message loc)
+ (format (guix-warning-port) "~a: ~a@~a: ~a~%"
+ (location->string loc)
+ (package-name package) (package-version package)
+ message)))
+ warnings))
\f
;;;
;;; Checkers
;;;
+
(define-record-type* <lint-checker>
lint-checker make-lint-checker
lint-checker?
@@ -163,10 +175,12 @@ monad."
(define (check-description-style package)
;; Emit a warning if stylistic issues are found in the description of PACKAGE.
(define (check-not-empty description)
- (when (string-null? description)
- (emit-warning package
- (G_ "description should not be empty")
- 'description)))
+ (if (string-null? description)
+ (list
+ (make-warning package
+ (G_ "description should not be empty")
+ #:field 'description))
+ '()))
(define (check-texinfo-markup description)
"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
(lambda () (texi->plain-text description))
(lambda (keys . args)
- (emit-warning package
+ (make-warning package
(G_ "Texinfo markup in description is invalid")
- 'description)
- #f)))
+ #:field 'description))))
(define (check-trademarks description)
"Check that DESCRIPTION does not contain '™' or '®' characters. See
http://www.gnu.org/prep/standards/html_node/Trademarks.html."
(match (string-index description (char-set #\™ #\®))
((and (? number?) index)
- (emit-warning package
- (format #f (G_ "description should not contain ~
+ (list
+ (make-warning package
+ (format #f (G_ "description should not contain ~
trademark sign '~a' at ~d")
- (string-ref description index) index)
- 'description))
- (else #t)))
+ (string-ref description index) index)
+ #:field 'description)))
+ (else '())))
(define (check-quotes description)
"Check whether DESCRIPTION contains single quotes and suggest @code."
- (when (regexp-exec %quoted-identifier-rx description)
- (emit-warning package
-
- ;; TRANSLATORS: '@code' is Texinfo markup and must be kept
- ;; as is.
- (G_ "use @code or similar ornament instead of quotes")
- 'description)))
+ (if (regexp-exec %quoted-identifier-rx description)
+ (list
+ (make-warning package
+ ;; TRANSLATORS: '@code' is Texinfo markup and must be kept
+ ;; as is.
+ (G_ "use @code or similar ornament instead of quotes")
+ #:field 'description))
+ '()))
(define (check-proper-start description)
- (unless (or (properly-starts-sentence? description)
- (string-prefix-ci? (package-name package) description))
- (emit-warning package
- (G_ "description should start with an upper-case letter or digit")
- 'description)))
+ (if (or (string-null? description)
+ (properly-starts-sentence? description)
+ (string-prefix-ci? (package-name package) description))
+ '()
+ (list
+ (make-warning
+ package
+ (G_ "description should start with an upper-case letter or digit")
+ #:field 'description))))
(define (check-end-of-sentence-space description)
"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)))
'("i.e" "e.g" "a.k.a" "resp"))
r (cons (match:start m) r)))))))
- (unless (null? infractions)
- (emit-warning package
- (format #f (G_ "sentences in description should be followed ~
+ (if (null? infractions)
+ '()
+ (list
+ (make-warning package
+ (format #f (G_ "sentences in description should be followed ~
by two spaces; possible infraction~p at ~{~a~^, ~}")
- (length infractions)
- infractions)
- 'description))))
+ (length infractions)
+ infractions)
+ #:field 'description)))))
(let ((description (package-description package)))
(if (string? description)
- (begin
- (check-not-empty description)
- (check-quotes description)
- (check-trademarks description)
- ;; Use raw description for this because Texinfo rendering
- ;; automatically fixes end of sentence space.
- (check-end-of-sentence-space description)
- (and=> (check-texinfo-markup description)
- check-proper-start))
- (emit-warning package
- (format #f (G_ "invalid description: ~s") description)
- 'description))))
+ (append
+ (check-not-empty description)
+ (check-quotes description)
+ (check-trademarks description)
+ ;; Use raw description for this because Texinfo rendering
+ ;; automatically fixes end of sentence space.
+ (check-end-of-sentence-space description)
+ (match (check-texinfo-markup description)
+ ((and warning (? lint-warning?)) (list warning))
+ (plain-description
+ (check-proper-start plain-description))))
+ (list
+ (make-warning package
+ (format #f (G_ "invalid description: ~s") description)
+ #:field 'description)))))
(define (package-input-intersection inputs-to-check input-names)
"Return the intersection between INPUTS-TO-CHECK, the list of input tuples
@@ -281,13 +305,13 @@ of a package, and INPUT-NAMES, a list of package specifications such as
"python-pytest-cov" "python2-pytest-cov"
"python-setuptools-scm" "python2-setuptools-scm"
"python-sphinx" "python2-sphinx")))
- (for-each (lambda (input)
- (emit-warning
- package
- (format #f (G_ "'~a' should probably be a native input")
- input)
- 'inputs-to-check))
- (package-input-intersection inputs input-names))))
+ (map (lambda (input)
+ (make-warning
+ package
+ (format #f (G_ "'~a' should probably be a native input")
+ input)
+ #:field 'inputs))
+ (package-input-intersection inputs input-names))))
(define (check-inputs-should-not-be-an-input-at-all package)
;; Emit a warning if some inputs of PACKAGE are likely to should not be
@@ -296,14 +320,15 @@ of a package, and INPUT-NAMES, a list of package specifications such as
"python2-setuptools"
"python-pip"
"python2-pip")))
- (for-each (lambda (input)
- (emit-warning
- package
- (format #f
- (G_ "'~a' should probably not be an input at all")
- input)))
- (package-input-intersection (package-direct-inputs package)
- input-names))))
+ (map (lambda (input)
+ (make-warning
+ package
+ (format #f
+ (G_ "'~a' should probably not be an input at all")
+ input)
+ #:field 'inputs))
+ (package-input-intersection (package-direct-inputs package)
+ input-names))))
(define (package-name-regexp package)
"Return a regexp that matches PACKAGE's name as a word at the beginning of a
@@ -314,66 +339,71 @@ line."
(define (check-synopsis-style 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)
;; Synopsis should not end with a period, except for some special cases.
- (when (and (string-suffix? "." synopsis)
- (not (string-suffix? "etc." synopsis)))
- (emit-warning package
- (G_ "no period allowed at the end of the synopsis")
- 'synopsis)))
+ (if (and (string-suffix? "." synopsis)
+ (not (string-suffix? "etc." synopsis)))
+ (list
+ (make-warning package
+ (G_ "no period allowed at the end of the synopsis")
+ #:field 'synopsis))
+ '()))
(define check-start-article
;; 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>.
(if (false-if-exception (gnu-package? package))
- (const #t)
+ (const '())
(lambda (synopsis)
- (when (or (string-prefix-ci? "A " synopsis)
- (string-prefix-ci? "An " synopsis))
- (emit-warning package
- (G_ "no article allowed at the beginning of \
+ (if (or (string-prefix-ci? "A " synopsis)
+ (string-prefix-ci? "An " synopsis))
+ (list
+ (make-warning package
+ (G_ "no article allowed at the beginning of \
the synopsis")
- 'synopsis)))))
+ #:field 'synopsis))
+ '()))))
(define (check-synopsis-length synopsis)
- (when (>= (string-length synopsis) 80)
- (emit-warning package
- (G_ "synopsis should be less than 80 characters long")
- 'synopsis)))
+ (if (>= (string-length synopsis) 80)
+ (list
+ (make-warning package
+ (G_ "synopsis should be less than 80 characters long")
+ #:field 'synopsis))
+ '()))
(define (check-proper-start synopsis)
- (unless (properly-starts-sentence? synopsis)
- (emit-warning package
- (G_ "synopsis should start with an upper-case letter or digit")
- 'synopsis)))
+ (if (properly-starts-sentence? synopsis)
+ '()
+ (list
+ (make-warning package
+ (G_ "synopsis should start with an upper-case letter or digit")
+ #:field '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)))
- (emit-warning package
- (G_ "synopsis should not start with the package name")
- 'synopsis)))
+ (list
+ (make-warning package
+ (G_ "synopsis should not start with the package name")
+ #:field 'synopsis))
+ '()))
(define (check-texinfo-markup synopsis)
"Check that SYNOPSIS can be parsed as a Texinfo fragment. If the
markup is valid return a plain-text version of SYNOPSIS, otherwise #f."
(catch #t
- (lambda () (texi->plain-text synopsis))
+ (lambda ()
+ (texi->plain-text synopsis)
+ '())
(lambda (keys . args)
- (emit-warning package
- (G_ "Texinfo markup in synopsis is invalid")
- 'synopsis)
- #f)))
+ (list
+ (make-warning package
+ (G_ "Texinfo markup in synopsis is invalid")
+ #:field 'synopsis)))))
(define checks
- (list check-not-empty
- check-proper-start
+ (list check-proper-start
check-final-period
check-start-article
check-start-with-package-name
@@ -381,13 +411,20 @@ markup is valid return a plain-text version of SYNOPSIS, otherwise #f."
check-texinfo-markup))
(match (package-synopsis package)
+ (""
+ (list
+ (make-warning package
+ (G_ "synopsis should not be empty")
+ #:field 'synopsis)))
((? string? synopsis)
- (for-each (lambda (proc)
- (proc synopsis))
- checks))
+ (append-map
+ (lambda (proc)
+ (proc synopsis))
+ checks))
(invalid
- (emit-warning package (format #f (G_ "invalid synopsis: ~s") invalid)
- 'synopsis))))
+ (list
+ (make-warning package (format #f (G_ "invalid synopsis: ~s") invalid)
+ #:field 'synopsis)))))
(define* (probe-uri uri #:key timeout)
"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))))
(define (validate-uri uri package field)
- "Return #t if the given URI can be reached, otherwise return #f and emit a
-warning for PACKAGE mentionning the FIELD."
+ "Return #t if the given URI can be reached, otherwise return a warning for
+PACKAGE mentionning the FIELD."
(let-values (((status argument)
(probe-uri uri #:timeout 3))) ;wait at most 3 seconds
(case status
@@ -502,71 +539,66 @@ warning for PACKAGE mentionning the FIELD."
;; with a small HTML page upon failure. Attempt to detect
;; such malicious behavior.
(or (> length 1000)
- (begin
- (emit-warning package
- (format #f
- (G_ "URI ~a returned \
+ (make-warning package
+ (format #f
+ (G_ "URI ~a returned \
suspiciously small file (~a bytes)")
- (uri->string uri)
- length))
- #f)))
+ (uri->string uri)
+ length)
+ #:field field)))
(_ #t)))
((= 301 (response-code argument))
(if (response-location argument)
- (begin
- (emit-warning package
- (format #f (G_ "permanent redirect from ~a to ~a")
- (uri->string uri)
- (uri->string
- (response-location argument))))
- #t)
- (begin
- (emit-warning package
- (format #f (G_ "invalid permanent redirect \
+ (make-warning package
+ (format #f (G_ "permanent redirect from ~a to ~a")
+ (uri->string uri)
+ (uri->string
+ (response-location argument)))
+ #:field field)
+ (make-warning package
+ (format #f (G_ "invalid permanent redirect \
from ~a")
- (uri->string uri)))
- #f)))
+ (uri->string uri))
+ #:field field)))
(else
- (emit-warning package
+ (make-warning package
(format #f
(G_ "URI ~a not reachable: ~a (~s)")
(uri->string uri)
(response-code argument)
(response-reason-phrase argument))
- field)
- #f)))
+ #:field field))))
((ftp-response)
(match argument
(('ok) #t)
(('error port command code message)
- (emit-warning package
+ (make-warning package
(format #f
(G_ "URI ~a not reachable: ~a (~s)")
(uri->string uri)
- code (string-trim-both message)))
- #f)))
+ code (string-trim-both message))
+ #:field field))))
((getaddrinfo-error)
- (emit-warning package
+ (make-warning package
(format #f
(G_ "URI ~a domain not found: ~a")
(uri->string uri)
(gai-strerror (car argument)))
- field)
- #f)
+ #:field field))
((system-error)
- (emit-warning package
+ (make-warning package
(format #f
(G_ "URI ~a unreachable: ~a")
(uri->string uri)
(strerror
(system-error-errno
(cons status argument))))
- field)
- #f)
+ #:field field))
((tls-certificate-error)
- (emit-warning package
+ (make-warning package
(format #f (G_ "TLS certificate error: ~a")
- (tls-certificate-error-string argument))))
+ (tls-certificate-error-string argument))
+ #:field field))
((invalid-http-response gnutls-error)
;; Probably a misbehaving server; ignore.
#f)
@@ -581,17 +613,23 @@ from ~a")
(let ((uri (and=> (package-home-page package) string->uri)))
(cond
((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))
- (unless (or (string-contains (package-name package) "bootstrap")
- (string=? (package-name package) "ld-wrapper"))
- (emit-warning package
- (G_ "invalid value for home page")
- 'home-page)))
+ (if (or (string-contains (package-name package) "bootstrap")
+ (string=? (package-name package) "ld-wrapper"))
+ '()
+ (list
+ (make-warning package
+ (G_ "invalid value for home page")
+ #:field 'home-page))))
(else
- (emit-warning package (format #f (G_ "invalid home page URL: ~s")
- (package-home-page package))
- 'home-page)))))
+ (list
+ (make-warning package (format #f (G_ "invalid home page URL: ~s")
+ (package-home-page package))
+ #:field 'home-page))))))
(define %distro-directory
(mlambda ()
@@ -601,42 +639,47 @@ from ~a")
"Emit a warning if the patches requires by PACKAGE are badly named or if the
patch could not be found."
(guard (c ((message-condition? c) ;raised by 'search-patch'
- (emit-warning package (condition-message c)
- 'patch-file-names)))
+ (list
+ (make-warning package (condition-message c)
+ #:field 'patch-file-names))))
(define patches
(or (and=> (package-source package) origin-patches)
'()))
- (unless (every (match-lambda ;patch starts with package name?
- ((? string? patch)
- (and=> (string-contains (basename patch)
- (package-name package))
- zero?))
- (_ #f)) ;must be an <origin> or something like that.
- patches)
- (emit-warning
- package
- (G_ "file names of patches should start with the package name")
- 'patch-file-names))
-
- ;; Check whether we're reaching tar's maximum file name length.
- (let ((prefix (string-length (%distro-directory)))
- (margin (string-length "guix-0.13.0-10-123456789/"))
- (max 99))
- (for-each (match-lambda
+ (append
+ (if (every (match-lambda ;patch starts with package name?
((? string? patch)
- (when (> (+ margin (if (string-prefix? (%distro-directory)
- patch)
- (- (string-length patch) prefix)
- (string-length patch)))
- max)
- (emit-warning
- package
- (format #f (G_ "~a: file name is too long")
- (basename patch))
- 'patch-file-names)))
- (_ #f))
- patches))))
+ (and=> (string-contains (basename patch)
+ (package-name package))
+ zero?))
+ (_ #f)) ;must be an <origin> or something like that.
+ patches)
+ '()
+ (list
+ (make-warning
+ package
+ (G_ "file names of patches should start with the package name")
+ #:field 'patch-file-names)))
+
+ ;; Check whether we're reaching tar's maximum file name length.
+ (let ((prefix (string-length (%distro-directory)))
+ (margin (string-length "guix-0.13.0-10-123456789/"))
+ (max 99))
+ (filter-map (match-lambda
+ ((? string? patch)
+ (if (> (+ margin (if (string-prefix? (%distro-directory)
+ patch)
+ (- (string-length patch) prefix)
+ (string-length patch)))
+ max)
+ (make-warning
+ package
+ (format #f (G_ "~a: file name is too long")
+ (basename patch))
+ #:field 'patch-file-names)
+ #f))
+ (_ #f))
+ patches)))))
(define (escape-quotes str)
"Replace any quote character in STR by an escaped quote character."
@@ -663,32 +706,35 @@ descriptions maintained upstream."
(package-name package)))
(official-gnu-packages*))
(#f ;not a GNU package, so nothing to do
- #t)
+ '())
(descriptor ;a genuine GNU package
- (let ((upstream (gnu-package-doc-summary descriptor))
- (downstream (package-synopsis package))
- (loc (or (package-field-location package 'synopsis)
- (package-location package))))
- (when (and upstream
- (or (not (string? downstream))
- (not (string=? upstream downstream))))
- (format (guix-warning-port)
- (G_ "~a: ~a: proposed synopsis: ~s~%")
- (location->string loc) (package-full-name package)
- upstream)))
-
- (let ((upstream (gnu-package-doc-description descriptor))
- (downstream (package-description package))
- (loc (or (package-field-location package 'description)
- (package-location package))))
- (when (and upstream
- (or (not (string? downstream))
- (not (string=? (fill-paragraph upstream 100)
- (fill-paragraph downstream 100)))))
- (format (guix-warning-port)
- (G_ "~a: ~a: proposed description:~% \"~a\"~%")
- (location->string loc) (package-full-name package)
- (fill-paragraph (escape-quotes upstream) 77 7)))))))
+ (append
+ (let ((upstream (gnu-package-doc-summary descriptor))
+ (downstream (package-synopsis package)))
+ (if (and upstream
+ (or (not (string? downstream))
+ (not (string=? upstream downstream))))
+ (list
+ (make-warning package
+ (format #f (G_ "proposed synopsis: ~s~%")
+ upstream)
+ #:field 'synopsis))
+ '()))
+
+ (let ((upstream (gnu-package-doc-description descriptor))
+ (downstream (package-description package)))
+ (if (and upstream
+ (or (not (string? downstream))
+ (not (string=? (fill-paragraph upstream 100)
+ (fill-paragraph downstream 100)))))
+ (list
+ (make-warning
+ package
+ (format #f
+ (G_ "proposed description:~% \"~a\"~%")
+ (fill-paragraph (escape-quotes upstream) 77 7))
+ #:field 'description))
+ '()))))))
(define (origin-uris origin)
"Return the list of URIs (strings) for ORIGIN."
@@ -701,38 +747,35 @@ descriptions maintained upstream."
(define (check-source package)
"Emit a warning if PACKAGE has an invalid 'source' field, or if that
'source' is not reachable."
- (define (try-uris uris)
- (run-with-state
- (anym %state-monad
- (lambda (uri)
- (with-accumulated-warnings
- (validate-uri uri package 'source)))
- (append-map (cut maybe-expand-mirrors <> %mirrors)
- uris))
- '()))
+ (define (warnings-for-uris uris)
+ (filter lint-warning?
+ (map
+ (lambda (uri)
+ (validate-uri uri package 'source))
+ (append-map (cut maybe-expand-mirrors <> %mirrors)
+ uris))))
(let ((origin (package-source package)))
- (when (and origin
- (eqv? (origin-method origin) url-fetch))
- (let ((uris (map string->uri (origin-uris origin))))
-
- ;; Just make sure that at least one of the URIs is valid.
- (call-with-values
- (lambda () (try-uris uris))
- (lambda (success? warnings)
- ;; When everything fails, report all of WARNINGS, otherwise don't
- ;; report anything.
- ;;
- ;; XXX: Ideally we'd still allow warnings to be raised if *some*
- ;; URIs are unreachable, but distinguish that from the error case
- ;; where *all* the URIs are unreachable.
- (unless success?
- (emit-warning package
- (G_ "all the source URIs are unreachable:")
- 'source)
- (for-each (lambda (warning)
- (display warning (guix-warning-port)))
- (reverse warnings)))))))))
+ (if (and origin
+ (eqv? (origin-method origin) url-fetch))
+ (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.
+ (if (eq? (length uris) (length warnings))
+ ;; When everything fails, report all of WARNINGS, otherwise don't
+ ;; report anything.
+ ;;
+ ;; XXX: Ideally we'd still allow warnings to be raised if *some*
+ ;; URIs are unreachable, but distinguish that from the error case
+ ;; where *all* the URIs are unreachable.
+ (cons*
+ (make-warning package
+ (G_ "all the source URIs are unreachable:")
+ #:field 'source)
+ warnings)
+ '()))
+ '())))
(define (check-source-file-name package)
"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)))))
(let ((origin (package-source package)))
- (unless (or (not origin) (origin-file-name-valid? origin))
- (emit-warning package
- (G_ "the source file name should contain the package name")
- 'source))))
+ (if (or (not origin) (origin-file-name-valid? origin))
+ '()
+ (list
+ (make-warning package
+ (G_ "the source file name should contain the package name")
+ #:field 'source)))))
(define (check-source-unstable-tarball package)
"Emit a warning if PACKAGE's source is an autogenerated tarball."
(define (check-source-uri uri)
- (when (and (string=? (uri-host (string->uri uri)) "github.com")
- (match (split-and-decode-uri-path
- (uri-path (string->uri uri)))
- ((_ _ "archive" _ ...) #t)
- (_ #f)))
- (emit-warning package
- (G_ "the source URI should not be an autogenerated tarball")
- 'source)))
+ (if (and (string=? (uri-host (string->uri uri)) "github.com")
+ (match (split-and-decode-uri-path
+ (uri-path (string->uri uri)))
+ ((_ _ "archive" _ ...) #t)
+ (_ #f)))
+ (make-warning package
+ (G_ "the source URI should not be an autogenerated tarball")
+ #:field 'source)
+ #f))
+
(let ((origin (package-source package)))
- (when (and (origin? origin)
- (eqv? (origin-method origin) url-fetch))
- (let ((uris (origin-uris origin)))
- (for-each check-source-uri uris)))))
+ (if (and (origin? origin)
+ (eqv? (origin-method origin) url-fetch))
+ (filter-map check-source-uri
+ (origin-uris origin))
+ '())))
(define (check-mirror-url package)
"Check whether PACKAGE uses source URLs that should be 'mirror://'."
@@ -776,24 +824,25 @@ descriptions maintained upstream."
(let loop ((mirrors %mirrors))
(match mirrors
(()
- #t)
+ #f)
(((mirror-id mirror-urls ...) rest ...)
(match (find (cut string-prefix? <> uri) mirror-urls)
(#f
(loop rest))
(prefix
- (emit-warning package
+ (make-warning package
(format #f (G_ "URL should be \
'mirror://~a/~a'")
mirror-id
(string-drop uri (string-length prefix)))
- 'source)))))))
+ #:field 'source)))))))
(let ((origin (package-source package)))
- (when (and (origin? origin)
- (eqv? (origin-method origin) url-fetch))
- (let ((uris (origin-uris origin)))
- (for-each check-mirror-uri uris)))))
+ (if (and (origin? origin)
+ (eqv? (origin-method origin) url-fetch))
+ (let ((uris (origin-uris origin)))
+ (filter-map check-mirror-uri uris))
+ '())))
(define* (check-github-url package #:key (timeout 3))
"Check whether PACKAGE uses source URLs that redirect to GitHub."
@@ -817,18 +866,20 @@ descriptions maintained upstream."
(else #f)))
(let ((origin (package-source package)))
- (when (and (origin? origin)
- (eqv? (origin-method origin) url-fetch))
- (for-each
- (lambda (uri)
- (and=> (follow-redirects-to-github uri)
- (lambda (github-uri)
- (unless (string=? github-uri uri)
- (emit-warning
- package
- (format #f (G_ "URL should be '~a'") github-uri)
- 'source)))))
- (origin-uris origin)))))
+ (if (and (origin? origin)
+ (eqv? (origin-method origin) url-fetch))
+ (filter-map
+ (lambda (uri)
+ (and=> (follow-redirects-to-github uri)
+ (lambda (github-uri)
+ (if (string=? github-uri uri)
+ #f
+ (make-warning
+ package
+ (format #f (G_ "URL should be '~a'") github-uri)
+ #:field 'source)))))
+ (origin-uris origin))
+ '())))
(define (check-derivation package)
"Emit a warning if we fail to compile PACKAGE to a derivation."
@@ -836,12 +887,12 @@ descriptions maintained upstream."
(catch #t
(lambda ()
(guard (c ((store-protocol-error? c)
- (emit-warning package
+ (make-warning package
(format #f (G_ "failed to create ~a derivation: ~a")
system
(store-protocol-error-message c))))
((message-condition? c)
- (emit-warning package
+ (make-warning package
(format #f (G_ "failed to create ~a derivation: ~a")
system
(condition-message c)))))
@@ -858,21 +909,23 @@ descriptions maintained upstream."
(package-derivation store replacement system
#:graft? #f)))))))
(lambda args
- (emit-warning package
+ (make-warning package
(format #f (G_ "failed to create ~a derivation: ~s")
system args)))))
- (for-each try (package-supported-systems package)))
+ (filter lint-warning?
+ (map try (package-supported-systems package))))
(define (check-license package)
"Warn about type errors of the 'license' field of PACKAGE."
(match (package-license package)
((or (? license?)
((? license?) ...))
- #t)
+ '())
(x
- (emit-warning package (G_ "invalid license field")
- 'license))))
+ (list
+ (make-warning package (G_ "invalid license field")
+ #:field 'license)))))
(define (call-with-networking-fail-safe message error-value proc)
"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)))
(match (package-vulnerabilities package)
(()
- #t)
+ '())
((vulnerabilities ...)
(let* ((patched (package-patched-vulnerabilities package))
(known-safe (or (assq-ref (package-properties package)
@@ -943,11 +996,14 @@ the NIST server non-fatal."
(or (member id patched)
(member id known-safe))))
vulnerabilities)))
- (unless (null? unpatched)
- (emit-warning package
- (format #f (G_ "probably vulnerable to ~a")
- (string-join (map vulnerability-id unpatched)
- ", ")))))))))
+ (if (null? unpatched)
+ '()
+ (list
+ (make-warning
+ package
+ (format #f (G_ "probably vulnerable to ~a")
+ (string-join (map vulnerability-id unpatched)
+ ", "))))))))))
(define (check-for-updates package)
"Check if there is an update available for PACKAGE."
@@ -957,12 +1013,15 @@ the NIST server non-fatal."
#f
(package-latest-release* package (force %updaters)))
((? upstream-source? source)
- (when (version>? (upstream-source-version source)
- (package-version package))
- (emit-warning package
- (format #f (G_ "can be upgraded to ~a")
- (upstream-source-version source)))))
- (#f #f))) ; cannot find newer upstream release
+ (if (version>? (upstream-source-version source)
+ (package-version package))
+ (list
+ (make-warning package
+ (format #f (G_ "can be upgraded to ~a")
+ (upstream-source-version source))
+ #:field 'version))
+ '()))
+ (#f '()))) ; cannot find newer upstream release
\f
;;;
@@ -974,18 +1033,26 @@ the NIST server non-fatal."
(match (string-index line #\tab)
(#f #t)
(index
- (emit-warning package
+ (make-warning package
(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)
"Warn about trailing white space in LINE."
(unless (or (string=? line (string-trim-right line))
(string=? line (string #\page)))
- (emit-warning package
+ (make-warning package
(format #f
(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)
"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
;; much noise.
(when (> (string-length line) 90)
- (emit-warning package
+ (make-warning package
(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
(make-regexp "^[[:blank:]]*[()]+[[:blank:]]*$"))
@@ -1003,11 +1074,15 @@ the NIST server non-fatal."
(define (report-lone-parentheses package line line-number)
"Emit a warning if LINE contains hanging parentheses."
(when (regexp-exec %hanging-paren-rx line)
- (emit-warning package
+ (make-warning package
(format #f
- (G_ "line ~a: parentheses feel lonely, \
+ (G_ "parentheses feel lonely, \
move to the previous or next line")
- line-number))))
+ line-number)
+ #:location
+ (location (package-file package)
+ line-number
+ 0))))
(define %formatting-reporters
;; List of procedures that report formatting issues. These are not separate
@@ -1040,31 +1115,40 @@ them for PACKAGE."
(call-with-input-file file
(lambda (port)
(let loop ((line-number 1)
- (last-line #f))
+ (last-line #f)
+ (warnings '()))
(let ((line (read-line port)))
- (or (eof-object? line)
- (and last-line (> line-number last-line))
+ (if (or (eof-object? line)
+ (and last-line (> line-number last-line)))
+ warnings
(if (and (= line-number starting-line)
(not last-line))
(loop (+ 1 line-number)
- (+ 1 (sexp-last-line port)))
- (begin
- (unless (< line-number starting-line)
- (for-each (lambda (report)
- (report package line line-number))
- reporters))
- (loop (+ 1 line-number) last-line)))))))))
+ (+ 1 (sexp-last-line port))
+ warnings)
+ (loop (+ 1 line-number)
+ last-line
+ (append
+ warnings
+ (if (< line-number starting-line)
+ '()
+ (filter
+ lint-warning?
+ (map (lambda (report)
+ (report package line line-number))
+ reporters))))))))))))
(define (check-formatting package)
"Check the formatting of the source code of PACKAGE."
(let ((location (package-location package)))
- (when location
- (and=> (search-path %load-path (location-file location))
- (lambda (file)
- ;; Report issues starting from the line before the 'package'
- ;; form, which usually contains the 'define' form.
- (report-formatting-issues package file
- (- (location-line location) 1)))))))
+ (if location
+ (and=> (search-path %load-path (location-file location))
+ (lambda (file)
+ ;; Report issues starting from the line before the 'package'
+ ;; form, which usually contains the 'define' form.
+ (report-formatting-issues package file
+ (- (location-line location) 1))))
+ '())))
\f
;;;
@@ -1155,7 +1239,8 @@ or a list thereof")
(package-name package) (package-version package)
(lint-checker-name checker))
(force-output (current-error-port)))
- ((lint-checker-check checker) package))
+ (emit-warnings
+ ((lint-checker-check checker) package)))
checkers)
(when tty?
(format (current-error-port) "\x1b[K")
diff --git a/tests/lint.scm b/tests/lint.scm
index dc2b17aeec..d8b2ca54cd 100644
--- a/tests/lint.scm
+++ b/tests/lint.scm
@@ -44,7 +44,12 @@
#: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.
@@ -60,781 +65,696 @@
(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))))
+
\f
(test-begin "lint")
-(define (call-with-warnings thunk)
- (let ((port (open-output-string)))
- (parameterize ((guix-warning-port port))
- (thunk))
- (get-output-string port)))
-
-(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
- (let ((pkg (dummy-package "x"
- (description ""))))
- (check-description-style pkg)))
- "description should not be empty")))
-
-(test-assert "description: valid Texinfo markup"
- (->bool
- (string-contains
- (with-warnings
- (check-description-style (dummy-package "x" (description "f{oo}b@r"))))
- "Texinfo markup in description is invalid")))
-
-(test-assert "description: does not start with an upper-case letter"
- (->bool
- (string-contains (with-warnings
- (let ((pkg (dummy-package "x"
- (description "bad description."))))
- (check-description-style pkg)))
- "description should start with an upper-case letter")))
-
-(test-assert "description: may start with a digit"
- (string-null?
- (with-warnings
- (let ((pkg (dummy-package "x"
- (description "2-component library."))))
- (check-description-style pkg)))))
-
-(test-assert "description: may start with lower-case package name"
- (string-null?
- (with-warnings
- (let ((pkg (dummy-package "x"
- (description "x is a dummy package."))))
- (check-description-style pkg)))))
-
-(test-assert "description: two spaces after end of sentence"
- (->bool
- (string-contains (with-warnings
- (let ((pkg (dummy-package "x"
- (description "Bad. Quite bad."))))
- (check-description-style pkg)))
- "sentences in description should be followed by two spaces")))
-
-(test-assert "description: end-of-sentence detection with abbreviations"
- (string-null?
- (with-warnings
- (let ((pkg (dummy-package "x"
- (description
- "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 "description: suggest ornament instead of quotes"
- (->bool
- (string-contains (with-warnings
- (let ((pkg (dummy-package "x"
- (description "This is a 'quoted' thing."))))
- (check-description-style pkg)))
- "use @code")))
-
-(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
- (let ((pkg (dummy-package "x"
- (synopsis ""))))
- (check-synopsis-style pkg)))
- "synopsis should not be empty")))
-
-(test-assert "synopsis: valid Texinfo markup"
- (->bool
- (string-contains
- (with-warnings
- (check-synopsis-style (dummy-package "x" (synopsis "Bad $@ texinfo"))))
- "Texinfo markup in synopsis is invalid")))
-
-(test-assert "synopsis: does not start with an upper-case letter"
- (->bool
- (string-contains (with-warnings
- (let ((pkg (dummy-package "x"
- (synopsis "bad synopsis."))))
- (check-synopsis-style pkg)))
- "synopsis should start with an upper-case letter")))
-
-(test-assert "synopsis: may start with a digit"
- (string-null?
- (with-warnings
- (let ((pkg (dummy-package "x"
- (synopsis "5-dimensional frobnicator"))))
- (check-synopsis-style pkg)))))
-
-(test-assert "synopsis: ends with a period"
- (->bool
- (string-contains (with-warnings
- (let ((pkg (dummy-package "x"
- (synopsis "Bad synopsis."))))
- (check-synopsis-style pkg)))
- "no period allowed at the end of the synopsis")))
-
-(test-assert "synopsis: ends with 'etc.'"
- (string-null? (with-warnings
- (let ((pkg (dummy-package "x"
- (synopsis "Foo, bar, etc."))))
- (check-synopsis-style pkg)))))
-
-(test-assert "synopsis: starts with 'A'"
- (->bool
- (string-contains (with-warnings
- (let ((pkg (dummy-package "x"
- (synopsis "A bad synopŝis"))))
- (check-synopsis-style pkg)))
- "no article allowed at the beginning of the synopsis")))
-
-(test-assert "synopsis: starts with 'An'"
- (->bool
- (string-contains (with-warnings
- (let ((pkg (dummy-package "x"
- (synopsis "An awful synopsis"))))
- (check-synopsis-style pkg)))
- "no article allowed at the beginning of the synopsis")))
-
-(test-assert "synopsis: starts with 'a'"
- (->bool
- (string-contains (with-warnings
- (let ((pkg (dummy-package "x"
- (synopsis "a bad synopsis"))))
- (check-synopsis-style pkg)))
- "no article allowed at the beginning of the synopsis")))
-
-(test-assert "synopsis: starts with 'an'"
- (->bool
- (string-contains (with-warnings
- (let ((pkg (dummy-package "x"
- (synopsis "an awful synopsis"))))
- (check-synopsis-style pkg)))
- "no article allowed at the beginning of the synopsis")))
-
-(test-assert "synopsis: too long"
- (->bool
- (string-contains (with-warnings
- (let ((pkg (dummy-package "x"
- (synopsis (make-string 80 #\x)))))
- (check-synopsis-style pkg)))
- "synopsis should be less than 80 characters long")))
-
-(test-assert "synopsis: start with package name"
- (->bool
- (string-contains (with-warnings
- (let ((pkg (dummy-package "x"
- (name "foo")
- (synopsis "foo, a nice package"))))
- (check-synopsis-style pkg)))
- "synopsis should not start with the package name")))
-
-(test-assert "synopsis: start with package name prefix"
- (string-null?
- (with-warnings
- (let ((pkg (dummy-package "arb"
- (synopsis "Arbitrary precision"))))
- (check-synopsis-style pkg)))))
-
-(test-assert "synopsis: start with abbreviation"
- (string-null?
- (with-warnings
- (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-assert "inputs: pkg-config is probably a native input"
- (->bool
- (string-contains
- (with-warnings
- (let ((pkg (dummy-package "x"
- (inputs `(("pkg-config" ,pkg-config))))))
- (check-inputs-should-be-native pkg)))
- "'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
+(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)"
- (->bool
- (string-contains
- (with-warnings
- (let ((pkg (dummy-package "x"
- (inputs `(("python-setuptools" ,python-setuptools))))))
- (check-inputs-should-not-be-an-input-at-all pkg)))
- "'python-setuptools' should probably not be an input at all")))
-
-(test-assert
+ "'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)"
- (->bool
- (string-contains
- (with-warnings
- (let ((pkg (dummy-package "x"
- (native-inputs
- `(("python-setuptools" ,python-setuptools))))))
- (check-inputs-should-not-be-an-input-at-all pkg)))
- "'python-setuptools' should probably not be an input at all")))
-
-(test-assert
+ "'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)"
- (->bool
- (string-contains
- (with-warnings
- (let ((pkg (dummy-package "x"
- (propagated-inputs
- `(("python-setuptools" ,python-setuptools))))))
- (check-inputs-should-not-be-an-input-at-all pkg)))
- "'python-setuptools' should probably not be an input at all")))
-
-(test-assert "patches: file names"
- (->bool
- (string-contains
- (with-warnings
- (let ((pkg (dummy-package "x"
- (source
- (dummy-origin
- (patches (list "/path/to/y.patch")))))))
- (check-patch-file-names pkg)))
- "file names of patches should start with the package name")))
-
-(test-assert "patches: file name too long"
- (->bool
- (string-contains
- (with-warnings
- (let ((pkg (dummy-package "x"
- (source
- (dummy-origin
- (patches (list (string-append "x-"
- (make-string 100 #\a)
- ".patch"))))))))
- (check-patch-file-names pkg)))
- "file name is too long")))
-
-(test-assert "patches: not found"
- (->bool
- (string-contains
- (with-warnings
- (let ((pkg (dummy-package "x"
- (source
- (dummy-origin
- (patches
- (list (search-patch "this-patch-does-not-exist!"))))))))
- (check-patch-file-names pkg)))
- "patch not found")))
-
-(test-assert "derivation: invalid arguments"
- (->bool
- (string-contains
- (with-warnings
- (let ((pkg (dummy-package "x"
- (arguments
- '(#:imported-modules (invalid-module))))))
- (check-derivation pkg)))
- "failed to create")))
-
-(test-assert "license: invalid license"
- (string-contains
- (with-warnings
- (check-license (dummy-package "x" (license #f))))
- "invalid license"))
-
-(test-assert "home-page: wrong home-page"
- (->bool
- (string-contains
- (with-warnings
- (let ((pkg (package
- (inherit (dummy-package "x"))
- (home-page #f))))
- (check-home-page pkg)))
- "invalid")))
-
-(test-assert "home-page: invalid URI"
- (->bool
- (string-contains
- (with-warnings
- (let ((pkg (package
- (inherit (dummy-package "x"))
- (home-page "foobar"))))
- (check-home-page pkg)))
- "invalid home page URL")))
-
-(test-assert "home-page: host not found"
- (->bool
- (string-contains
- (with-warnings
- (let ((pkg (package
- (inherit (dummy-package "x"))
- (home-page "http://does-not-exist"))))
- (check-home-page pkg)))
- "domain not found")))
+ "'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-assert "home-page: Connection refused"
- (->bool
- (string-contains
- (with-warnings
- (let ((pkg (package
- (inherit (dummy-package "x"))
- (home-page (%local-url)))))
- (check-home-page pkg)))
- "Connection refused")))
+(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-warnings
- (with-http-server 200 %long-string
- (let ((pkg (package
- (inherit (dummy-package "x"))
- (home-page (%local-url)))))
- (check-home-page pkg)))))
+ '()
+ (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-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-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-assert "home-page: 404"
- (->bool
- (string-contains
- (with-warnings
- (with-http-server 404 %long-string
- (let ((pkg (package
- (inherit (dummy-package "x"))
- (home-page (%local-url)))))
- (check-home-page pkg))))
- "not reachable: 404")))
+(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-assert "home-page: 301, invalid"
- (->bool
- (string-contains
- (with-warnings
- (with-http-server 301 %long-string
- (let ((pkg (package
- (inherit (dummy-package "x"))
- (home-page (%local-url)))))
- (check-home-page pkg))))
- "invalid permanent redirect")))
+(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-assert "home-page: 301 -> 200"
- (->bool
- (string-contains
- (with-warnings
- (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)))))
- (check-home-page pkg)))))))
- "permanent redirect")))
+(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-assert "home-page: 301 -> 404"
- (->bool
- (string-contains
- (with-warnings
- (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)))))
- (check-home-page pkg)))))))
- "not reachable: 404")))
-
-(test-assert "source-file-name"
- (->bool
- (string-contains
- (with-warnings
- (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))))))
- (check-source-file-name pkg)))
- "file name should contain the package name")))
-
-(test-assert "source-file-name: v prefix"
- (->bool
- (string-contains
- (with-warnings
- (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))))))
- (check-source-file-name pkg)))
- "file name should contain the package name")))
-
-(test-assert "source-file-name: bad checkout"
- (->bool
- (string-contains
- (with-warnings
- (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))))))
- (check-source-file-name pkg)))
- "file name should contain the package name")))
-
-(test-assert "source-file-name: good checkout"
- (not
- (->bool
- (string-contains
- (with-warnings
- (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)))
- "file name should contain the package name"))))
-
-(test-assert "source-file-name: valid"
- (not
- (->bool
- (string-contains
- (with-warnings
- (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)))
- "file name should contain the package name"))))
-
-(test-assert "source-unstable-tarball"
- (string-contains
- (with-warnings
- (let ((pkg (dummy-package "x"
- (source
- (origin
- (method url-fetch)
- (uri "https://github.com/example/example/archive/v0.0.tar.gz")
- (sha256 %null-sha256))))))
- (check-source-unstable-tarball pkg)))
- "source URI should not be an autogenerated tarball"))
-
-(test-assert "source-unstable-tarball: source #f"
- (not
- (->bool
- (string-contains
- (with-warnings
- (let ((pkg (dummy-package "x"
- (source #f))))
- (check-source-unstable-tarball pkg)))
- "source URI should not be an autogenerated tarball"))))
-
-(test-assert "source-unstable-tarball: valid"
- (not
- (->bool
- (string-contains
- (with-warnings
- (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)))
- "source URI should not be an autogenerated tarball"))))
-
-(test-assert "source-unstable-tarball: package named archive"
- (not
- (->bool
- (string-contains
- (with-warnings
- (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)))
- "source URI should not be an autogenerated tarball"))))
-
-(test-assert "source-unstable-tarball: not-github"
- (not
- (->bool
- (string-contains
- (with-warnings
- (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)))
- "source URI should not be an autogenerated tarball"))))
-
-(test-assert "source-unstable-tarball: git-fetch"
- (not
- (->bool
- (string-contains
- (with-warnings
- (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)))
- "source URI should not be an autogenerated tarball"))))
+(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-skip (if (http-server-can-listen?) 0 1))
-(test-equal "source: 200"
- ""
- (with-warnings
- (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-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-skip (if (http-server-can-listen?) 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
+(test-equal "source-unstable-tarball: package named archive"
+ '()
+ (let ((pkg (dummy-package "x"
+ (source
+ (origin
(method url-fetch)
- (uri (%local-url))
+ (uri "https://github.com/example/archive/releases/download/x-0.0/x-0.0.tar.gz")
(sha256 %null-sha256))))))
- (check-source pkg))))
- "suspiciously small")))
+ (check-source-unstable-tarball pkg)))
-(test-skip (if (http-server-can-listen?) 0 1))
-(test-assert "source: 404"
- (->bool
- (string-contains
- (with-warnings
- (with-http-server 404 %long-string
- (let ((pkg (package
- (inherit (dummy-package "x"))
- (source (origin
+(test-equal "source-unstable-tarball: not-github"
+ '()
+ (let ((pkg (dummy-package "x"
+ (source
+ (origin
(method url-fetch)
- (uri (%local-url))
+ (uri "https://bitbucket.org/archive/example/download/x-0.0.tar.gz")
(sha256 %null-sha256))))))
- (check-source pkg))))
- "not reachable: 404")))
+ (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"
- ""
- (with-warnings
- (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))))))
- (check-source pkg))))))))
+ "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-assert "source: 301 -> 404"
- (->bool
- (string-contains
- (with-warnings
- (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))))))
- (check-source pkg)))))))
- "not reachable: 404")))
-
-(test-assert "mirror-url"
- (string-null?
- (with-warnings
- (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-assert "mirror-url: one suggestion"
- (string-contains
- (with-warnings
- (let ((source (origin
- (method url-fetch)
- (uri "http://ftp.gnu.org/pub/gnu/foo/foo.tar.gz")
- (sha256 %null-sha256))))
- (check-mirror-url (dummy-package "x" (source source)))))
- "mirror://gnu/foo/foo.tar.gz"))
-
-(test-assert "github-url"
- (string-null?
- (with-warnings
- (with-http-server 200 %long-string
- (check-github-url
- (dummy-package "x" (source
- (origin
- (method url-fetch)
- (uri (%local-url))
- (sha256 %null-sha256)))))))))
+(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-assert "github-url: one suggestion"
- (string-contains
- (with-warnings
- (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)))) ""
- (check-github-url
- (dummy-package "x" (source
- (origin
- (method url-fetch)
- (uri (%local-url))
- (sha256 %null-sha256))))))))))
- github-url))
- (test-assert "github-url: already the correct github url"
- (string-null?
- (with-warnings
- (check-github-url
- (dummy-package "x" (source
- (origin
- (method url-fetch)
- (uri github-url)
- (sha256 %null-sha256)))))))))
-
-(test-assert "cve"
+ (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 '()))
- (string-null?
- (with-warnings (check-vulnerabilities (dummy-package "x"))))))
+ (check-vulnerabilities (dummy-package "x"))))
-(test-assert "cve: one vulnerability"
+(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)))))))
- (string-contains
- (with-warnings
- (check-vulnerabilities (dummy-package "pi" (version "3.14"))))
- "vulnerable to CVE-2015-1234")))
+ (single-lint-warning-message
+ (check-vulnerabilities (dummy-package "pi" (version "3.14"))))))
-(test-assert "cve: one patched vulnerability"
+(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)))))))
- (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: known safe from vulnerability"
+ (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)))))))
- (string-null?
- (with-warnings
- (check-vulnerabilities
- (dummy-package "pi"
- (version "3.14")
- (properties `((lint-hidden-cve . ("CVE-2015-1234"))))))))))
-
-(test-assert "cve: vulnerability fixed in replacement version"
+ (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)
@@ -845,71 +765,60 @@
(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"
+ (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)))))))
- (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
- (check-formatting
- (
- dummy-package "ugly as hell!"
- )
- ))
- "lonely"))
+ (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-contains
- (with-warnings
- (check-formatting (dummy-package "leave the tab here: ")))
- "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-contains
- (with-warnings
- ;; Leave the trailing white space on the next line!
- (check-formatting (dummy-package "x")))
- "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-contains
- (with-warnings
- (check-formatting
- (dummy-package "x" ;here is a stupid comment just to make a long line
- )))
- "too long"))
-
-(test-assert "formatting: alright"
- (string-null?
- (with-warnings
- (check-formatting (dummy-package "x")))))
+ (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")
--
2.22.0
^ permalink raw reply related [flat|nested] 37+ messages in thread
* [bug#35790] [PATCH 2/2] scripts: lint: Separate the message warning text and data.
2019-06-29 11:25 ` [bug#35790] [PATCH 1/2] " Christopher Baines
@ 2019-06-29 11:25 ` Christopher Baines
0 siblings, 0 replies; 37+ messages in thread
From: Christopher Baines @ 2019-06-29 11:25 UTC (permalink / raw)
To: 35790
So that translations can be handled more flexibly, rather than having to
translate the message text within the checker.
* guix/scripts/lint.scm (lint-warning-message-text,
lint-warning-message-data): New procedures.
(lint-warning-message): Remove record field accessor, replace with procedure
that handles the lint warning data and translating the message.
(make-warning): Rename to %make-warning.
(make-warning): New macro.
(emit-warnings): Handle the message-text and message-data fields.
(check-description-style): Adjust for changes to make-warning.
[check-trademarks, check-end-of-sentence-space): Adjust for changes to
make-warning.
(check-inputs-should-be-native, check-inputs-should-not-be-an-input-at-all,
check-synopsis-style, validate-uri, check-home-page, check-patch-file-names,
check-gnu-synopsis+description, 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): Adjust for changes to make-warning.
---
guix/scripts/lint.scm | 198 ++++++++++++++++++++++--------------------
1 file changed, 106 insertions(+), 92 deletions(-)
diff --git a/guix/scripts/lint.scm b/guix/scripts/lint.scm
index 1b08068669..4eb7e0e200 100644
--- a/guix/scripts/lint.scm
+++ b/guix/scripts/lint.scm
@@ -88,6 +88,8 @@
lint-warning?
lint-warning-package
lint-warning-message
+ lint-warning-message-text
+ lint-warning-message-data
lint-warning-location
%checkers
@@ -105,35 +107,49 @@
(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)))
+ (package lint-warning-package)
+ (message-text lint-warning-message-text)
+ (message-data lint-warning-message-data
+ (default '()))
+ (location lint-warning-location
+ (default #f)))
+
+(define (lint-warning-message warning)
+ (apply format #f
+ (G_ (lint-warning-message-text warning))
+ (lint-warning-message-data warning)))
(define (package-file package)
(location-file
(package-location package)))
-(define* (make-warning package message
- #:key field location)
+(define* (%make-warning package message-text
+ #:optional (message-data '())
+ #:key field location)
(make-lint-warning
package
- message
+ message-text
+ message-data
(or location
(package-field-location package field)
(package-location package))))
+(define-syntax make-warning
+ (syntax-rules (G_)
+ ((_ package (G_ message) rest ...)
+ (%make-warning package message rest ...))))
+
(define (emit-warnings warnings)
;; 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
;; provided MESSAGE.
(for-each
(match-lambda
- (($ <lint-warning> package message loc)
+ (($ <lint-warning> package message-text message-data loc)
(format (guix-warning-port) "~a: ~a@~a: ~a~%"
(location->string loc)
(package-name package) (package-version package)
- message)))
+ (apply format #f (G_ message-text) message-data))))
warnings))
\f
@@ -199,9 +215,9 @@ http://www.gnu.org/prep/standards/html_node/Trademarks.html."
((and (? number?) index)
(list
(make-warning package
- (format #f (G_ "description should not contain ~
+ (G_ "description should not contain ~
trademark sign '~a' at ~d")
- (string-ref description index) index)
+ (list (string-ref description index) index)
#:field 'description)))
(else '())))
@@ -242,10 +258,10 @@ trademark sign '~a' at ~d")
'()
(list
(make-warning package
- (format #f (G_ "sentences in description should be followed ~
+ (G_ "sentences in description should be followed ~
by two spaces; possible infraction~p at ~{~a~^, ~}")
- (length infractions)
- infractions)
+ (list (length infractions)
+ infractions)
#:field 'description)))))
(let ((description (package-description package)))
@@ -263,7 +279,8 @@ by two spaces; possible infraction~p at ~{~a~^, ~}")
(check-proper-start plain-description))))
(list
(make-warning package
- (format #f (G_ "invalid description: ~s") description)
+ (G_ "invalid description: ~s")
+ (list description)
#:field 'description)))))
(define (package-input-intersection inputs-to-check input-names)
@@ -308,8 +325,8 @@ of a package, and INPUT-NAMES, a list of package specifications such as
(map (lambda (input)
(make-warning
package
- (format #f (G_ "'~a' should probably be a native input")
- input)
+ (G_ "'~a' should probably be a native input")
+ (list input)
#:field 'inputs))
(package-input-intersection inputs input-names))))
@@ -323,9 +340,8 @@ of a package, and INPUT-NAMES, a list of package specifications such as
(map (lambda (input)
(make-warning
package
- (format #f
- (G_ "'~a' should probably not be an input at all")
- input)
+ (G_ "'~a' should probably not be an input at all")
+ (list input)
#:field 'inputs))
(package-input-intersection (package-direct-inputs package)
input-names))))
@@ -423,7 +439,9 @@ markup is valid return a plain-text version of SYNOPSIS, otherwise #f."
checks))
(invalid
(list
- (make-warning package (format #f (G_ "invalid synopsis: ~s") invalid)
+ (make-warning package
+ (G_ "invalid synopsis: ~s")
+ (list invalid)
#:field 'synopsis)))))
(define* (probe-uri uri #:key timeout)
@@ -540,64 +558,59 @@ PACKAGE mentionning the FIELD."
;; such malicious behavior.
(or (> length 1000)
(make-warning package
- (format #f
- (G_ "URI ~a returned \
+ (G_ "URI ~a returned \
suspiciously small file (~a bytes)")
- (uri->string uri)
- length)
+ (list (uri->string uri)
+ length)
#:field field)))
(_ #t)))
((= 301 (response-code argument))
(if (response-location argument)
(make-warning package
- (format #f (G_ "permanent redirect from ~a to ~a")
- (uri->string uri)
- (uri->string
- (response-location argument)))
+ (G_ "permanent redirect from ~a to ~a")
+ (list (uri->string uri)
+ (uri->string
+ (response-location argument)))
#:field field)
(make-warning package
- (format #f (G_ "invalid permanent redirect \
+ (G_ "invalid permanent redirect \
from ~a")
- (uri->string uri))
+ (list (uri->string uri))
#:field field)))
(else
(make-warning package
- (format #f
- (G_ "URI ~a not reachable: ~a (~s)")
- (uri->string uri)
- (response-code argument)
- (response-reason-phrase argument))
+ (G_ "URI ~a not reachable: ~a (~s)")
+ (list (uri->string uri)
+ (response-code argument)
+ (response-reason-phrase argument))
#:field field))))
((ftp-response)
(match argument
(('ok) #t)
(('error port command code message)
(make-warning package
- (format #f
- (G_ "URI ~a not reachable: ~a (~s)")
- (uri->string uri)
- code (string-trim-both message))
+ (G_ "URI ~a not reachable: ~a (~s)")
+ (list (uri->string uri)
+ code (string-trim-both message))
#:field field))))
((getaddrinfo-error)
(make-warning package
- (format #f
- (G_ "URI ~a domain not found: ~a")
- (uri->string uri)
- (gai-strerror (car argument)))
+ (G_ "URI ~a domain not found: ~a")
+ (list (uri->string uri)
+ (gai-strerror (car argument)))
#:field field))
((system-error)
(make-warning package
- (format #f
- (G_ "URI ~a unreachable: ~a")
- (uri->string uri)
- (strerror
- (system-error-errno
- (cons status argument))))
+ (G_ "URI ~a unreachable: ~a")
+ (list (uri->string uri)
+ (strerror
+ (system-error-errno
+ (cons status argument))))
#:field field))
((tls-certificate-error)
(make-warning package
- (format #f (G_ "TLS certificate error: ~a")
- (tls-certificate-error-string argument))
+ (G_ "TLS certificate error: ~a")
+ (list (tls-certificate-error-string argument))
#:field field))
((invalid-http-response gnutls-error)
;; Probably a misbehaving server; ignore.
@@ -627,8 +640,9 @@ from ~a")
#:field 'home-page))))
(else
(list
- (make-warning package (format #f (G_ "invalid home page URL: ~s")
- (package-home-page package))
+ (make-warning package
+ (G_ "invalid home page URL: ~s")
+ (list (package-home-page package))
#:field 'home-page))))))
(define %distro-directory
@@ -640,8 +654,10 @@ from ~a")
patch could not be found."
(guard (c ((message-condition? c) ;raised by 'search-patch'
(list
- (make-warning package (condition-message c)
- #:field 'patch-file-names))))
+ ;; Use %make-warning, as condition-mesasge is already
+ ;; translated.
+ (%make-warning package (condition-message c)
+ #:field 'patch-file-names))))
(define patches
(or (and=> (package-source package) origin-patches)
'()))
@@ -674,8 +690,8 @@ patch could not be found."
max)
(make-warning
package
- (format #f (G_ "~a: file name is too long")
- (basename patch))
+ (G_ "~a: file name is too long")
+ (list (basename patch))
#:field 'patch-file-names)
#f))
(_ #f))
@@ -716,8 +732,8 @@ descriptions maintained upstream."
(not (string=? upstream downstream))))
(list
(make-warning package
- (format #f (G_ "proposed synopsis: ~s~%")
- upstream)
+ (G_ "proposed synopsis: ~s~%")
+ (list upstream)
#:field 'synopsis))
'()))
@@ -730,9 +746,8 @@ descriptions maintained upstream."
(list
(make-warning
package
- (format #f
- (G_ "proposed description:~% \"~a\"~%")
- (fill-paragraph (escape-quotes upstream) 77 7))
+ (G_ "proposed description:~% \"~a\"~%")
+ (list (fill-paragraph (escape-quotes upstream) 77 7))
#:field 'description))
'()))))))
@@ -831,10 +846,10 @@ descriptions maintained upstream."
(loop rest))
(prefix
(make-warning package
- (format #f (G_ "URL should be \
+ (G_ "URL should be \
'mirror://~a/~a'")
- mirror-id
- (string-drop uri (string-length prefix)))
+ (list mirror-id
+ (string-drop uri (string-length prefix)))
#:field 'source)))))))
(let ((origin (package-source package)))
@@ -876,7 +891,8 @@ descriptions maintained upstream."
#f
(make-warning
package
- (format #f (G_ "URL should be '~a'") github-uri)
+ (G_ "URL should be '~a'")
+ (list github-uri)
#:field 'source)))))
(origin-uris origin))
'())))
@@ -888,14 +904,14 @@ descriptions maintained upstream."
(lambda ()
(guard (c ((store-protocol-error? c)
(make-warning package
- (format #f (G_ "failed to create ~a derivation: ~a")
- system
- (store-protocol-error-message c))))
+ (G_ "failed to create ~a derivation: ~a")
+ (list system
+ (store-protocol-error-message c))))
((message-condition? c)
(make-warning package
- (format #f (G_ "failed to create ~a derivation: ~a")
- system
- (condition-message c)))))
+ (G_ "failed to create ~a derivation: ~a")
+ (list system
+ (condition-message c)))))
(with-store store
;; Disable grafts since it can entail rebuilds.
(parameterize ((%graft? #f))
@@ -910,8 +926,8 @@ descriptions maintained upstream."
#:graft? #f)))))))
(lambda args
(make-warning package
- (format #f (G_ "failed to create ~a derivation: ~s")
- system args)))))
+ (G_ "failed to create ~a derivation: ~s")
+ (list system args)))))
(filter lint-warning?
(map try (package-supported-systems package))))
@@ -1001,15 +1017,15 @@ the NIST server non-fatal."
(list
(make-warning
package
- (format #f (G_ "probably vulnerable to ~a")
- (string-join (map vulnerability-id unpatched)
- ", "))))))))))
+ (G_ "probably vulnerable to ~a")
+ (list (string-join (map vulnerability-id unpatched)
+ ", "))))))))))
(define (check-for-updates package)
"Check if there is an update available for PACKAGE."
(match (with-networking-fail-safe
- (format #f (G_ "while retrieving upstream info for '~a'")
- (package-name package))
+ (G_ "while retrieving upstream info for '~a'")
+ (list (package-name package))
#f
(package-latest-release* package (force %updaters)))
((? upstream-source? source)
@@ -1017,8 +1033,8 @@ the NIST server non-fatal."
(package-version package))
(list
(make-warning package
- (format #f (G_ "can be upgraded to ~a")
- (upstream-source-version source))
+ (G_ "can be upgraded to ~a")
+ (list (upstream-source-version source))
#:field 'version))
'()))
(#f '()))) ; cannot find newer upstream release
@@ -1034,8 +1050,8 @@ the NIST server non-fatal."
(#f #t)
(index
(make-warning package
- (format #f (G_ "tabulation on line ~a, column ~a")
- line-number index)
+ (G_ "tabulation on line ~a, column ~a")
+ (list line-number index)
#:location
(location (package-file package)
line-number
@@ -1046,9 +1062,8 @@ the NIST server non-fatal."
(unless (or (string=? line (string-trim-right line))
(string=? line (string #\page)))
(make-warning package
- (format #f
- (G_ "trailing white space on line ~a")
- line-number)
+ (G_ "trailing white space on line ~a")
+ (list line-number)
#:location
(location (package-file package)
line-number
@@ -1061,8 +1076,8 @@ the NIST server non-fatal."
;; much noise.
(when (> (string-length line) 90)
(make-warning package
- (format #f (G_ "line ~a is way too long (~a characters)")
- line-number (string-length line))
+ (G_ "line ~a is way too long (~a characters)")
+ (list line-number (string-length line))
#:location
(location (package-file package)
line-number
@@ -1075,10 +1090,9 @@ the NIST server non-fatal."
"Emit a warning if LINE contains hanging parentheses."
(when (regexp-exec %hanging-paren-rx line)
(make-warning package
- (format #f
- (G_ "parentheses feel lonely, \
+ (G_ "parentheses feel lonely, \
move to the previous or next line")
- line-number)
+ (list line-number)
#:location
(location (package-file package)
line-number
--
2.22.0
^ permalink raw reply related [flat|nested] 37+ messages in thread
* [bug#35790] [PATCH] scripts: lint: Handle warnings with a record type.
2019-06-24 8:39 ` Ludovic Courtès
2019-06-29 11:25 ` [bug#35790] [PATCH 1/2] " Christopher Baines
@ 2019-06-29 11:56 ` Christopher Baines
2019-07-01 12:32 ` Ludovic Courtès
1 sibling, 1 reply; 37+ messages in thread
From: Christopher Baines @ 2019-06-29 11:56 UTC (permalink / raw)
To: Ludovic Courtès; +Cc: 35790
[-- Attachment #1: Type: text/plain, Size: 700 bytes --]
Ludovic Courtès <ludo@gnu.org> writes:
> Hi Chris,
>
> Christopher Baines <mail@cbaines.net> skribis:
>
>> Thanks, so if I set the bindtextdomain, things do indeed work
>> better. So, regarding these two patches, I've got the following things
>> on my mind...
>>
>> - As they change so many things, I'm not sure what to add for the GNU
>> changelog at the end of the commit message?
>
> I think you should try to write the commit log the usual way, by
> listing every changed entity. It’s a bit tedious, but it’s also a good
> way to review everything (and Magit makes it relatively easy.)
Ok, I've now made an initial attempt at this, and sent some updated
patches.
[-- Attachment #2: signature.asc --]
[-- Type: application/pgp-signature, Size: 962 bytes --]
^ permalink raw reply [flat|nested] 37+ messages in thread
* [bug#35790] [PATCH] scripts: lint: Handle warnings with a record type.
2019-06-29 11:56 ` [bug#35790] [PATCH] scripts: lint: Handle warnings with a record type Christopher Baines
@ 2019-07-01 12:32 ` Ludovic Courtès
2019-07-02 19:25 ` [bug#35790] [PATCH 1/2] lint: Move the linting code to a different module Christopher Baines
2019-07-02 20:15 ` [bug#35790] [PATCH] scripts: lint: Handle warnings with a record type Christopher Baines
0 siblings, 2 replies; 37+ messages in thread
From: Ludovic Courtès @ 2019-07-01 12:32 UTC (permalink / raw)
To: Christopher Baines; +Cc: 35790
Hi!
Christopher Baines <mail@cbaines.net> skribis:
> Ludovic Courtès <ludo@gnu.org> writes:
>
>> Hi Chris,
>>
>> Christopher Baines <mail@cbaines.net> skribis:
>>
>>> Thanks, so if I set the bindtextdomain, things do indeed work
>>> better. So, regarding these two patches, I've got the following things
>>> on my mind...
>>>
>>> - As they change so many things, I'm not sure what to add for the GNU
>>> changelog at the end of the commit message?
>>
>> I think you should try to write the commit log the usual way, by
>> listing every changed entity. It’s a bit tedious, but it’s also a good
>> way to review everything (and Magit makes it relatively easy.)
>
> Ok, I've now made an initial attempt at this, and sent some updated
> patches.
Perfect, thanks for taking the time to do it.
Time to push! :-)
Thanks,
Ludo’.
^ permalink raw reply [flat|nested] 37+ messages in thread
* [bug#35790] [PATCH 1/2] lint: Move the linting code to a different module.
2019-07-01 12:32 ` Ludovic Courtès
@ 2019-07-02 19:25 ` Christopher Baines
2019-07-02 19:25 ` [bug#35790] [PATCH 2/2] lint: Separate checkers by dependence on the internet Christopher Baines
2019-07-12 14:36 ` [bug#35790] [PATCH 1/2] lint: Move the linting code to a different module Ludovic Courtès
2019-07-02 20:15 ` [bug#35790] [PATCH] scripts: lint: Handle warnings with a record type Christopher Baines
1 sibling, 2 replies; 37+ messages in thread
From: Christopher Baines @ 2019-07-02 19:25 UTC (permalink / raw)
To: 35790
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.
---
Makefile.am | 1 +
guix/lint.scm | 1234 +++++++++++++++++++++++++++++++++++++++++
guix/scripts/lint.scm | 1220 +---------------------------------------
tests/lint.scm | 2 +-
4 files changed, 1248 insertions(+), 1209 deletions(-)
create mode 100644 guix/lint.scm
diff --git a/Makefile.am b/Makefile.am
index 80be73e4bf..0baadcde9c 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -97,6 +97,7 @@ MODULES = \
guix/self.scm \
guix/upstream.scm \
guix/licenses.scm \
+ guix/lint.scm \
guix/glob.scm \
guix/git.scm \
guix/graph.scm \
diff --git a/guix/lint.scm b/guix/lint.scm
new file mode 100644
index 0000000000..f86e494be5
--- /dev/null
+++ b/guix/lint.scm
@@ -0,0 +1,1234 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2014 Cyril Roelandt <tipecaml@gmail.com>
+;;; Copyright © 2014, 2015 Eric Bavier <bavier@member.fsf.org>
+;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2015, 2016 Mathieu Lirzin <mthl@gnu.org>
+;;; Copyright © 2016 Danny Milosavljevic <dannym+a@scratchpost.org>
+;;; Copyright © 2016 Hartmut Goebel <h.goebel@crazy-compilers.com>
+;;; Copyright © 2017 Alex Kost <alezost@gmail.com>
+;;; Copyright © 2017 Tobias Geerinckx-Rice <me@tobias.gr>
+;;; Copyright © 2017, 2018 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/>.
+
+(define-module (guix lint)
+ #:use-module ((guix store) #:hide (close-connection))
+ #:use-module (guix base32)
+ #:use-module (guix download)
+ #:use-module (guix ftp-client)
+ #:use-module (guix http-client)
+ #:use-module (guix packages)
+ #:use-module (guix licenses)
+ #:use-module (guix records)
+ #:use-module (guix grafts)
+ #:use-module (guix ui)
+ #:use-module (guix upstream)
+ #:use-module (guix utils)
+ #:use-module (guix memoization)
+ #:use-module (guix scripts)
+ #:use-module (guix gnu-maintenance)
+ #:use-module (guix monads)
+ #:use-module (guix cve)
+ #:use-module (gnu packages)
+ #:use-module (ice-9 match)
+ #:use-module (ice-9 regex)
+ #:use-module (ice-9 format)
+ #:use-module (web client)
+ #:use-module (web uri)
+ #:use-module ((guix build download)
+ #:select (maybe-expand-mirrors
+ (open-connection-for-uri
+ . guix:open-connection-for-uri)
+ close-connection))
+ #:use-module (web request)
+ #:use-module (web response)
+ #:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-6) ;Unicode string ports
+ #:use-module (srfi srfi-9)
+ #:use-module (srfi srfi-11)
+ #:use-module (srfi srfi-26)
+ #:use-module (srfi srfi-34)
+ #:use-module (srfi srfi-35)
+ #:use-module (ice-9 rdelim)
+ #:export (check-description-style
+ check-inputs-should-be-native
+ check-inputs-should-not-be-an-input-at-all
+ check-patch-file-names
+ check-synopsis-style
+ check-derivation
+ check-home-page
+ check-source
+ check-source-file-name
+ check-source-unstable-tarball
+ check-mirror-url
+ check-github-url
+ check-license
+ check-vulnerabilities
+ check-for-updates
+ check-formatting
+
+ lint-warning
+ lint-warning?
+ lint-warning-package
+ lint-warning-message
+ lint-warning-message-text
+ lint-warning-message-data
+ lint-warning-location
+
+ emit-warnings
+
+ %checkers
+ lint-checker
+ lint-checker?
+ lint-checker-name
+ lint-checker-description
+ lint-checker-check))
+
+\f
+;;;
+;;; Warnings
+;;;
+
+(define-record-type* <lint-warning>
+ lint-warning make-lint-warning
+ lint-warning?
+ (package lint-warning-package)
+ (message-text lint-warning-message-text)
+ (message-data lint-warning-message-data
+ (default '()))
+ (location lint-warning-location
+ (default #f)))
+
+(define (lint-warning-message warning)
+ (apply format #f
+ (G_ (lint-warning-message-text warning))
+ (lint-warning-message-data warning)))
+
+(define (package-file package)
+ (location-file
+ (package-location package)))
+
+(define* (%make-warning package message-text
+ #:optional (message-data '())
+ #:key field location)
+ (make-lint-warning
+ package
+ message-text
+ message-data
+ (or location
+ (package-field-location package field)
+ (package-location package))))
+
+(define-syntax make-warning
+ (syntax-rules (G_)
+ ((_ package (G_ message) rest ...)
+ (%make-warning package message rest ...))))
+
+(define (emit-warnings warnings)
+ ;; 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
+ ;; provided MESSAGE.
+ (for-each
+ (match-lambda
+ (($ <lint-warning> package message-text message-data loc)
+ (format (guix-warning-port) "~a: ~a@~a: ~a~%"
+ (location->string loc)
+ (package-name package) (package-version package)
+ (apply format #f (G_ message-text) message-data))))
+ warnings))
+
+\f
+;;;
+;;; Checkers
+;;;
+
+(define-record-type* <lint-checker>
+ lint-checker make-lint-checker
+ lint-checker?
+ ;; TODO: add a 'certainty' field that shows how confident we are in the
+ ;; checker. Then allow users to only run checkers that have a certain
+ ;; 'certainty' level.
+ (name lint-checker-name)
+ (description lint-checker-description)
+ (check lint-checker-check))
+
+(define (properly-starts-sentence? s)
+ (string-match "^[(\"'`[:upper:][:digit:]]" s))
+
+(define (starts-with-abbreviation? s)
+ "Return #t if S starts with what looks like an abbreviation or acronym."
+ (string-match "^[A-Z][A-Z0-9]+\\>" s))
+
+(define %quoted-identifier-rx
+ ;; A quoted identifier, like 'this'.
+ (make-regexp "['`][[:graph:]]+'"))
+
+(define (check-description-style package)
+ ;; Emit a warning if stylistic issues are found in the description of PACKAGE.
+ (define (check-not-empty description)
+ (if (string-null? description)
+ (list
+ (make-warning package
+ (G_ "description should not be empty")
+ #:field 'description))
+ '()))
+
+ (define (check-texinfo-markup description)
+ "Check that DESCRIPTION can be parsed as a Texinfo fragment. If the
+markup is valid return a plain-text version of DESCRIPTION, otherwise #f."
+ (catch #t
+ (lambda () (texi->plain-text description))
+ (lambda (keys . args)
+ (make-warning package
+ (G_ "Texinfo markup in description is invalid")
+ #:field 'description))))
+
+ (define (check-trademarks description)
+ "Check that DESCRIPTION does not contain '™' or '®' characters. See
+http://www.gnu.org/prep/standards/html_node/Trademarks.html."
+ (match (string-index description (char-set #\™ #\®))
+ ((and (? number?) index)
+ (list
+ (make-warning package
+ (G_ "description should not contain ~
+trademark sign '~a' at ~d")
+ (list (string-ref description index) index)
+ #:field 'description)))
+ (else '())))
+
+ (define (check-quotes description)
+ "Check whether DESCRIPTION contains single quotes and suggest @code."
+ (if (regexp-exec %quoted-identifier-rx description)
+ (list
+ (make-warning package
+ ;; TRANSLATORS: '@code' is Texinfo markup and must be kept
+ ;; as is.
+ (G_ "use @code or similar ornament instead of quotes")
+ #:field 'description))
+ '()))
+
+ (define (check-proper-start description)
+ (if (or (string-null? description)
+ (properly-starts-sentence? description)
+ (string-prefix-ci? (package-name package) description))
+ '()
+ (list
+ (make-warning
+ package
+ (G_ "description should start with an upper-case letter or digit")
+ #:field 'description))))
+
+ (define (check-end-of-sentence-space description)
+ "Check that an end-of-sentence period is followed by two spaces."
+ (let ((infractions
+ (reverse (fold-matches
+ "\\. [A-Z]" description '()
+ (lambda (m r)
+ ;; Filter out matches of common abbreviations.
+ (if (find (lambda (s)
+ (string-suffix-ci? s (match:prefix m)))
+ '("i.e" "e.g" "a.k.a" "resp"))
+ r (cons (match:start m) r)))))))
+ (if (null? infractions)
+ '()
+ (list
+ (make-warning package
+ (G_ "sentences in description should be followed ~
+by two spaces; possible infraction~p at ~{~a~^, ~}")
+ (list (length infractions)
+ infractions)
+ #:field 'description)))))
+
+ (let ((description (package-description package)))
+ (if (string? description)
+ (append
+ (check-not-empty description)
+ (check-quotes description)
+ (check-trademarks description)
+ ;; Use raw description for this because Texinfo rendering
+ ;; automatically fixes end of sentence space.
+ (check-end-of-sentence-space description)
+ (match (check-texinfo-markup description)
+ ((and warning (? lint-warning?)) (list warning))
+ (plain-description
+ (check-proper-start plain-description))))
+ (list
+ (make-warning package
+ (G_ "invalid description: ~s")
+ (list description)
+ #:field 'description)))))
+
+(define (package-input-intersection inputs-to-check input-names)
+ "Return the intersection between INPUTS-TO-CHECK, the list of input tuples
+of a package, and INPUT-NAMES, a list of package specifications such as
+\"glib:bin\"."
+ (match inputs-to-check
+ (((labels packages . outputs) ...)
+ (filter-map (lambda (package output)
+ (and (package? package)
+ (let ((input (string-append
+ (package-name package)
+ (if (> (length output) 0)
+ (string-append ":" (car output))
+ ""))))
+ (and (member input input-names)
+ input))))
+ packages outputs))))
+
+(define (check-inputs-should-be-native package)
+ ;; Emit a warning if some inputs of PACKAGE are likely to belong to its
+ ;; native inputs.
+ (let ((inputs (package-inputs package))
+ (input-names
+ '("pkg-config"
+ "cmake"
+ "extra-cmake-modules"
+ "glib:bin"
+ "intltool"
+ "itstool"
+ "qttools"
+ "python-coverage" "python2-coverage"
+ "python-cython" "python2-cython"
+ "python-docutils" "python2-docutils"
+ "python-mock" "python2-mock"
+ "python-nose" "python2-nose"
+ "python-pbr" "python2-pbr"
+ "python-pytest" "python2-pytest"
+ "python-pytest-cov" "python2-pytest-cov"
+ "python-setuptools-scm" "python2-setuptools-scm"
+ "python-sphinx" "python2-sphinx")))
+ (map (lambda (input)
+ (make-warning
+ package
+ (G_ "'~a' should probably be a native input")
+ (list input)
+ #:field 'inputs))
+ (package-input-intersection inputs input-names))))
+
+(define (check-inputs-should-not-be-an-input-at-all package)
+ ;; Emit a warning if some inputs of PACKAGE are likely to should not be
+ ;; an input at all.
+ (let ((input-names '("python-setuptools"
+ "python2-setuptools"
+ "python-pip"
+ "python2-pip")))
+ (map (lambda (input)
+ (make-warning
+ package
+ (G_ "'~a' should probably not be an input at all")
+ (list input)
+ #:field 'inputs))
+ (package-input-intersection (package-direct-inputs package)
+ input-names))))
+
+(define (package-name-regexp package)
+ "Return a regexp that matches PACKAGE's name as a word at the beginning of a
+line."
+ (make-regexp (string-append "^" (regexp-quote (package-name package))
+ "\\>")
+ regexp/icase))
+
+(define (check-synopsis-style package)
+ ;; Emit a warning if stylistic issues are found in the synopsis of PACKAGE.
+ (define (check-final-period synopsis)
+ ;; Synopsis should not end with a period, except for some special cases.
+ (if (and (string-suffix? "." synopsis)
+ (not (string-suffix? "etc." synopsis)))
+ (list
+ (make-warning package
+ (G_ "no period allowed at the end of the synopsis")
+ #:field 'synopsis))
+ '()))
+
+ (define check-start-article
+ ;; 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>.
+ (if (false-if-exception (gnu-package? package))
+ (const '())
+ (lambda (synopsis)
+ (if (or (string-prefix-ci? "A " synopsis)
+ (string-prefix-ci? "An " synopsis))
+ (list
+ (make-warning package
+ (G_ "no article allowed at the beginning of \
+the synopsis")
+ #:field 'synopsis))
+ '()))))
+
+ (define (check-synopsis-length synopsis)
+ (if (>= (string-length synopsis) 80)
+ (list
+ (make-warning package
+ (G_ "synopsis should be less than 80 characters long")
+ #:field 'synopsis))
+ '()))
+
+ (define (check-proper-start synopsis)
+ (if (properly-starts-sentence? synopsis)
+ '()
+ (list
+ (make-warning package
+ (G_ "synopsis should start with an upper-case letter or digit")
+ #:field 'synopsis))))
+
+ (define (check-start-with-package-name synopsis)
+ (if (and (regexp-exec (package-name-regexp package) synopsis)
+ (not (starts-with-abbreviation? synopsis)))
+ (list
+ (make-warning package
+ (G_ "synopsis should not start with the package name")
+ #:field 'synopsis))
+ '()))
+
+ (define (check-texinfo-markup synopsis)
+ "Check that SYNOPSIS can be parsed as a Texinfo fragment. If the
+markup is valid return a plain-text version of SYNOPSIS, otherwise #f."
+ (catch #t
+ (lambda ()
+ (texi->plain-text synopsis)
+ '())
+ (lambda (keys . args)
+ (list
+ (make-warning package
+ (G_ "Texinfo markup in synopsis is invalid")
+ #:field 'synopsis)))))
+
+ (define checks
+ (list check-proper-start
+ check-final-period
+ check-start-article
+ check-start-with-package-name
+ check-synopsis-length
+ check-texinfo-markup))
+
+ (match (package-synopsis package)
+ (""
+ (list
+ (make-warning package
+ (G_ "synopsis should not be empty")
+ #:field 'synopsis)))
+ ((? string? synopsis)
+ (append-map
+ (lambda (proc)
+ (proc synopsis))
+ checks))
+ (invalid
+ (list
+ (make-warning package
+ (G_ "invalid synopsis: ~s")
+ (list invalid)
+ #:field 'synopsis)))))
+
+(define* (probe-uri uri #:key timeout)
+ "Probe URI, a URI object, and return two values: a symbol denoting the
+probing status, such as 'http-response' when we managed to get an HTTP
+response from URI, and additional details, such as the actual HTTP response.
+
+TIMEOUT is the maximum number of seconds (possibly an inexact number) to wait
+for connections to complete; when TIMEOUT is #f, wait as long as needed."
+ (define headers
+ '((User-Agent . "GNU Guile")
+ (Accept . "*/*")))
+
+ (let loop ((uri uri)
+ (visited '()))
+ (match (uri-scheme uri)
+ ((or 'http 'https)
+ (catch #t
+ (lambda ()
+ (let ((port (guix:open-connection-for-uri
+ uri #:timeout timeout))
+ (request (build-request uri #:headers headers)))
+ (define response
+ (dynamic-wind
+ (const #f)
+ (lambda ()
+ (write-request request port)
+ (force-output port)
+ (read-response port))
+ (lambda ()
+ (close-connection port))))
+
+ (case (response-code response)
+ ((302 ; found (redirection)
+ 303 ; see other
+ 307 ; temporary redirection
+ 308) ; permanent redirection
+ (let ((location (response-location response)))
+ (if (or (not location) (member location visited))
+ (values 'http-response response)
+ (loop location (cons location visited))))) ;follow the redirect
+ ((301) ; moved permanently
+ (let ((location (response-location response)))
+ ;; Return RESPONSE, unless the final response as we follow
+ ;; redirects is not 200.
+ (if location
+ (let-values (((status response2)
+ (loop location (cons location visited))))
+ (case status
+ ((http-response)
+ (values 'http-response
+ (if (= 200 (response-code response2))
+ response
+ response2)))
+ (else
+ (values status response2))))
+ (values 'http-response response)))) ;invalid redirect
+ (else
+ (values 'http-response response)))))
+ (lambda (key . args)
+ (case key
+ ((bad-header bad-header-component)
+ ;; This can happen if the server returns an invalid HTTP header,
+ ;; as is the case with the 'Date' header at sqlite.org.
+ (values 'invalid-http-response #f))
+ ((getaddrinfo-error system-error
+ gnutls-error tls-certificate-error)
+ (values key args))
+ (else
+ (apply throw key args))))))
+ ('ftp
+ (catch #t
+ (lambda ()
+ (let ((conn (ftp-open (uri-host uri) #:timeout timeout)))
+ (define response
+ (dynamic-wind
+ (const #f)
+ (lambda ()
+ (ftp-chdir conn (dirname (uri-path uri)))
+ (ftp-size conn (basename (uri-path uri))))
+ (lambda ()
+ (ftp-close conn))))
+ (values 'ftp-response '(ok))))
+ (lambda (key . args)
+ (case key
+ ((ftp-error)
+ (values 'ftp-response `(error ,@args)))
+ ((getaddrinfo-error system-error gnutls-error)
+ (values key args))
+ (else
+ (apply throw key args))))))
+ (_
+ (values 'unknown-protocol #f)))))
+
+(define (tls-certificate-error-string args)
+ "Return a string explaining the 'tls-certificate-error' arguments ARGS."
+ (call-with-output-string
+ (lambda (port)
+ (print-exception port #f
+ 'tls-certificate-error args))))
+
+(define (validate-uri uri package field)
+ "Return #t if the given URI can be reached, otherwise return a warning for
+PACKAGE mentionning the FIELD."
+ (let-values (((status argument)
+ (probe-uri uri #:timeout 3))) ;wait at most 3 seconds
+ (case status
+ ((http-response)
+ (cond ((= 200 (response-code argument))
+ (match (response-content-length argument)
+ ((? number? length)
+ ;; As of July 2016, SourceForge returns 200 (instead of 404)
+ ;; with a small HTML page upon failure. Attempt to detect
+ ;; such malicious behavior.
+ (or (> length 1000)
+ (make-warning package
+ (G_ "URI ~a returned \
+suspiciously small file (~a bytes)")
+ (list (uri->string uri)
+ length)
+ #:field field)))
+ (_ #t)))
+ ((= 301 (response-code argument))
+ (if (response-location argument)
+ (make-warning package
+ (G_ "permanent redirect from ~a to ~a")
+ (list (uri->string uri)
+ (uri->string
+ (response-location argument)))
+ #:field field)
+ (make-warning package
+ (G_ "invalid permanent redirect \
+from ~a")
+ (list (uri->string uri))
+ #:field field)))
+ (else
+ (make-warning package
+ (G_ "URI ~a not reachable: ~a (~s)")
+ (list (uri->string uri)
+ (response-code argument)
+ (response-reason-phrase argument))
+ #:field field))))
+ ((ftp-response)
+ (match argument
+ (('ok) #t)
+ (('error port command code message)
+ (make-warning package
+ (G_ "URI ~a not reachable: ~a (~s)")
+ (list (uri->string uri)
+ code (string-trim-both message))
+ #:field field))))
+ ((getaddrinfo-error)
+ (make-warning package
+ (G_ "URI ~a domain not found: ~a")
+ (list (uri->string uri)
+ (gai-strerror (car argument)))
+ #:field field))
+ ((system-error)
+ (make-warning package
+ (G_ "URI ~a unreachable: ~a")
+ (list (uri->string uri)
+ (strerror
+ (system-error-errno
+ (cons status argument))))
+ #:field field))
+ ((tls-certificate-error)
+ (make-warning package
+ (G_ "TLS certificate error: ~a")
+ (list (tls-certificate-error-string argument))
+ #:field field))
+ ((invalid-http-response gnutls-error)
+ ;; Probably a misbehaving server; ignore.
+ #f)
+ ((unknown-protocol) ;nothing we can do
+ #f)
+ (else
+ (error "internal linter error" status)))))
+
+(define (check-home-page package)
+ "Emit a warning if PACKAGE has an invalid 'home-page' field, or if that
+'home-page' is not reachable."
+ (let ((uri (and=> (package-home-page package) string->uri)))
+ (cond
+ ((uri? uri)
+ (match (validate-uri uri package 'home-page)
+ ((and (? lint-warning? warning) warning)
+ (list warning))
+ (_ '())))
+ ((not (package-home-page package))
+ (if (or (string-contains (package-name package) "bootstrap")
+ (string=? (package-name package) "ld-wrapper"))
+ '()
+ (list
+ (make-warning package
+ (G_ "invalid value for home page")
+ #:field 'home-page))))
+ (else
+ (list
+ (make-warning package
+ (G_ "invalid home page URL: ~s")
+ (list (package-home-page package))
+ #:field 'home-page))))))
+
+(define %distro-directory
+ (mlambda ()
+ (dirname (search-path %load-path "gnu.scm"))))
+
+(define (check-patch-file-names package)
+ "Emit a warning if the patches requires by PACKAGE are badly named or if the
+patch could not be found."
+ (guard (c ((message-condition? c) ;raised by 'search-patch'
+ (list
+ ;; Use %make-warning, as condition-mesasge is already
+ ;; translated.
+ (%make-warning package (condition-message c)
+ #:field 'patch-file-names))))
+ (define patches
+ (or (and=> (package-source package) origin-patches)
+ '()))
+
+ (append
+ (if (every (match-lambda ;patch starts with package name?
+ ((? string? patch)
+ (and=> (string-contains (basename patch)
+ (package-name package))
+ zero?))
+ (_ #f)) ;must be an <origin> or something like that.
+ patches)
+ '()
+ (list
+ (make-warning
+ package
+ (G_ "file names of patches should start with the package name")
+ #:field 'patch-file-names)))
+
+ ;; Check whether we're reaching tar's maximum file name length.
+ (let ((prefix (string-length (%distro-directory)))
+ (margin (string-length "guix-0.13.0-10-123456789/"))
+ (max 99))
+ (filter-map (match-lambda
+ ((? string? patch)
+ (if (> (+ margin (if (string-prefix? (%distro-directory)
+ patch)
+ (- (string-length patch) prefix)
+ (string-length patch)))
+ max)
+ (make-warning
+ package
+ (G_ "~a: file name is too long")
+ (list (basename patch))
+ #:field 'patch-file-names)
+ #f))
+ (_ #f))
+ patches)))))
+
+(define (escape-quotes str)
+ "Replace any quote character in STR by an escaped quote character."
+ (list->string
+ (string-fold-right (lambda (chr result)
+ (match chr
+ (#\" (cons* #\\ #\"result))
+ (_ (cons chr result))))
+ '()
+ str)))
+
+(define official-gnu-packages*
+ (mlambda ()
+ "A memoizing version of 'official-gnu-packages' that returns the empty
+list when something goes wrong, such as a networking issue."
+ (let ((gnus (false-if-exception (official-gnu-packages))))
+ (or gnus '()))))
+
+(define (check-gnu-synopsis+description package)
+ "Make sure that, if PACKAGE is a GNU package, it uses the synopsis and
+descriptions maintained upstream."
+ (match (find (lambda (descriptor)
+ (string=? (gnu-package-name descriptor)
+ (package-name package)))
+ (official-gnu-packages*))
+ (#f ;not a GNU package, so nothing to do
+ '())
+ (descriptor ;a genuine GNU package
+ (append
+ (let ((upstream (gnu-package-doc-summary descriptor))
+ (downstream (package-synopsis package)))
+ (if (and upstream
+ (or (not (string? downstream))
+ (not (string=? upstream downstream))))
+ (list
+ (make-warning package
+ (G_ "proposed synopsis: ~s~%")
+ (list upstream)
+ #:field 'synopsis))
+ '()))
+
+ (let ((upstream (gnu-package-doc-description descriptor))
+ (downstream (package-description package)))
+ (if (and upstream
+ (or (not (string? downstream))
+ (not (string=? (fill-paragraph upstream 100)
+ (fill-paragraph downstream 100)))))
+ (list
+ (make-warning
+ package
+ (G_ "proposed description:~% \"~a\"~%")
+ (list (fill-paragraph (escape-quotes upstream) 77 7))
+ #:field 'description))
+ '()))))))
+
+(define (origin-uris origin)
+ "Return the list of URIs (strings) for ORIGIN."
+ (match (origin-uri origin)
+ ((? string? uri)
+ (list uri))
+ ((uris ...)
+ uris)))
+
+(define (check-source package)
+ "Emit a warning if PACKAGE has an invalid 'source' field, or if that
+'source' is not reachable."
+ (define (warnings-for-uris uris)
+ (filter lint-warning?
+ (map
+ (lambda (uri)
+ (validate-uri uri package 'source))
+ (append-map (cut maybe-expand-mirrors <> %mirrors)
+ uris))))
+
+ (let ((origin (package-source package)))
+ (if (and origin
+ (eqv? (origin-method origin) url-fetch))
+ (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.
+ (if (eq? (length uris) (length warnings))
+ ;; When everything fails, report all of WARNINGS, otherwise don't
+ ;; report anything.
+ ;;
+ ;; XXX: Ideally we'd still allow warnings to be raised if *some*
+ ;; URIs are unreachable, but distinguish that from the error case
+ ;; where *all* the URIs are unreachable.
+ (cons*
+ (make-warning package
+ (G_ "all the source URIs are unreachable:")
+ #:field 'source)
+ warnings)
+ '()))
+ '())))
+
+(define (check-source-file-name package)
+ "Emit a warning if PACKAGE's origin has no meaningful file name."
+ (define (origin-file-name-valid? origin)
+ ;; Return #f if the source file name contains only a version or is #f;
+ ;; indicates that the origin needs a 'file-name' field.
+ (let ((file-name (origin-actual-file-name origin))
+ (version (package-version package)))
+ (and file-name
+ ;; Common in many projects is for the filename to start
+ ;; with a "v" followed by the version,
+ ;; e.g. "v3.2.0.tar.gz".
+ (not (string-match (string-append "^v?" version) file-name)))))
+
+ (let ((origin (package-source package)))
+ (if (or (not origin) (origin-file-name-valid? origin))
+ '()
+ (list
+ (make-warning package
+ (G_ "the source file name should contain the package name")
+ #:field 'source)))))
+
+(define (check-source-unstable-tarball package)
+ "Emit a warning if PACKAGE's source is an autogenerated tarball."
+ (define (check-source-uri uri)
+ (if (and (string=? (uri-host (string->uri uri)) "github.com")
+ (match (split-and-decode-uri-path
+ (uri-path (string->uri uri)))
+ ((_ _ "archive" _ ...) #t)
+ (_ #f)))
+ (make-warning package
+ (G_ "the source URI should not be an autogenerated tarball")
+ #:field 'source)
+ #f))
+
+ (let ((origin (package-source package)))
+ (if (and (origin? origin)
+ (eqv? (origin-method origin) url-fetch))
+ (filter-map check-source-uri
+ (origin-uris origin))
+ '())))
+
+(define (check-mirror-url package)
+ "Check whether PACKAGE uses source URLs that should be 'mirror://'."
+ (define (check-mirror-uri uri) ;XXX: could be optimized
+ (let loop ((mirrors %mirrors))
+ (match mirrors
+ (()
+ #f)
+ (((mirror-id mirror-urls ...) rest ...)
+ (match (find (cut string-prefix? <> uri) mirror-urls)
+ (#f
+ (loop rest))
+ (prefix
+ (make-warning package
+ (G_ "URL should be \
+'mirror://~a/~a'")
+ (list mirror-id
+ (string-drop uri (string-length prefix)))
+ #:field 'source)))))))
+
+ (let ((origin (package-source package)))
+ (if (and (origin? origin)
+ (eqv? (origin-method origin) url-fetch))
+ (let ((uris (origin-uris origin)))
+ (filter-map check-mirror-uri uris))
+ '())))
+
+(define* (check-github-url package #:key (timeout 3))
+ "Check whether PACKAGE uses source URLs that redirect to GitHub."
+ (define (follow-redirect url)
+ (let* ((uri (string->uri url))
+ (port (guix:open-connection-for-uri uri #:timeout timeout))
+ (response (http-head uri #:port port)))
+ (close-port port)
+ (case (response-code response)
+ ((301 302)
+ (uri->string (assoc-ref (response-headers response) 'location)))
+ (else #f))))
+
+ (define (follow-redirects-to-github uri)
+ (cond
+ ((string-prefix? "https://github.com/" uri) uri)
+ ((string-prefix? "http" uri)
+ (and=> (follow-redirect uri) follow-redirects-to-github))
+ ;; Do not attempt to follow redirects on URIs other than http and https
+ ;; (such as mirror, file)
+ (else #f)))
+
+ (let ((origin (package-source package)))
+ (if (and (origin? origin)
+ (eqv? (origin-method origin) url-fetch))
+ (filter-map
+ (lambda (uri)
+ (and=> (follow-redirects-to-github uri)
+ (lambda (github-uri)
+ (if (string=? github-uri uri)
+ #f
+ (make-warning
+ package
+ (G_ "URL should be '~a'")
+ (list github-uri)
+ #:field 'source)))))
+ (origin-uris origin))
+ '())))
+
+(define (check-derivation package)
+ "Emit a warning if we fail to compile PACKAGE to a derivation."
+ (define (try system)
+ (catch #t
+ (lambda ()
+ (guard (c ((store-protocol-error? c)
+ (make-warning package
+ (G_ "failed to create ~a derivation: ~a")
+ (list system
+ (store-protocol-error-message c))))
+ ((message-condition? c)
+ (make-warning package
+ (G_ "failed to create ~a derivation: ~a")
+ (list system
+ (condition-message c)))))
+ (with-store store
+ ;; Disable grafts since it can entail rebuilds.
+ (parameterize ((%graft? #f))
+ (package-derivation store package system #:graft? #f)
+
+ ;; If there's a replacement, make sure we can compute its
+ ;; derivation.
+ (match (package-replacement package)
+ (#f #t)
+ (replacement
+ (package-derivation store replacement system
+ #:graft? #f)))))))
+ (lambda args
+ (make-warning package
+ (G_ "failed to create ~a derivation: ~s")
+ (list system args)))))
+
+ (filter lint-warning?
+ (map try (package-supported-systems package))))
+
+(define (check-license package)
+ "Warn about type errors of the 'license' field of PACKAGE."
+ (match (package-license package)
+ ((or (? license?)
+ ((? license?) ...))
+ '())
+ (x
+ (list
+ (make-warning package (G_ "invalid license field")
+ #:field 'license)))))
+
+(define (call-with-networking-fail-safe message error-value proc)
+ "Call PROC catching any network-related errors. Upon a networking error,
+display a message including MESSAGE and return ERROR-VALUE."
+ (guard (c ((http-get-error? c)
+ (warning (G_ "~a: HTTP GET error for ~a: ~a (~s)~%")
+ message
+ (uri->string (http-get-error-uri c))
+ (http-get-error-code c)
+ (http-get-error-reason c))
+ error-value))
+ (catch #t
+ proc
+ (match-lambda*
+ (('getaddrinfo-error errcode)
+ (warning (G_ "~a: host lookup failure: ~a~%")
+ message
+ (gai-strerror errcode))
+ error-value)
+ (('tls-certificate-error args ...)
+ (warning (G_ "~a: TLS certificate error: ~a")
+ message
+ (tls-certificate-error-string args))
+ error-value)
+ (args
+ (apply throw args))))))
+
+(define-syntax-rule (with-networking-fail-safe message error-value exp ...)
+ (call-with-networking-fail-safe message error-value
+ (lambda () exp ...)))
+
+(define (current-vulnerabilities*)
+ "Like 'current-vulnerabilities', but return the empty list upon networking
+or HTTP errors. This allows network-less operation and makes problems with
+the NIST server non-fatal."
+ (with-networking-fail-safe (G_ "while retrieving CVE vulnerabilities")
+ '()
+ (current-vulnerabilities)))
+
+(define package-vulnerabilities
+ (let ((lookup (delay (vulnerabilities->lookup-proc
+ (current-vulnerabilities*)))))
+ (lambda (package)
+ "Return a list of vulnerabilities affecting PACKAGE."
+ ;; First we retrieve the Common Platform Enumeration (CPE) name and
+ ;; version for PACKAGE, then we can pass them to LOOKUP.
+ (let ((name (or (assoc-ref (package-properties package)
+ 'cpe-name)
+ (package-name package)))
+ (version (or (assoc-ref (package-properties package)
+ 'cpe-version)
+ (package-version package))))
+ ((force lookup) name version)))))
+
+(define (check-vulnerabilities package)
+ "Check for known vulnerabilities for PACKAGE."
+ (let ((package (or (package-replacement package) package)))
+ (match (package-vulnerabilities package)
+ (()
+ '())
+ ((vulnerabilities ...)
+ (let* ((patched (package-patched-vulnerabilities package))
+ (known-safe (or (assq-ref (package-properties package)
+ 'lint-hidden-cve)
+ '()))
+ (unpatched (remove (lambda (vuln)
+ (let ((id (vulnerability-id vuln)))
+ (or (member id patched)
+ (member id known-safe))))
+ vulnerabilities)))
+ (if (null? unpatched)
+ '()
+ (list
+ (make-warning
+ package
+ (G_ "probably vulnerable to ~a")
+ (list (string-join (map vulnerability-id unpatched)
+ ", "))))))))))
+
+(define (check-for-updates package)
+ "Check if there is an update available for PACKAGE."
+ (match (with-networking-fail-safe
+ (G_ "while retrieving upstream info for '~a'")
+ (list (package-name package))
+ #f
+ (package-latest-release* package (force %updaters)))
+ ((? upstream-source? source)
+ (if (version>? (upstream-source-version source)
+ (package-version package))
+ (list
+ (make-warning package
+ (G_ "can be upgraded to ~a")
+ (list (upstream-source-version source))
+ #:field 'version))
+ '()))
+ (#f '()))) ; cannot find newer upstream release
+
+\f
+;;;
+;;; Source code formatting.
+;;;
+
+(define (report-tabulations package line line-number)
+ "Warn about tabulations found in LINE."
+ (match (string-index line #\tab)
+ (#f #t)
+ (index
+ (make-warning package
+ (G_ "tabulation on line ~a, column ~a")
+ (list line-number index)
+ #:location
+ (location (package-file package)
+ line-number
+ index)))))
+
+(define (report-trailing-white-space package line line-number)
+ "Warn about trailing white space in LINE."
+ (unless (or (string=? line (string-trim-right line))
+ (string=? line (string #\page)))
+ (make-warning package
+ (G_ "trailing white space on line ~a")
+ (list line-number)
+ #:location
+ (location (package-file package)
+ line-number
+ 0))))
+
+(define (report-long-line package line line-number)
+ "Emit a warning if LINE is too long."
+ ;; Note: We don't warn at 80 characters because sometimes hashes and URLs
+ ;; make it hard to fit within that limit and we want to avoid making too
+ ;; much noise.
+ (when (> (string-length line) 90)
+ (make-warning package
+ (G_ "line ~a is way too long (~a characters)")
+ (list line-number (string-length line))
+ #:location
+ (location (package-file package)
+ line-number
+ 0))))
+
+(define %hanging-paren-rx
+ (make-regexp "^[[:blank:]]*[()]+[[:blank:]]*$"))
+
+(define (report-lone-parentheses package line line-number)
+ "Emit a warning if LINE contains hanging parentheses."
+ (when (regexp-exec %hanging-paren-rx line)
+ (make-warning package
+ (G_ "parentheses feel lonely, \
+move to the previous or next line")
+ (list line-number)
+ #:location
+ (location (package-file package)
+ line-number
+ 0))))
+
+(define %formatting-reporters
+ ;; List of procedures that report formatting issues. These are not separate
+ ;; checkers because they would need to re-read the file.
+ (list report-tabulations
+ report-trailing-white-space
+ report-long-line
+ report-lone-parentheses))
+
+(define* (report-formatting-issues package file starting-line
+ #:key (reporters %formatting-reporters))
+ "Report white-space issues in FILE starting from STARTING-LINE, and report
+them for PACKAGE."
+ (define (sexp-last-line port)
+ ;; Return the last line of the sexp read from PORT or an estimate thereof.
+ (define &failure (list 'failure))
+
+ (let ((start (ftell port))
+ (start-line (port-line port))
+ (sexp (catch 'read-error
+ (lambda () (read port))
+ (const &failure))))
+ (let ((line (port-line port)))
+ (seek port start SEEK_SET)
+ (set-port-line! port start-line)
+ (if (eq? sexp &failure)
+ (+ start-line 60) ;conservative estimate
+ line))))
+
+ (call-with-input-file file
+ (lambda (port)
+ (let loop ((line-number 1)
+ (last-line #f)
+ (warnings '()))
+ (let ((line (read-line port)))
+ (if (or (eof-object? line)
+ (and last-line (> line-number last-line)))
+ warnings
+ (if (and (= line-number starting-line)
+ (not last-line))
+ (loop (+ 1 line-number)
+ (+ 1 (sexp-last-line port))
+ warnings)
+ (loop (+ 1 line-number)
+ last-line
+ (append
+ warnings
+ (if (< line-number starting-line)
+ '()
+ (filter
+ lint-warning?
+ (map (lambda (report)
+ (report package line line-number))
+ reporters))))))))))))
+
+(define (check-formatting package)
+ "Check the formatting of the source code of PACKAGE."
+ (let ((location (package-location package)))
+ (if location
+ (and=> (search-path %load-path (location-file location))
+ (lambda (file)
+ ;; Report issues starting from the line before the 'package'
+ ;; form, which usually contains the 'define' form.
+ (report-formatting-issues package file
+ (- (location-line location) 1))))
+ '())))
+
+\f
+;;;
+;;; List of checkers.
+;;;
+
+(define %checkers
+ (list
+ (lint-checker
+ (name 'description)
+ (description "Validate package descriptions")
+ (check check-description-style))
+ (lint-checker
+ (name 'gnu-description)
+ (description "Validate synopsis & description of GNU packages")
+ (check check-gnu-synopsis+description))
+ (lint-checker
+ (name 'inputs-should-be-native)
+ (description "Identify inputs that should be native inputs")
+ (check check-inputs-should-be-native))
+ (lint-checker
+ (name 'inputs-should-not-be-input)
+ (description "Identify inputs that shouldn't be inputs at all")
+ (check check-inputs-should-not-be-an-input-at-all))
+ (lint-checker
+ (name 'patch-file-names)
+ (description "Validate file names and availability of patches")
+ (check check-patch-file-names))
+ (lint-checker
+ (name 'home-page)
+ (description "Validate home-page URLs")
+ (check check-home-page))
+ (lint-checker
+ (name 'license)
+ ;; TRANSLATORS: <license> is the name of a data type and must not be
+ ;; translated.
+ (description "Make sure the 'license' field is a <license> \
+or a list thereof")
+ (check check-license))
+ (lint-checker
+ (name 'source)
+ (description "Validate source URLs")
+ (check check-source))
+ (lint-checker
+ (name 'mirror-url)
+ (description "Suggest 'mirror://' URLs")
+ (check check-mirror-url))
+ (lint-checker
+ (name 'github-url)
+ (description "Suggest GitHub URLs")
+ (check check-github-url))
+ (lint-checker
+ (name 'source-file-name)
+ (description "Validate file names of sources")
+ (check check-source-file-name))
+ (lint-checker
+ (name 'source-unstable-tarball)
+ (description "Check for autogenerated tarballs")
+ (check check-source-unstable-tarball))
+ (lint-checker
+ (name 'derivation)
+ (description "Report failure to compile a package to a derivation")
+ (check check-derivation))
+ (lint-checker
+ (name 'synopsis)
+ (description "Validate package synopses")
+ (check check-synopsis-style))
+ (lint-checker
+ (name 'cve)
+ (description "Check the Common Vulnerabilities and Exposures\
+ (CVE) database")
+ (check check-vulnerabilities))
+ (lint-checker
+ (name 'refresh)
+ (description "Check the package for new upstream releases")
+ (check check-for-updates))
+ (lint-checker
+ (name 'formatting)
+ (description "Look for formatting issues in the source")
+ (check check-formatting))))
diff --git a/guix/scripts/lint.scm b/guix/scripts/lint.scm
index 4eb7e0e200..8a8ffc8f28 100644
--- a/guix/scripts/lint.scm
+++ b/guix/scripts/lint.scm
@@ -26,1223 +26,17 @@
;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
(define-module (guix scripts lint)
- #:use-module ((guix store) #:hide (close-connection))
- #:use-module (guix base32)
- #:use-module (guix download)
- #:use-module (guix ftp-client)
- #:use-module (guix http-client)
#:use-module (guix packages)
- #:use-module (guix licenses)
- #:use-module (guix records)
- #:use-module (guix grafts)
+ #:use-module (guix lint)
#:use-module (guix ui)
- #:use-module (guix upstream)
- #:use-module (guix utils)
- #:use-module (guix memoization)
#:use-module (guix scripts)
- #:use-module (guix gnu-maintenance)
- #:use-module (guix monads)
- #:use-module (guix cve)
#:use-module (gnu packages)
#:use-module (ice-9 match)
- #:use-module (ice-9 regex)
#:use-module (ice-9 format)
- #:use-module (web client)
- #:use-module (web uri)
- #:use-module ((guix build download)
- #:select (maybe-expand-mirrors
- (open-connection-for-uri
- . guix:open-connection-for-uri)
- close-connection))
- #:use-module (web request)
- #:use-module (web response)
#:use-module (srfi srfi-1)
- #:use-module (srfi srfi-6) ;Unicode string ports
- #:use-module (srfi srfi-9)
- #:use-module (srfi srfi-11)
- #:use-module (srfi srfi-26)
- #:use-module (srfi srfi-34)
- #:use-module (srfi srfi-35)
#:use-module (srfi srfi-37)
- #:use-module (ice-9 rdelim)
#:export (guix-lint
- check-description-style
- check-inputs-should-be-native
- check-inputs-should-not-be-an-input-at-all
- check-patch-file-names
- check-synopsis-style
- check-derivation
- check-home-page
- check-source
- check-source-file-name
- check-source-unstable-tarball
- check-mirror-url
- check-github-url
- check-license
- check-vulnerabilities
- check-for-updates
- check-formatting
- run-checkers
-
- lint-warning
- lint-warning?
- lint-warning-package
- lint-warning-message
- lint-warning-message-text
- lint-warning-message-data
- lint-warning-location
-
- %checkers
- lint-checker
- lint-checker?
- lint-checker-name
- lint-checker-description
- lint-checker-check))
-
-\f
-;;;
-;;; Warnings
-;;;
-
-(define-record-type* <lint-warning>
- lint-warning make-lint-warning
- lint-warning?
- (package lint-warning-package)
- (message-text lint-warning-message-text)
- (message-data lint-warning-message-data
- (default '()))
- (location lint-warning-location
- (default #f)))
-
-(define (lint-warning-message warning)
- (apply format #f
- (G_ (lint-warning-message-text warning))
- (lint-warning-message-data warning)))
-
-(define (package-file package)
- (location-file
- (package-location package)))
-
-(define* (%make-warning package message-text
- #:optional (message-data '())
- #:key field location)
- (make-lint-warning
- package
- message-text
- message-data
- (or location
- (package-field-location package field)
- (package-location package))))
-
-(define-syntax make-warning
- (syntax-rules (G_)
- ((_ package (G_ message) rest ...)
- (%make-warning package message rest ...))))
-
-(define (emit-warnings warnings)
- ;; 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
- ;; provided MESSAGE.
- (for-each
- (match-lambda
- (($ <lint-warning> package message-text message-data loc)
- (format (guix-warning-port) "~a: ~a@~a: ~a~%"
- (location->string loc)
- (package-name package) (package-version package)
- (apply format #f (G_ message-text) message-data))))
- warnings))
-
-\f
-;;;
-;;; Checkers
-;;;
-
-(define-record-type* <lint-checker>
- lint-checker make-lint-checker
- lint-checker?
- ;; TODO: add a 'certainty' field that shows how confident we are in the
- ;; checker. Then allow users to only run checkers that have a certain
- ;; 'certainty' level.
- (name lint-checker-name)
- (description lint-checker-description)
- (check lint-checker-check))
-
-(define (list-checkers-and-exit)
- ;; Print information about all available checkers and exit.
- (format #t (G_ "Available checkers:~%"))
- (for-each (lambda (checker)
- (format #t "- ~a: ~a~%"
- (lint-checker-name checker)
- (G_ (lint-checker-description checker))))
- %checkers)
- (exit 0))
-
-(define (properly-starts-sentence? s)
- (string-match "^[(\"'`[:upper:][:digit:]]" s))
-
-(define (starts-with-abbreviation? s)
- "Return #t if S starts with what looks like an abbreviation or acronym."
- (string-match "^[A-Z][A-Z0-9]+\\>" s))
-
-(define %quoted-identifier-rx
- ;; A quoted identifier, like 'this'.
- (make-regexp "['`][[:graph:]]+'"))
-
-(define (check-description-style package)
- ;; Emit a warning if stylistic issues are found in the description of PACKAGE.
- (define (check-not-empty description)
- (if (string-null? description)
- (list
- (make-warning package
- (G_ "description should not be empty")
- #:field 'description))
- '()))
-
- (define (check-texinfo-markup description)
- "Check that DESCRIPTION can be parsed as a Texinfo fragment. If the
-markup is valid return a plain-text version of DESCRIPTION, otherwise #f."
- (catch #t
- (lambda () (texi->plain-text description))
- (lambda (keys . args)
- (make-warning package
- (G_ "Texinfo markup in description is invalid")
- #:field 'description))))
-
- (define (check-trademarks description)
- "Check that DESCRIPTION does not contain '™' or '®' characters. See
-http://www.gnu.org/prep/standards/html_node/Trademarks.html."
- (match (string-index description (char-set #\™ #\®))
- ((and (? number?) index)
- (list
- (make-warning package
- (G_ "description should not contain ~
-trademark sign '~a' at ~d")
- (list (string-ref description index) index)
- #:field 'description)))
- (else '())))
-
- (define (check-quotes description)
- "Check whether DESCRIPTION contains single quotes and suggest @code."
- (if (regexp-exec %quoted-identifier-rx description)
- (list
- (make-warning package
- ;; TRANSLATORS: '@code' is Texinfo markup and must be kept
- ;; as is.
- (G_ "use @code or similar ornament instead of quotes")
- #:field 'description))
- '()))
-
- (define (check-proper-start description)
- (if (or (string-null? description)
- (properly-starts-sentence? description)
- (string-prefix-ci? (package-name package) description))
- '()
- (list
- (make-warning
- package
- (G_ "description should start with an upper-case letter or digit")
- #:field 'description))))
-
- (define (check-end-of-sentence-space description)
- "Check that an end-of-sentence period is followed by two spaces."
- (let ((infractions
- (reverse (fold-matches
- "\\. [A-Z]" description '()
- (lambda (m r)
- ;; Filter out matches of common abbreviations.
- (if (find (lambda (s)
- (string-suffix-ci? s (match:prefix m)))
- '("i.e" "e.g" "a.k.a" "resp"))
- r (cons (match:start m) r)))))))
- (if (null? infractions)
- '()
- (list
- (make-warning package
- (G_ "sentences in description should be followed ~
-by two spaces; possible infraction~p at ~{~a~^, ~}")
- (list (length infractions)
- infractions)
- #:field 'description)))))
-
- (let ((description (package-description package)))
- (if (string? description)
- (append
- (check-not-empty description)
- (check-quotes description)
- (check-trademarks description)
- ;; Use raw description for this because Texinfo rendering
- ;; automatically fixes end of sentence space.
- (check-end-of-sentence-space description)
- (match (check-texinfo-markup description)
- ((and warning (? lint-warning?)) (list warning))
- (plain-description
- (check-proper-start plain-description))))
- (list
- (make-warning package
- (G_ "invalid description: ~s")
- (list description)
- #:field 'description)))))
-
-(define (package-input-intersection inputs-to-check input-names)
- "Return the intersection between INPUTS-TO-CHECK, the list of input tuples
-of a package, and INPUT-NAMES, a list of package specifications such as
-\"glib:bin\"."
- (match inputs-to-check
- (((labels packages . outputs) ...)
- (filter-map (lambda (package output)
- (and (package? package)
- (let ((input (string-append
- (package-name package)
- (if (> (length output) 0)
- (string-append ":" (car output))
- ""))))
- (and (member input input-names)
- input))))
- packages outputs))))
-
-(define (check-inputs-should-be-native package)
- ;; Emit a warning if some inputs of PACKAGE are likely to belong to its
- ;; native inputs.
- (let ((inputs (package-inputs package))
- (input-names
- '("pkg-config"
- "cmake"
- "extra-cmake-modules"
- "glib:bin"
- "intltool"
- "itstool"
- "qttools"
- "python-coverage" "python2-coverage"
- "python-cython" "python2-cython"
- "python-docutils" "python2-docutils"
- "python-mock" "python2-mock"
- "python-nose" "python2-nose"
- "python-pbr" "python2-pbr"
- "python-pytest" "python2-pytest"
- "python-pytest-cov" "python2-pytest-cov"
- "python-setuptools-scm" "python2-setuptools-scm"
- "python-sphinx" "python2-sphinx")))
- (map (lambda (input)
- (make-warning
- package
- (G_ "'~a' should probably be a native input")
- (list input)
- #:field 'inputs))
- (package-input-intersection inputs input-names))))
-
-(define (check-inputs-should-not-be-an-input-at-all package)
- ;; Emit a warning if some inputs of PACKAGE are likely to should not be
- ;; an input at all.
- (let ((input-names '("python-setuptools"
- "python2-setuptools"
- "python-pip"
- "python2-pip")))
- (map (lambda (input)
- (make-warning
- package
- (G_ "'~a' should probably not be an input at all")
- (list input)
- #:field 'inputs))
- (package-input-intersection (package-direct-inputs package)
- input-names))))
-
-(define (package-name-regexp package)
- "Return a regexp that matches PACKAGE's name as a word at the beginning of a
-line."
- (make-regexp (string-append "^" (regexp-quote (package-name package))
- "\\>")
- regexp/icase))
-
-(define (check-synopsis-style package)
- ;; Emit a warning if stylistic issues are found in the synopsis of PACKAGE.
- (define (check-final-period synopsis)
- ;; Synopsis should not end with a period, except for some special cases.
- (if (and (string-suffix? "." synopsis)
- (not (string-suffix? "etc." synopsis)))
- (list
- (make-warning package
- (G_ "no period allowed at the end of the synopsis")
- #:field 'synopsis))
- '()))
-
- (define check-start-article
- ;; 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>.
- (if (false-if-exception (gnu-package? package))
- (const '())
- (lambda (synopsis)
- (if (or (string-prefix-ci? "A " synopsis)
- (string-prefix-ci? "An " synopsis))
- (list
- (make-warning package
- (G_ "no article allowed at the beginning of \
-the synopsis")
- #:field 'synopsis))
- '()))))
-
- (define (check-synopsis-length synopsis)
- (if (>= (string-length synopsis) 80)
- (list
- (make-warning package
- (G_ "synopsis should be less than 80 characters long")
- #:field 'synopsis))
- '()))
-
- (define (check-proper-start synopsis)
- (if (properly-starts-sentence? synopsis)
- '()
- (list
- (make-warning package
- (G_ "synopsis should start with an upper-case letter or digit")
- #:field 'synopsis))))
-
- (define (check-start-with-package-name synopsis)
- (if (and (regexp-exec (package-name-regexp package) synopsis)
- (not (starts-with-abbreviation? synopsis)))
- (list
- (make-warning package
- (G_ "synopsis should not start with the package name")
- #:field 'synopsis))
- '()))
-
- (define (check-texinfo-markup synopsis)
- "Check that SYNOPSIS can be parsed as a Texinfo fragment. If the
-markup is valid return a plain-text version of SYNOPSIS, otherwise #f."
- (catch #t
- (lambda ()
- (texi->plain-text synopsis)
- '())
- (lambda (keys . args)
- (list
- (make-warning package
- (G_ "Texinfo markup in synopsis is invalid")
- #:field 'synopsis)))))
-
- (define checks
- (list check-proper-start
- check-final-period
- check-start-article
- check-start-with-package-name
- check-synopsis-length
- check-texinfo-markup))
-
- (match (package-synopsis package)
- (""
- (list
- (make-warning package
- (G_ "synopsis should not be empty")
- #:field 'synopsis)))
- ((? string? synopsis)
- (append-map
- (lambda (proc)
- (proc synopsis))
- checks))
- (invalid
- (list
- (make-warning package
- (G_ "invalid synopsis: ~s")
- (list invalid)
- #:field 'synopsis)))))
-
-(define* (probe-uri uri #:key timeout)
- "Probe URI, a URI object, and return two values: a symbol denoting the
-probing status, such as 'http-response' when we managed to get an HTTP
-response from URI, and additional details, such as the actual HTTP response.
-
-TIMEOUT is the maximum number of seconds (possibly an inexact number) to wait
-for connections to complete; when TIMEOUT is #f, wait as long as needed."
- (define headers
- '((User-Agent . "GNU Guile")
- (Accept . "*/*")))
-
- (let loop ((uri uri)
- (visited '()))
- (match (uri-scheme uri)
- ((or 'http 'https)
- (catch #t
- (lambda ()
- (let ((port (guix:open-connection-for-uri
- uri #:timeout timeout))
- (request (build-request uri #:headers headers)))
- (define response
- (dynamic-wind
- (const #f)
- (lambda ()
- (write-request request port)
- (force-output port)
- (read-response port))
- (lambda ()
- (close-connection port))))
-
- (case (response-code response)
- ((302 ; found (redirection)
- 303 ; see other
- 307 ; temporary redirection
- 308) ; permanent redirection
- (let ((location (response-location response)))
- (if (or (not location) (member location visited))
- (values 'http-response response)
- (loop location (cons location visited))))) ;follow the redirect
- ((301) ; moved permanently
- (let ((location (response-location response)))
- ;; Return RESPONSE, unless the final response as we follow
- ;; redirects is not 200.
- (if location
- (let-values (((status response2)
- (loop location (cons location visited))))
- (case status
- ((http-response)
- (values 'http-response
- (if (= 200 (response-code response2))
- response
- response2)))
- (else
- (values status response2))))
- (values 'http-response response)))) ;invalid redirect
- (else
- (values 'http-response response)))))
- (lambda (key . args)
- (case key
- ((bad-header bad-header-component)
- ;; This can happen if the server returns an invalid HTTP header,
- ;; as is the case with the 'Date' header at sqlite.org.
- (values 'invalid-http-response #f))
- ((getaddrinfo-error system-error
- gnutls-error tls-certificate-error)
- (values key args))
- (else
- (apply throw key args))))))
- ('ftp
- (catch #t
- (lambda ()
- (let ((conn (ftp-open (uri-host uri) #:timeout timeout)))
- (define response
- (dynamic-wind
- (const #f)
- (lambda ()
- (ftp-chdir conn (dirname (uri-path uri)))
- (ftp-size conn (basename (uri-path uri))))
- (lambda ()
- (ftp-close conn))))
- (values 'ftp-response '(ok))))
- (lambda (key . args)
- (case key
- ((ftp-error)
- (values 'ftp-response `(error ,@args)))
- ((getaddrinfo-error system-error gnutls-error)
- (values key args))
- (else
- (apply throw key args))))))
- (_
- (values 'unknown-protocol #f)))))
-
-(define (tls-certificate-error-string args)
- "Return a string explaining the 'tls-certificate-error' arguments ARGS."
- (call-with-output-string
- (lambda (port)
- (print-exception port #f
- 'tls-certificate-error args))))
-
-(define (validate-uri uri package field)
- "Return #t if the given URI can be reached, otherwise return a warning for
-PACKAGE mentionning the FIELD."
- (let-values (((status argument)
- (probe-uri uri #:timeout 3))) ;wait at most 3 seconds
- (case status
- ((http-response)
- (cond ((= 200 (response-code argument))
- (match (response-content-length argument)
- ((? number? length)
- ;; As of July 2016, SourceForge returns 200 (instead of 404)
- ;; with a small HTML page upon failure. Attempt to detect
- ;; such malicious behavior.
- (or (> length 1000)
- (make-warning package
- (G_ "URI ~a returned \
-suspiciously small file (~a bytes)")
- (list (uri->string uri)
- length)
- #:field field)))
- (_ #t)))
- ((= 301 (response-code argument))
- (if (response-location argument)
- (make-warning package
- (G_ "permanent redirect from ~a to ~a")
- (list (uri->string uri)
- (uri->string
- (response-location argument)))
- #:field field)
- (make-warning package
- (G_ "invalid permanent redirect \
-from ~a")
- (list (uri->string uri))
- #:field field)))
- (else
- (make-warning package
- (G_ "URI ~a not reachable: ~a (~s)")
- (list (uri->string uri)
- (response-code argument)
- (response-reason-phrase argument))
- #:field field))))
- ((ftp-response)
- (match argument
- (('ok) #t)
- (('error port command code message)
- (make-warning package
- (G_ "URI ~a not reachable: ~a (~s)")
- (list (uri->string uri)
- code (string-trim-both message))
- #:field field))))
- ((getaddrinfo-error)
- (make-warning package
- (G_ "URI ~a domain not found: ~a")
- (list (uri->string uri)
- (gai-strerror (car argument)))
- #:field field))
- ((system-error)
- (make-warning package
- (G_ "URI ~a unreachable: ~a")
- (list (uri->string uri)
- (strerror
- (system-error-errno
- (cons status argument))))
- #:field field))
- ((tls-certificate-error)
- (make-warning package
- (G_ "TLS certificate error: ~a")
- (list (tls-certificate-error-string argument))
- #:field field))
- ((invalid-http-response gnutls-error)
- ;; Probably a misbehaving server; ignore.
- #f)
- ((unknown-protocol) ;nothing we can do
- #f)
- (else
- (error "internal linter error" status)))))
-
-(define (check-home-page package)
- "Emit a warning if PACKAGE has an invalid 'home-page' field, or if that
-'home-page' is not reachable."
- (let ((uri (and=> (package-home-page package) string->uri)))
- (cond
- ((uri? uri)
- (match (validate-uri uri package 'home-page)
- ((and (? lint-warning? warning) warning)
- (list warning))
- (_ '())))
- ((not (package-home-page package))
- (if (or (string-contains (package-name package) "bootstrap")
- (string=? (package-name package) "ld-wrapper"))
- '()
- (list
- (make-warning package
- (G_ "invalid value for home page")
- #:field 'home-page))))
- (else
- (list
- (make-warning package
- (G_ "invalid home page URL: ~s")
- (list (package-home-page package))
- #:field 'home-page))))))
-
-(define %distro-directory
- (mlambda ()
- (dirname (search-path %load-path "gnu.scm"))))
-
-(define (check-patch-file-names package)
- "Emit a warning if the patches requires by PACKAGE are badly named or if the
-patch could not be found."
- (guard (c ((message-condition? c) ;raised by 'search-patch'
- (list
- ;; Use %make-warning, as condition-mesasge is already
- ;; translated.
- (%make-warning package (condition-message c)
- #:field 'patch-file-names))))
- (define patches
- (or (and=> (package-source package) origin-patches)
- '()))
-
- (append
- (if (every (match-lambda ;patch starts with package name?
- ((? string? patch)
- (and=> (string-contains (basename patch)
- (package-name package))
- zero?))
- (_ #f)) ;must be an <origin> or something like that.
- patches)
- '()
- (list
- (make-warning
- package
- (G_ "file names of patches should start with the package name")
- #:field 'patch-file-names)))
-
- ;; Check whether we're reaching tar's maximum file name length.
- (let ((prefix (string-length (%distro-directory)))
- (margin (string-length "guix-0.13.0-10-123456789/"))
- (max 99))
- (filter-map (match-lambda
- ((? string? patch)
- (if (> (+ margin (if (string-prefix? (%distro-directory)
- patch)
- (- (string-length patch) prefix)
- (string-length patch)))
- max)
- (make-warning
- package
- (G_ "~a: file name is too long")
- (list (basename patch))
- #:field 'patch-file-names)
- #f))
- (_ #f))
- patches)))))
-
-(define (escape-quotes str)
- "Replace any quote character in STR by an escaped quote character."
- (list->string
- (string-fold-right (lambda (chr result)
- (match chr
- (#\" (cons* #\\ #\"result))
- (_ (cons chr result))))
- '()
- str)))
-
-(define official-gnu-packages*
- (mlambda ()
- "A memoizing version of 'official-gnu-packages' that returns the empty
-list when something goes wrong, such as a networking issue."
- (let ((gnus (false-if-exception (official-gnu-packages))))
- (or gnus '()))))
-
-(define (check-gnu-synopsis+description package)
- "Make sure that, if PACKAGE is a GNU package, it uses the synopsis and
-descriptions maintained upstream."
- (match (find (lambda (descriptor)
- (string=? (gnu-package-name descriptor)
- (package-name package)))
- (official-gnu-packages*))
- (#f ;not a GNU package, so nothing to do
- '())
- (descriptor ;a genuine GNU package
- (append
- (let ((upstream (gnu-package-doc-summary descriptor))
- (downstream (package-synopsis package)))
- (if (and upstream
- (or (not (string? downstream))
- (not (string=? upstream downstream))))
- (list
- (make-warning package
- (G_ "proposed synopsis: ~s~%")
- (list upstream)
- #:field 'synopsis))
- '()))
-
- (let ((upstream (gnu-package-doc-description descriptor))
- (downstream (package-description package)))
- (if (and upstream
- (or (not (string? downstream))
- (not (string=? (fill-paragraph upstream 100)
- (fill-paragraph downstream 100)))))
- (list
- (make-warning
- package
- (G_ "proposed description:~% \"~a\"~%")
- (list (fill-paragraph (escape-quotes upstream) 77 7))
- #:field 'description))
- '()))))))
-
-(define (origin-uris origin)
- "Return the list of URIs (strings) for ORIGIN."
- (match (origin-uri origin)
- ((? string? uri)
- (list uri))
- ((uris ...)
- uris)))
-
-(define (check-source package)
- "Emit a warning if PACKAGE has an invalid 'source' field, or if that
-'source' is not reachable."
- (define (warnings-for-uris uris)
- (filter lint-warning?
- (map
- (lambda (uri)
- (validate-uri uri package 'source))
- (append-map (cut maybe-expand-mirrors <> %mirrors)
- uris))))
-
- (let ((origin (package-source package)))
- (if (and origin
- (eqv? (origin-method origin) url-fetch))
- (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.
- (if (eq? (length uris) (length warnings))
- ;; When everything fails, report all of WARNINGS, otherwise don't
- ;; report anything.
- ;;
- ;; XXX: Ideally we'd still allow warnings to be raised if *some*
- ;; URIs are unreachable, but distinguish that from the error case
- ;; where *all* the URIs are unreachable.
- (cons*
- (make-warning package
- (G_ "all the source URIs are unreachable:")
- #:field 'source)
- warnings)
- '()))
- '())))
-
-(define (check-source-file-name package)
- "Emit a warning if PACKAGE's origin has no meaningful file name."
- (define (origin-file-name-valid? origin)
- ;; Return #f if the source file name contains only a version or is #f;
- ;; indicates that the origin needs a 'file-name' field.
- (let ((file-name (origin-actual-file-name origin))
- (version (package-version package)))
- (and file-name
- ;; Common in many projects is for the filename to start
- ;; with a "v" followed by the version,
- ;; e.g. "v3.2.0.tar.gz".
- (not (string-match (string-append "^v?" version) file-name)))))
-
- (let ((origin (package-source package)))
- (if (or (not origin) (origin-file-name-valid? origin))
- '()
- (list
- (make-warning package
- (G_ "the source file name should contain the package name")
- #:field 'source)))))
-
-(define (check-source-unstable-tarball package)
- "Emit a warning if PACKAGE's source is an autogenerated tarball."
- (define (check-source-uri uri)
- (if (and (string=? (uri-host (string->uri uri)) "github.com")
- (match (split-and-decode-uri-path
- (uri-path (string->uri uri)))
- ((_ _ "archive" _ ...) #t)
- (_ #f)))
- (make-warning package
- (G_ "the source URI should not be an autogenerated tarball")
- #:field 'source)
- #f))
-
- (let ((origin (package-source package)))
- (if (and (origin? origin)
- (eqv? (origin-method origin) url-fetch))
- (filter-map check-source-uri
- (origin-uris origin))
- '())))
-
-(define (check-mirror-url package)
- "Check whether PACKAGE uses source URLs that should be 'mirror://'."
- (define (check-mirror-uri uri) ;XXX: could be optimized
- (let loop ((mirrors %mirrors))
- (match mirrors
- (()
- #f)
- (((mirror-id mirror-urls ...) rest ...)
- (match (find (cut string-prefix? <> uri) mirror-urls)
- (#f
- (loop rest))
- (prefix
- (make-warning package
- (G_ "URL should be \
-'mirror://~a/~a'")
- (list mirror-id
- (string-drop uri (string-length prefix)))
- #:field 'source)))))))
-
- (let ((origin (package-source package)))
- (if (and (origin? origin)
- (eqv? (origin-method origin) url-fetch))
- (let ((uris (origin-uris origin)))
- (filter-map check-mirror-uri uris))
- '())))
-
-(define* (check-github-url package #:key (timeout 3))
- "Check whether PACKAGE uses source URLs that redirect to GitHub."
- (define (follow-redirect url)
- (let* ((uri (string->uri url))
- (port (guix:open-connection-for-uri uri #:timeout timeout))
- (response (http-head uri #:port port)))
- (close-port port)
- (case (response-code response)
- ((301 302)
- (uri->string (assoc-ref (response-headers response) 'location)))
- (else #f))))
-
- (define (follow-redirects-to-github uri)
- (cond
- ((string-prefix? "https://github.com/" uri) uri)
- ((string-prefix? "http" uri)
- (and=> (follow-redirect uri) follow-redirects-to-github))
- ;; Do not attempt to follow redirects on URIs other than http and https
- ;; (such as mirror, file)
- (else #f)))
-
- (let ((origin (package-source package)))
- (if (and (origin? origin)
- (eqv? (origin-method origin) url-fetch))
- (filter-map
- (lambda (uri)
- (and=> (follow-redirects-to-github uri)
- (lambda (github-uri)
- (if (string=? github-uri uri)
- #f
- (make-warning
- package
- (G_ "URL should be '~a'")
- (list github-uri)
- #:field 'source)))))
- (origin-uris origin))
- '())))
-
-(define (check-derivation package)
- "Emit a warning if we fail to compile PACKAGE to a derivation."
- (define (try system)
- (catch #t
- (lambda ()
- (guard (c ((store-protocol-error? c)
- (make-warning package
- (G_ "failed to create ~a derivation: ~a")
- (list system
- (store-protocol-error-message c))))
- ((message-condition? c)
- (make-warning package
- (G_ "failed to create ~a derivation: ~a")
- (list system
- (condition-message c)))))
- (with-store store
- ;; Disable grafts since it can entail rebuilds.
- (parameterize ((%graft? #f))
- (package-derivation store package system #:graft? #f)
-
- ;; If there's a replacement, make sure we can compute its
- ;; derivation.
- (match (package-replacement package)
- (#f #t)
- (replacement
- (package-derivation store replacement system
- #:graft? #f)))))))
- (lambda args
- (make-warning package
- (G_ "failed to create ~a derivation: ~s")
- (list system args)))))
-
- (filter lint-warning?
- (map try (package-supported-systems package))))
-
-(define (check-license package)
- "Warn about type errors of the 'license' field of PACKAGE."
- (match (package-license package)
- ((or (? license?)
- ((? license?) ...))
- '())
- (x
- (list
- (make-warning package (G_ "invalid license field")
- #:field 'license)))))
-
-(define (call-with-networking-fail-safe message error-value proc)
- "Call PROC catching any network-related errors. Upon a networking error,
-display a message including MESSAGE and return ERROR-VALUE."
- (guard (c ((http-get-error? c)
- (warning (G_ "~a: HTTP GET error for ~a: ~a (~s)~%")
- message
- (uri->string (http-get-error-uri c))
- (http-get-error-code c)
- (http-get-error-reason c))
- error-value))
- (catch #t
- proc
- (match-lambda*
- (('getaddrinfo-error errcode)
- (warning (G_ "~a: host lookup failure: ~a~%")
- message
- (gai-strerror errcode))
- error-value)
- (('tls-certificate-error args ...)
- (warning (G_ "~a: TLS certificate error: ~a")
- message
- (tls-certificate-error-string args))
- error-value)
- (args
- (apply throw args))))))
-
-(define-syntax-rule (with-networking-fail-safe message error-value exp ...)
- (call-with-networking-fail-safe message error-value
- (lambda () exp ...)))
-
-(define (current-vulnerabilities*)
- "Like 'current-vulnerabilities', but return the empty list upon networking
-or HTTP errors. This allows network-less operation and makes problems with
-the NIST server non-fatal."
- (with-networking-fail-safe (G_ "while retrieving CVE vulnerabilities")
- '()
- (current-vulnerabilities)))
-
-(define package-vulnerabilities
- (let ((lookup (delay (vulnerabilities->lookup-proc
- (current-vulnerabilities*)))))
- (lambda (package)
- "Return a list of vulnerabilities affecting PACKAGE."
- ;; First we retrieve the Common Platform Enumeration (CPE) name and
- ;; version for PACKAGE, then we can pass them to LOOKUP.
- (let ((name (or (assoc-ref (package-properties package)
- 'cpe-name)
- (package-name package)))
- (version (or (assoc-ref (package-properties package)
- 'cpe-version)
- (package-version package))))
- ((force lookup) name version)))))
-
-(define (check-vulnerabilities package)
- "Check for known vulnerabilities for PACKAGE."
- (let ((package (or (package-replacement package) package)))
- (match (package-vulnerabilities package)
- (()
- '())
- ((vulnerabilities ...)
- (let* ((patched (package-patched-vulnerabilities package))
- (known-safe (or (assq-ref (package-properties package)
- 'lint-hidden-cve)
- '()))
- (unpatched (remove (lambda (vuln)
- (let ((id (vulnerability-id vuln)))
- (or (member id patched)
- (member id known-safe))))
- vulnerabilities)))
- (if (null? unpatched)
- '()
- (list
- (make-warning
- package
- (G_ "probably vulnerable to ~a")
- (list (string-join (map vulnerability-id unpatched)
- ", "))))))))))
-
-(define (check-for-updates package)
- "Check if there is an update available for PACKAGE."
- (match (with-networking-fail-safe
- (G_ "while retrieving upstream info for '~a'")
- (list (package-name package))
- #f
- (package-latest-release* package (force %updaters)))
- ((? upstream-source? source)
- (if (version>? (upstream-source-version source)
- (package-version package))
- (list
- (make-warning package
- (G_ "can be upgraded to ~a")
- (list (upstream-source-version source))
- #:field 'version))
- '()))
- (#f '()))) ; cannot find newer upstream release
-
-\f
-;;;
-;;; Source code formatting.
-;;;
-
-(define (report-tabulations package line line-number)
- "Warn about tabulations found in LINE."
- (match (string-index line #\tab)
- (#f #t)
- (index
- (make-warning package
- (G_ "tabulation on line ~a, column ~a")
- (list line-number index)
- #:location
- (location (package-file package)
- line-number
- index)))))
-
-(define (report-trailing-white-space package line line-number)
- "Warn about trailing white space in LINE."
- (unless (or (string=? line (string-trim-right line))
- (string=? line (string #\page)))
- (make-warning package
- (G_ "trailing white space on line ~a")
- (list line-number)
- #:location
- (location (package-file package)
- line-number
- 0))))
-
-(define (report-long-line package line line-number)
- "Emit a warning if LINE is too long."
- ;; Note: We don't warn at 80 characters because sometimes hashes and URLs
- ;; make it hard to fit within that limit and we want to avoid making too
- ;; much noise.
- (when (> (string-length line) 90)
- (make-warning package
- (G_ "line ~a is way too long (~a characters)")
- (list line-number (string-length line))
- #:location
- (location (package-file package)
- line-number
- 0))))
-
-(define %hanging-paren-rx
- (make-regexp "^[[:blank:]]*[()]+[[:blank:]]*$"))
-
-(define (report-lone-parentheses package line line-number)
- "Emit a warning if LINE contains hanging parentheses."
- (when (regexp-exec %hanging-paren-rx line)
- (make-warning package
- (G_ "parentheses feel lonely, \
-move to the previous or next line")
- (list line-number)
- #:location
- (location (package-file package)
- line-number
- 0))))
-
-(define %formatting-reporters
- ;; List of procedures that report formatting issues. These are not separate
- ;; checkers because they would need to re-read the file.
- (list report-tabulations
- report-trailing-white-space
- report-long-line
- report-lone-parentheses))
-
-(define* (report-formatting-issues package file starting-line
- #:key (reporters %formatting-reporters))
- "Report white-space issues in FILE starting from STARTING-LINE, and report
-them for PACKAGE."
- (define (sexp-last-line port)
- ;; Return the last line of the sexp read from PORT or an estimate thereof.
- (define &failure (list 'failure))
-
- (let ((start (ftell port))
- (start-line (port-line port))
- (sexp (catch 'read-error
- (lambda () (read port))
- (const &failure))))
- (let ((line (port-line port)))
- (seek port start SEEK_SET)
- (set-port-line! port start-line)
- (if (eq? sexp &failure)
- (+ start-line 60) ;conservative estimate
- line))))
-
- (call-with-input-file file
- (lambda (port)
- (let loop ((line-number 1)
- (last-line #f)
- (warnings '()))
- (let ((line (read-line port)))
- (if (or (eof-object? line)
- (and last-line (> line-number last-line)))
- warnings
- (if (and (= line-number starting-line)
- (not last-line))
- (loop (+ 1 line-number)
- (+ 1 (sexp-last-line port))
- warnings)
- (loop (+ 1 line-number)
- last-line
- (append
- warnings
- (if (< line-number starting-line)
- '()
- (filter
- lint-warning?
- (map (lambda (report)
- (report package line line-number))
- reporters))))))))))))
-
-(define (check-formatting package)
- "Check the formatting of the source code of PACKAGE."
- (let ((location (package-location package)))
- (if location
- (and=> (search-path %load-path (location-file location))
- (lambda (file)
- ;; Report issues starting from the line before the 'package'
- ;; form, which usually contains the 'define' form.
- (report-formatting-issues package file
- (- (location-line location) 1))))
- '())))
-
-\f
-;;;
-;;; List of checkers.
-;;;
-
-(define %checkers
- (list
- (lint-checker
- (name 'description)
- (description "Validate package descriptions")
- (check check-description-style))
- (lint-checker
- (name 'gnu-description)
- (description "Validate synopsis & description of GNU packages")
- (check check-gnu-synopsis+description))
- (lint-checker
- (name 'inputs-should-be-native)
- (description "Identify inputs that should be native inputs")
- (check check-inputs-should-be-native))
- (lint-checker
- (name 'inputs-should-not-be-input)
- (description "Identify inputs that shouldn't be inputs at all")
- (check check-inputs-should-not-be-an-input-at-all))
- (lint-checker
- (name 'patch-file-names)
- (description "Validate file names and availability of patches")
- (check check-patch-file-names))
- (lint-checker
- (name 'home-page)
- (description "Validate home-page URLs")
- (check check-home-page))
- (lint-checker
- (name 'license)
- ;; TRANSLATORS: <license> is the name of a data type and must not be
- ;; translated.
- (description "Make sure the 'license' field is a <license> \
-or a list thereof")
- (check check-license))
- (lint-checker
- (name 'source)
- (description "Validate source URLs")
- (check check-source))
- (lint-checker
- (name 'mirror-url)
- (description "Suggest 'mirror://' URLs")
- (check check-mirror-url))
- (lint-checker
- (name 'github-url)
- (description "Suggest GitHub URLs")
- (check check-github-url))
- (lint-checker
- (name 'source-file-name)
- (description "Validate file names of sources")
- (check check-source-file-name))
- (lint-checker
- (name 'source-unstable-tarball)
- (description "Check for autogenerated tarballs")
- (check check-source-unstable-tarball))
- (lint-checker
- (name 'derivation)
- (description "Report failure to compile a package to a derivation")
- (check check-derivation))
- (lint-checker
- (name 'synopsis)
- (description "Validate package synopses")
- (check check-synopsis-style))
- (lint-checker
- (name 'cve)
- (description "Check the Common Vulnerabilities and Exposures\
- (CVE) database")
- (check check-vulnerabilities))
- (lint-checker
- (name 'refresh)
- (description "Check the package for new upstream releases")
- (check check-for-updates))
- (lint-checker
- (name 'formatting)
- (description "Look for formatting issues in the source")
- (check check-formatting))))
+ run-checkers))
(define* (run-checkers package #:optional (checkers %checkers))
"Run the given CHECKERS on PACKAGE."
@@ -1260,6 +54,16 @@ or a list thereof")
(format (current-error-port) "\x1b[K")
(force-output (current-error-port)))))
+(define (list-checkers-and-exit)
+ ;; Print information about all available checkers and exit.
+ (format #t (G_ "Available checkers:~%"))
+ (for-each (lambda (checker)
+ (format #t "- ~a: ~a~%"
+ (lint-checker-name checker)
+ (G_ (lint-checker-description checker))))
+ %checkers)
+ (exit 0))
+
\f
;;;
;;; Command-line options.
diff --git a/tests/lint.scm b/tests/lint.scm
index d8b2ca54cd..59be061a99 100644
--- a/tests/lint.scm
+++ b/tests/lint.scm
@@ -33,7 +33,7 @@
#:use-module (guix git-download)
#:use-module (guix build-system gnu)
#:use-module (guix packages)
- #:use-module (guix scripts lint)
+ #:use-module (guix lint)
#:use-module (guix ui)
#:use-module (gnu packages)
#:use-module (gnu packages glib)
--
2.22.0
^ permalink raw reply related [flat|nested] 37+ messages in thread
* [bug#35790] [PATCH 2/2] lint: Separate checkers by dependence on the internet.
2019-07-02 19:25 ` [bug#35790] [PATCH 1/2] lint: Move the linting code to a different module Christopher Baines
@ 2019-07-02 19:25 ` Christopher Baines
2019-07-12 14:38 ` Ludovic Courtès
2019-07-12 14:36 ` [bug#35790] [PATCH 1/2] lint: Move the linting code to a different module Ludovic Courtès
1 sibling, 1 reply; 37+ messages in thread
From: Christopher Baines @ 2019-07-02 19:25 UTC (permalink / raw)
To: 35790
I think there are a couple of potential uses for this. It's somewhat a
separation in to what checkers are just checking the contents of the
repository (line length for example), and other checkers which are bringing in
external information which could change.
I'm thinking particularly, about treating network dependant checkers
differently when automatically running them, but this commit also adds a
--no-network flag to guix lint, which selects the checkers that don't access
the network, which could be useful if no network access is available.
* guix/lint.scm (%checkers): Rename to %all-checkers.
(%local-checkers, %network-dependant-checkers): New variables.
* guix/scripts/lint.scm (run-checkers): Make the checkers argument mandatory.
(list-checkers-and-exit): Handle the checkers as an argument.
(%options): Adjust for changes to %checkers, add a --no-network option, and
change how the --list-checkers option is handled.
(guix-lint): Adjust indentation, and update how the checkers are handled.
---
guix/lint.scm | 64 +++++++++++++++++++++++++------------------
guix/scripts/lint.scm | 49 ++++++++++++++++++++-------------
2 files changed, 67 insertions(+), 46 deletions(-)
diff --git a/guix/lint.scm b/guix/lint.scm
index f86e494be5..2cc0d34440 100644
--- a/guix/lint.scm
+++ b/guix/lint.scm
@@ -91,7 +91,10 @@
emit-warnings
- %checkers
+ %local-checkers
+ %network-dependant-checkers
+ %all-checkers
+
lint-checker
lint-checker?
lint-checker-name
@@ -1158,16 +1161,12 @@ them for PACKAGE."
;;; List of checkers.
;;;
-(define %checkers
+(define %local-checkers
(list
(lint-checker
(name 'description)
(description "Validate package descriptions")
(check check-description-style))
- (lint-checker
- (name 'gnu-description)
- (description "Validate synopsis & description of GNU packages")
- (check check-gnu-synopsis+description))
(lint-checker
(name 'inputs-should-be-native)
(description "Identify inputs that should be native inputs")
@@ -1176,14 +1175,6 @@ them for PACKAGE."
(name 'inputs-should-not-be-input)
(description "Identify inputs that shouldn't be inputs at all")
(check check-inputs-should-not-be-an-input-at-all))
- (lint-checker
- (name 'patch-file-names)
- (description "Validate file names and availability of patches")
- (check check-patch-file-names))
- (lint-checker
- (name 'home-page)
- (description "Validate home-page URLs")
- (check check-home-page))
(lint-checker
(name 'license)
;; TRANSLATORS: <license> is the name of a data type and must not be
@@ -1191,18 +1182,10 @@ them for PACKAGE."
(description "Make sure the 'license' field is a <license> \
or a list thereof")
(check check-license))
- (lint-checker
- (name 'source)
- (description "Validate source URLs")
- (check check-source))
(lint-checker
(name 'mirror-url)
(description "Suggest 'mirror://' URLs")
(check check-mirror-url))
- (lint-checker
- (name 'github-url)
- (description "Suggest GitHub URLs")
- (check check-github-url))
(lint-checker
(name 'source-file-name)
(description "Validate file names of sources")
@@ -1215,10 +1198,37 @@ or a list thereof")
(name 'derivation)
(description "Report failure to compile a package to a derivation")
(check check-derivation))
+ (lint-checker
+ (name 'patch-file-names)
+ (description "Validate file names and availability of patches")
+ (check check-patch-file-names))
+ (lint-checker
+ (name 'formatting)
+ (description "Look for formatting issues in the source")
+ (check check-formatting))))
+
+(define %network-dependant-checkers
+ (list
(lint-checker
(name 'synopsis)
(description "Validate package synopses")
(check check-synopsis-style))
+ (lint-checker
+ (name 'gnu-description)
+ (description "Validate synopsis & description of GNU packages")
+ (check check-gnu-synopsis+description))
+ (lint-checker
+ (name 'home-page)
+ (description "Validate home-page URLs")
+ (check check-home-page))
+ (lint-checker
+ (name 'source)
+ (description "Validate source URLs")
+ (check check-source))
+ (lint-checker
+ (name 'github-url)
+ (description "Suggest GitHub URLs")
+ (check check-github-url))
(lint-checker
(name 'cve)
(description "Check the Common Vulnerabilities and Exposures\
@@ -1227,8 +1237,8 @@ or a list thereof")
(lint-checker
(name 'refresh)
(description "Check the package for new upstream releases")
- (check check-for-updates))
- (lint-checker
- (name 'formatting)
- (description "Look for formatting issues in the source")
- (check check-formatting))))
+ (check check-for-updates))))
+
+(define %all-checkers
+ (append %local-checkers
+ %network-dependant-checkers))
diff --git a/guix/scripts/lint.scm b/guix/scripts/lint.scm
index 8a8ffc8f28..c2e022cf94 100644
--- a/guix/scripts/lint.scm
+++ b/guix/scripts/lint.scm
@@ -38,7 +38,7 @@
#:export (guix-lint
run-checkers))
-(define* (run-checkers package #:optional (checkers %checkers))
+(define (run-checkers package checkers)
"Run the given CHECKERS on PACKAGE."
(let ((tty? (isatty? (current-error-port))))
(for-each (lambda (checker)
@@ -54,14 +54,14 @@
(format (current-error-port) "\x1b[K")
(force-output (current-error-port)))))
-(define (list-checkers-and-exit)
+(define (list-checkers-and-exit checkers)
;; Print information about all available checkers and exit.
(format #t (G_ "Available checkers:~%"))
(for-each (lambda (checker)
(format #t "- ~a: ~a~%"
(lint-checker-name checker)
(G_ (lint-checker-description checker))))
- %checkers)
+ checkers)
(exit 0))
\f
@@ -97,26 +97,33 @@ run the checkers on all packages.\n"))
;; 'certainty'.
(list (option '(#\c "checkers") #t #f
(lambda (opt name arg result)
- (let ((names (map string->symbol (string-split arg #\,))))
+ (let ((names (map string->symbol (string-split arg #\,)))
+ (checker-names (map lint-checker-name %all-checkers)))
(for-each (lambda (c)
- (unless (memq c
- (map lint-checker-name
- %checkers))
+ (unless (memq c checker-names)
(leave (G_ "~a: invalid checker~%") c)))
names)
(alist-cons 'checkers
(filter (lambda (checker)
(member (lint-checker-name checker)
names))
- %checkers)
+ %all-checkers)
result))))
+ (option '(#\n "no-network") #f #f
+ (lambda (opt name arg result)
+ (alist-cons 'checkers
+ %local-checkers
+ (alist-delete 'checkers
+ result))))
(option '(#\h "help") #f #f
(lambda args
(show-help)
(exit 0)))
(option '(#\l "list-checkers") #f #f
- (lambda args
- (list-checkers-and-exit)))
+ (lambda (opt name arg result)
+ (alist-cons 'list?
+ #t
+ result)))
(option '(#\V "version") #f #f
(lambda args
(show-version-and-exit "guix lint")))))
@@ -134,13 +141,17 @@ run the checkers on all packages.\n"))
(let* ((opts (parse-options))
(args (filter-map (match-lambda
- (('argument . value)
- value)
- (_ #f))
+ (('argument . value)
+ value)
+ (_ #f))
(reverse opts)))
- (checkers (or (assoc-ref opts 'checkers) %checkers)))
- (if (null? args)
- (fold-packages (lambda (p r) (run-checkers p checkers)) '())
- (for-each (lambda (spec)
- (run-checkers (specification->package spec) checkers))
- args))))
+ (checkers (or (assoc-ref opts 'checkers) %all-checkers)))
+ (cond
+ ((assoc-ref opts 'list?)
+ (list-checkers-and-exit checkers))
+ ((null? args)
+ (fold-packages (lambda (p r) (run-checkers p checkers)) '()))
+ (else
+ (for-each (lambda (spec)
+ (run-checkers (specification->package spec) checkers))
+ args)))))
--
2.22.0
^ permalink raw reply related [flat|nested] 37+ messages in thread
* [bug#35790] [PATCH] scripts: lint: Handle warnings with a record type.
2019-07-01 12:32 ` Ludovic Courtès
2019-07-02 19:25 ` [bug#35790] [PATCH 1/2] lint: Move the linting code to a different module Christopher Baines
@ 2019-07-02 20:15 ` Christopher Baines
1 sibling, 0 replies; 37+ messages in thread
From: Christopher Baines @ 2019-07-02 20:15 UTC (permalink / raw)
To: Ludovic Courtès; +Cc: 35790
[-- Attachment #1: Type: text/plain, Size: 1525 bytes --]
Ludovic Courtès <ludo@gnu.org> writes:
> Hi!
>
> Christopher Baines <mail@cbaines.net> skribis:
>
>> Ludovic Courtès <ludo@gnu.org> writes:
>>
>>> Hi Chris,
>>>
>>> Christopher Baines <mail@cbaines.net> skribis:
>>>
>>>> Thanks, so if I set the bindtextdomain, things do indeed work
>>>> better. So, regarding these two patches, I've got the following things
>>>> on my mind...
>>>>
>>>> - As they change so many things, I'm not sure what to add for the GNU
>>>> changelog at the end of the commit message?
>>>
>>> I think you should try to write the commit log the usual way, by
>>> listing every changed entity. It’s a bit tedious, but it’s also a good
>>> way to review everything (and Magit makes it relatively easy.)
>>
>> Ok, I've now made an initial attempt at this, and sent some updated
>> patches.
>
> Perfect, thanks for taking the time to do it.
Great :)
> Time to push! :-)
Well... I'm happy to push these patches to master, but I've got some
more related changes in mind. It might be good to merge these all
together, to avoid churning up the codebase more than necessary.
I've sent another couple of patches, the first to move most of the
functionality from (guix scripts lint) to a new (guix lint) module.
The second patch then splits the checkers in to two groups, based on
whether they attempt to access the network.
This is still moving towards being able to easily lint all the packages
and store this information in the Guix Data Serivce.
[-- Attachment #2: signature.asc --]
[-- Type: application/pgp-signature, Size: 962 bytes --]
^ permalink raw reply [flat|nested] 37+ messages in thread
* [bug#35790] [PATCH 1/2] lint: Move the linting code to a different module.
2019-07-02 19:25 ` [bug#35790] [PATCH 1/2] lint: Move the linting code to a different module Christopher Baines
2019-07-02 19:25 ` [bug#35790] [PATCH 2/2] lint: Separate checkers by dependence on the internet Christopher Baines
@ 2019-07-12 14:36 ` Ludovic Courtès
2019-07-14 18:03 ` Christopher Baines
1 sibling, 1 reply; 37+ messages in thread
From: Ludovic Courtès @ 2019-07-12 14:36 UTC (permalink / raw)
To: Christopher Baines; +Cc: 35790
Hi,
I think this could have come as a subsequent patch, but regardless, this
is a welcome move.
Christopher Baines <mail@cbaines.net> skribis:
> 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.
For the final version, please write a change log.
> +(define-module (guix lint)
> + #:use-module ((guix store) #:hide (close-connection))
> + #:use-module (guix base32)
> + #:use-module (guix download)
> + #:use-module (guix ftp-client)
> + #:use-module (guix http-client)
> + #:use-module (guix packages)
> + #:use-module (guix licenses)
> + #:use-module (guix records)
> + #:use-module (guix grafts)
> + #:use-module (guix ui)
The principle that’s mostly followed for Guix modules is that they are
UI-independent: they might throw ‘&message’ error conditions, they might
even use (guix i18n), but they usually don’t depend on (guix ui).
The idea is separation of concerns: the actual UI implementation details
(TUI, GUI, etc.) remain separate from the API.
At first sight (guix ui) is not necessary here, and it’s enough to use
(guix i18n), isn’t it?
Last thing: please add this new file to po/guix/POTFILES.in.
Thanks for working on it!
Ludo’.
^ permalink raw reply [flat|nested] 37+ messages in thread
* [bug#35790] [PATCH 2/2] lint: Separate checkers by dependence on the internet.
2019-07-02 19:25 ` [bug#35790] [PATCH 2/2] lint: Separate checkers by dependence on the internet Christopher Baines
@ 2019-07-12 14:38 ` Ludovic Courtès
2019-07-14 18:17 ` Christopher Baines
0 siblings, 1 reply; 37+ messages in thread
From: Ludovic Courtès @ 2019-07-12 14:38 UTC (permalink / raw)
To: Christopher Baines; +Cc: 35790
Hi,
Christopher Baines <mail@cbaines.net> skribis:
> I think there are a couple of potential uses for this. It's somewhat a
> separation in to what checkers are just checking the contents of the
> repository (line length for example), and other checkers which are bringing in
> external information which could change.
>
> I'm thinking particularly, about treating network dependant checkers
> differently when automatically running them, but this commit also adds a
> --no-network flag to guix lint, which selects the checkers that don't access
> the network, which could be useful if no network access is available.
>
> * guix/lint.scm (%checkers): Rename to %all-checkers.
> (%local-checkers, %network-dependant-checkers): New variables.
> * guix/scripts/lint.scm (run-checkers): Make the checkers argument mandatory.
> (list-checkers-and-exit): Handle the checkers as an argument.
> (%options): Adjust for changes to %checkers, add a --no-network option, and
> change how the --list-checkers option is handled.
> (guix-lint): Adjust indentation, and update how the checkers are handled.
Nice.
> +(define %network-dependant-checkers
^
Shouldn’t it be “dependent” with an ‘e’?
Otherwise LGTM, thanks!
Ludo’.
^ permalink raw reply [flat|nested] 37+ messages in thread
* [bug#35790] [PATCH 1/2] lint: Move the linting code to a different module.
2019-07-12 14:36 ` [bug#35790] [PATCH 1/2] lint: Move the linting code to a different module Ludovic Courtès
@ 2019-07-14 18:03 ` Christopher Baines
2019-07-14 18:23 ` Christopher Baines
2019-07-15 9:20 ` Ludovic Courtès
0 siblings, 2 replies; 37+ messages in thread
From: Christopher Baines @ 2019-07-14 18:03 UTC (permalink / raw)
To: Ludovic Courtès; +Cc: 35790
[-- Attachment #1: Type: text/plain, Size: 1782 bytes --]
Ludovic Courtès <ludo@gnu.org> writes:
> Christopher Baines <mail@cbaines.net> skribis:
>
>> 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.
>
> For the final version, please write a change log.
Sure, any suggestions about how to write it? I wasn't sure whether to
list everything that had been moved from (guix scripts lint) to (guix
lint), or say that the file has moved, and list the things that have
been moved back.
>> +(define-module (guix lint)
>> + #:use-module ((guix store) #:hide (close-connection))
>> + #:use-module (guix base32)
>> + #:use-module (guix download)
>> + #:use-module (guix ftp-client)
>> + #:use-module (guix http-client)
>> + #:use-module (guix packages)
>> + #:use-module (guix licenses)
>> + #:use-module (guix records)
>> + #:use-module (guix grafts)
>> + #:use-module (guix ui)
>
> The principle that’s mostly followed for Guix modules is that they are
> UI-independent: they might throw ‘&message’ error conditions, they might
> even use (guix i18n), but they usually don’t depend on (guix ui).
>
> The idea is separation of concerns: the actual UI implementation details
> (TUI, GUI, etc.) remain separate from the API.
>
> At first sight (guix ui) is not necessary here, and it’s enough to use
> (guix i18n), isn’t it?
I do remember looking at this, but I think I got stuck. I've just had
another look though, and I think if I import (guix diagnostics) and
(guix i18n) modules, then (guix ui) isn't required.
> Last thing: please add this new file to po/guix/POTFILES.in.
>
> Thanks for working on it!
No problem, thanks for taking a look :)
[-- Attachment #2: signature.asc --]
[-- Type: application/pgp-signature, Size: 962 bytes --]
^ permalink raw reply [flat|nested] 37+ messages in thread
* [bug#35790] [PATCH 2/2] lint: Separate checkers by dependence on the internet.
2019-07-12 14:38 ` Ludovic Courtès
@ 2019-07-14 18:17 ` Christopher Baines
0 siblings, 0 replies; 37+ messages in thread
From: Christopher Baines @ 2019-07-14 18:17 UTC (permalink / raw)
To: Ludovic Courtès; +Cc: 35790
[-- Attachment #1: Type: text/plain, Size: 1510 bytes --]
Ludovic Courtès <ludo@gnu.org> writes:
> Hi,
>
> Christopher Baines <mail@cbaines.net> skribis:
>
>> I think there are a couple of potential uses for this. It's somewhat a
>> separation in to what checkers are just checking the contents of the
>> repository (line length for example), and other checkers which are bringing in
>> external information which could change.
>>
>> I'm thinking particularly, about treating network dependant checkers
>> differently when automatically running them, but this commit also adds a
>> --no-network flag to guix lint, which selects the checkers that don't access
>> the network, which could be useful if no network access is available.
>>
>> * guix/lint.scm (%checkers): Rename to %all-checkers.
>> (%local-checkers, %network-dependant-checkers): New variables.
>> * guix/scripts/lint.scm (run-checkers): Make the checkers argument mandatory.
>> (list-checkers-and-exit): Handle the checkers as an argument.
>> (%options): Adjust for changes to %checkers, add a --no-network option, and
>> change how the --list-checkers option is handled.
>> (guix-lint): Adjust indentation, and update how the checkers are handled.
>
> Nice.
>
>> +(define %network-dependant-checkers
> ^
> Shouldn’t it be “dependent” with an ‘e’?
I'm definitely not an authority on spelling, but yeah, it seems like
dependent is preferred as the adjective, especially in American English.
> Otherwise LGTM, thanks!
Great :)
[-- Attachment #2: signature.asc --]
[-- Type: application/pgp-signature, Size: 962 bytes --]
^ permalink raw reply [flat|nested] 37+ messages in thread
* [bug#35790] [PATCH 1/2] lint: Move the linting code to a different module.
2019-07-14 18:03 ` Christopher Baines
@ 2019-07-14 18:23 ` Christopher Baines
2019-07-15 9:20 ` Ludovic Courtès
1 sibling, 0 replies; 37+ messages in thread
From: Christopher Baines @ 2019-07-14 18:23 UTC (permalink / raw)
To: Ludovic Courtès; +Cc: 35790
[-- Attachment #1: Type: text/plain, Size: 1184 bytes --]
Christopher Baines <mail@cbaines.net> writes:
> Ludovic Courtès <ludo@gnu.org> writes:
>
>> Christopher Baines <mail@cbaines.net> skribis:
>>
>>> 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.
>>
>> For the final version, please write a change log.
>
> Sure, any suggestions about how to write it? I wasn't sure whether to
> list everything that had been moved from (guix scripts lint) to (guix
> lint), or say that the file has moved, and list the things that have
> been moved back.
Actually, now that I've run make, that's spotted some problems in some
checks.
guix/lint.scm:198:17: warning: possibly unbound variable `texi->plain-text'
guix/lint.scm:406:8: warning: possibly unbound variable `texi->plain-text'
guix/lint.scm:737:36: warning: possibly unbound variable `fill-paragraph'
guix/lint.scm:738:36: warning: possibly unbound variable `fill-paragraph'
guix/lint.scm:743:20: warning: possibly unbound variable `fill-paragraph'
I don't think these are as easy to solve, as these functions come from
(guix ui).
[-- Attachment #2: signature.asc --]
[-- Type: application/pgp-signature, Size: 962 bytes --]
^ permalink raw reply [flat|nested] 37+ messages in thread
* [bug#35790] [PATCH 1/2] lint: Move the linting code to a different module.
2019-07-14 18:03 ` Christopher Baines
2019-07-14 18:23 ` Christopher Baines
@ 2019-07-15 9:20 ` Ludovic Courtès
2019-07-15 19:45 ` [bug#35790] [PATCH 1/4] scripts: lint: Handle warnings with a record type Christopher Baines
2019-07-15 19:51 ` [bug#35790] [PATCH 1/2] lint: Move the linting code to a different module Christopher Baines
1 sibling, 2 replies; 37+ messages in thread
From: Ludovic Courtès @ 2019-07-15 9:20 UTC (permalink / raw)
To: Christopher Baines; +Cc: 35790
Hi Chris!
Christopher Baines <mail@cbaines.net> skribis:
> Ludovic Courtès <ludo@gnu.org> writes:
>
>> Christopher Baines <mail@cbaines.net> skribis:
>>
>>> 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.
>>
>> For the final version, please write a change log.
>
> Sure, any suggestions about how to write it? I wasn't sure whether to
> list everything that had been moved from (guix scripts lint) to (guix
> lint), or say that the file has moved, and list the things that have
> been moved back.
Maybe something like:
* guix/scripts/lint.scm (check-foo, check-bar): Move to…
* guix/lint.scm: … here.
and also mention things that go beyond simply moving things around (if
applicable).
But again, don’t spend a whole day on this, it’s mostly so the future us
have an easily searchable log.
> Actually, now that I've run make, that's spotted some problems in some
> checks.
>
> guix/lint.scm:198:17: warning: possibly unbound variable `texi->plain-text'
> guix/lint.scm:406:8: warning: possibly unbound variable `texi->plain-text'
> guix/lint.scm:737:36: warning: possibly unbound variable `fill-paragraph'
> guix/lint.scm:738:36: warning: possibly unbound variable `fill-paragraph'
> guix/lint.scm:743:20: warning: possibly unbound variable `fill-paragraph'
>
> I don't think these are as easy to solve, as these functions come from
> (guix ui).
Ah yes, indeed.
In that case it’s OK because (guix ui) is used as part of the linter’s
job. Perhaps for clarity we should write:
#:use-module ((guix ui) #:select (texi->plain-text fill-paragraph))
Uses of the ‘warning’ procedure or similar UI functionality should be
left to (guix scripts lint), though.
Thanks,
Ludo’.
^ permalink raw reply [flat|nested] 37+ messages in thread
* [bug#35790] [PATCH 1/4] scripts: lint: Handle warnings with a record type.
2019-07-15 9:20 ` Ludovic Courtès
@ 2019-07-15 19:45 ` Christopher Baines
2019-07-15 19:45 ` [bug#35790] [PATCH 2/4] scripts: lint: Separate the message warning text and data Christopher Baines
` (2 more replies)
2019-07-15 19:51 ` [bug#35790] [PATCH 1/2] lint: Move the linting code to a different module Christopher Baines
1 sibling, 3 replies; 37+ messages in thread
From: Christopher Baines @ 2019-07-15 19:45 UTC (permalink / raw)
To: 35790
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.
---
guix/scripts/lint.scm | 757 +++++++++++----------
tests/lint.scm | 1453 +++++++++++++++++++----------------------
2 files changed, 1102 insertions(+), 1108 deletions(-)
diff --git a/guix/scripts/lint.scm b/guix/scripts/lint.scm
index dc338a1d7b..1b08068669 100644
--- a/guix/scripts/lint.scm
+++ b/guix/scripts/lint.scm
@@ -84,6 +84,12 @@
check-formatting
run-checkers
+ lint-warning
+ lint-warning?
+ lint-warning-package
+ lint-warning-message
+ lint-warning-location
+
%checkers
lint-checker
lint-checker?
@@ -93,42 +99,48 @@
\f
;;;
-;;; 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
;; given, the location of PACKAGE otherwise, the full name of PACKAGE and the
;; provided MESSAGE.
- (let ((loc (or (package-field-location package field)
- (package-location package))))
- (format (guix-warning-port) "~a: ~a@~a: ~a~%"
- (location->string loc)
- (package-name package) (package-version package)
- message)))
-
-(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 ...)))
+ (for-each
+ (match-lambda
+ (($ <lint-warning> package message loc)
+ (format (guix-warning-port) "~a: ~a@~a: ~a~%"
+ (location->string loc)
+ (package-name package) (package-version package)
+ message)))
+ warnings))
\f
;;;
;;; Checkers
;;;
+
(define-record-type* <lint-checker>
lint-checker make-lint-checker
lint-checker?
@@ -163,10 +175,12 @@ monad."
(define (check-description-style package)
;; Emit a warning if stylistic issues are found in the description of PACKAGE.
(define (check-not-empty description)
- (when (string-null? description)
- (emit-warning package
- (G_ "description should not be empty")
- 'description)))
+ (if (string-null? description)
+ (list
+ (make-warning package
+ (G_ "description should not be empty")
+ #:field 'description))
+ '()))
(define (check-texinfo-markup description)
"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
(lambda () (texi->plain-text description))
(lambda (keys . args)
- (emit-warning package
+ (make-warning package
(G_ "Texinfo markup in description is invalid")
- 'description)
- #f)))
+ #:field 'description))))
(define (check-trademarks description)
"Check that DESCRIPTION does not contain '™' or '®' characters. See
http://www.gnu.org/prep/standards/html_node/Trademarks.html."
(match (string-index description (char-set #\™ #\®))
((and (? number?) index)
- (emit-warning package
- (format #f (G_ "description should not contain ~
+ (list
+ (make-warning package
+ (format #f (G_ "description should not contain ~
trademark sign '~a' at ~d")
- (string-ref description index) index)
- 'description))
- (else #t)))
+ (string-ref description index) index)
+ #:field 'description)))
+ (else '())))
(define (check-quotes description)
"Check whether DESCRIPTION contains single quotes and suggest @code."
- (when (regexp-exec %quoted-identifier-rx description)
- (emit-warning package
-
- ;; TRANSLATORS: '@code' is Texinfo markup and must be kept
- ;; as is.
- (G_ "use @code or similar ornament instead of quotes")
- 'description)))
+ (if (regexp-exec %quoted-identifier-rx description)
+ (list
+ (make-warning package
+ ;; TRANSLATORS: '@code' is Texinfo markup and must be kept
+ ;; as is.
+ (G_ "use @code or similar ornament instead of quotes")
+ #:field 'description))
+ '()))
(define (check-proper-start description)
- (unless (or (properly-starts-sentence? description)
- (string-prefix-ci? (package-name package) description))
- (emit-warning package
- (G_ "description should start with an upper-case letter or digit")
- 'description)))
+ (if (or (string-null? description)
+ (properly-starts-sentence? description)
+ (string-prefix-ci? (package-name package) description))
+ '()
+ (list
+ (make-warning
+ package
+ (G_ "description should start with an upper-case letter or digit")
+ #:field 'description))))
(define (check-end-of-sentence-space description)
"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)))
'("i.e" "e.g" "a.k.a" "resp"))
r (cons (match:start m) r)))))))
- (unless (null? infractions)
- (emit-warning package
- (format #f (G_ "sentences in description should be followed ~
+ (if (null? infractions)
+ '()
+ (list
+ (make-warning package
+ (format #f (G_ "sentences in description should be followed ~
by two spaces; possible infraction~p at ~{~a~^, ~}")
- (length infractions)
- infractions)
- 'description))))
+ (length infractions)
+ infractions)
+ #:field 'description)))))
(let ((description (package-description package)))
(if (string? description)
- (begin
- (check-not-empty description)
- (check-quotes description)
- (check-trademarks description)
- ;; Use raw description for this because Texinfo rendering
- ;; automatically fixes end of sentence space.
- (check-end-of-sentence-space description)
- (and=> (check-texinfo-markup description)
- check-proper-start))
- (emit-warning package
- (format #f (G_ "invalid description: ~s") description)
- 'description))))
+ (append
+ (check-not-empty description)
+ (check-quotes description)
+ (check-trademarks description)
+ ;; Use raw description for this because Texinfo rendering
+ ;; automatically fixes end of sentence space.
+ (check-end-of-sentence-space description)
+ (match (check-texinfo-markup description)
+ ((and warning (? lint-warning?)) (list warning))
+ (plain-description
+ (check-proper-start plain-description))))
+ (list
+ (make-warning package
+ (format #f (G_ "invalid description: ~s") description)
+ #:field 'description)))))
(define (package-input-intersection inputs-to-check input-names)
"Return the intersection between INPUTS-TO-CHECK, the list of input tuples
@@ -281,13 +305,13 @@ of a package, and INPUT-NAMES, a list of package specifications such as
"python-pytest-cov" "python2-pytest-cov"
"python-setuptools-scm" "python2-setuptools-scm"
"python-sphinx" "python2-sphinx")))
- (for-each (lambda (input)
- (emit-warning
- package
- (format #f (G_ "'~a' should probably be a native input")
- input)
- 'inputs-to-check))
- (package-input-intersection inputs input-names))))
+ (map (lambda (input)
+ (make-warning
+ package
+ (format #f (G_ "'~a' should probably be a native input")
+ input)
+ #:field 'inputs))
+ (package-input-intersection inputs input-names))))
(define (check-inputs-should-not-be-an-input-at-all package)
;; Emit a warning if some inputs of PACKAGE are likely to should not be
@@ -296,14 +320,15 @@ of a package, and INPUT-NAMES, a list of package specifications such as
"python2-setuptools"
"python-pip"
"python2-pip")))
- (for-each (lambda (input)
- (emit-warning
- package
- (format #f
- (G_ "'~a' should probably not be an input at all")
- input)))
- (package-input-intersection (package-direct-inputs package)
- input-names))))
+ (map (lambda (input)
+ (make-warning
+ package
+ (format #f
+ (G_ "'~a' should probably not be an input at all")
+ input)
+ #:field 'inputs))
+ (package-input-intersection (package-direct-inputs package)
+ input-names))))
(define (package-name-regexp package)
"Return a regexp that matches PACKAGE's name as a word at the beginning of a
@@ -314,66 +339,71 @@ line."
(define (check-synopsis-style 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)
;; Synopsis should not end with a period, except for some special cases.
- (when (and (string-suffix? "." synopsis)
- (not (string-suffix? "etc." synopsis)))
- (emit-warning package
- (G_ "no period allowed at the end of the synopsis")
- 'synopsis)))
+ (if (and (string-suffix? "." synopsis)
+ (not (string-suffix? "etc." synopsis)))
+ (list
+ (make-warning package
+ (G_ "no period allowed at the end of the synopsis")
+ #:field 'synopsis))
+ '()))
(define check-start-article
;; 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>.
(if (false-if-exception (gnu-package? package))
- (const #t)
+ (const '())
(lambda (synopsis)
- (when (or (string-prefix-ci? "A " synopsis)
- (string-prefix-ci? "An " synopsis))
- (emit-warning package
- (G_ "no article allowed at the beginning of \
+ (if (or (string-prefix-ci? "A " synopsis)
+ (string-prefix-ci? "An " synopsis))
+ (list
+ (make-warning package
+ (G_ "no article allowed at the beginning of \
the synopsis")
- 'synopsis)))))
+ #:field 'synopsis))
+ '()))))
(define (check-synopsis-length synopsis)
- (when (>= (string-length synopsis) 80)
- (emit-warning package
- (G_ "synopsis should be less than 80 characters long")
- 'synopsis)))
+ (if (>= (string-length synopsis) 80)
+ (list
+ (make-warning package
+ (G_ "synopsis should be less than 80 characters long")
+ #:field 'synopsis))
+ '()))
(define (check-proper-start synopsis)
- (unless (properly-starts-sentence? synopsis)
- (emit-warning package
- (G_ "synopsis should start with an upper-case letter or digit")
- 'synopsis)))
+ (if (properly-starts-sentence? synopsis)
+ '()
+ (list
+ (make-warning package
+ (G_ "synopsis should start with an upper-case letter or digit")
+ #:field '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)))
- (emit-warning package
- (G_ "synopsis should not start with the package name")
- 'synopsis)))
+ (list
+ (make-warning package
+ (G_ "synopsis should not start with the package name")
+ #:field 'synopsis))
+ '()))
(define (check-texinfo-markup synopsis)
"Check that SYNOPSIS can be parsed as a Texinfo fragment. If the
markup is valid return a plain-text version of SYNOPSIS, otherwise #f."
(catch #t
- (lambda () (texi->plain-text synopsis))
+ (lambda ()
+ (texi->plain-text synopsis)
+ '())
(lambda (keys . args)
- (emit-warning package
- (G_ "Texinfo markup in synopsis is invalid")
- 'synopsis)
- #f)))
+ (list
+ (make-warning package
+ (G_ "Texinfo markup in synopsis is invalid")
+ #:field 'synopsis)))))
(define checks
- (list check-not-empty
- check-proper-start
+ (list check-proper-start
check-final-period
check-start-article
check-start-with-package-name
@@ -381,13 +411,20 @@ markup is valid return a plain-text version of SYNOPSIS, otherwise #f."
check-texinfo-markup))
(match (package-synopsis package)
+ (""
+ (list
+ (make-warning package
+ (G_ "synopsis should not be empty")
+ #:field 'synopsis)))
((? string? synopsis)
- (for-each (lambda (proc)
- (proc synopsis))
- checks))
+ (append-map
+ (lambda (proc)
+ (proc synopsis))
+ checks))
(invalid
- (emit-warning package (format #f (G_ "invalid synopsis: ~s") invalid)
- 'synopsis))))
+ (list
+ (make-warning package (format #f (G_ "invalid synopsis: ~s") invalid)
+ #:field 'synopsis)))))
(define* (probe-uri uri #:key timeout)
"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))))
(define (validate-uri uri package field)
- "Return #t if the given URI can be reached, otherwise return #f and emit a
-warning for PACKAGE mentionning the FIELD."
+ "Return #t if the given URI can be reached, otherwise return a warning for
+PACKAGE mentionning the FIELD."
(let-values (((status argument)
(probe-uri uri #:timeout 3))) ;wait at most 3 seconds
(case status
@@ -502,71 +539,66 @@ warning for PACKAGE mentionning the FIELD."
;; with a small HTML page upon failure. Attempt to detect
;; such malicious behavior.
(or (> length 1000)
- (begin
- (emit-warning package
- (format #f
- (G_ "URI ~a returned \
+ (make-warning package
+ (format #f
+ (G_ "URI ~a returned \
suspiciously small file (~a bytes)")
- (uri->string uri)
- length))
- #f)))
+ (uri->string uri)
+ length)
+ #:field field)))
(_ #t)))
((= 301 (response-code argument))
(if (response-location argument)
- (begin
- (emit-warning package
- (format #f (G_ "permanent redirect from ~a to ~a")
- (uri->string uri)
- (uri->string
- (response-location argument))))
- #t)
- (begin
- (emit-warning package
- (format #f (G_ "invalid permanent redirect \
+ (make-warning package
+ (format #f (G_ "permanent redirect from ~a to ~a")
+ (uri->string uri)
+ (uri->string
+ (response-location argument)))
+ #:field field)
+ (make-warning package
+ (format #f (G_ "invalid permanent redirect \
from ~a")
- (uri->string uri)))
- #f)))
+ (uri->string uri))
+ #:field field)))
(else
- (emit-warning package
+ (make-warning package
(format #f
(G_ "URI ~a not reachable: ~a (~s)")
(uri->string uri)
(response-code argument)
(response-reason-phrase argument))
- field)
- #f)))
+ #:field field))))
((ftp-response)
(match argument
(('ok) #t)
(('error port command code message)
- (emit-warning package
+ (make-warning package
(format #f
(G_ "URI ~a not reachable: ~a (~s)")
(uri->string uri)
- code (string-trim-both message)))
- #f)))
+ code (string-trim-both message))
+ #:field field))))
((getaddrinfo-error)
- (emit-warning package
+ (make-warning package
(format #f
(G_ "URI ~a domain not found: ~a")
(uri->string uri)
(gai-strerror (car argument)))
- field)
- #f)
+ #:field field))
((system-error)
- (emit-warning package
+ (make-warning package
(format #f
(G_ "URI ~a unreachable: ~a")
(uri->string uri)
(strerror
(system-error-errno
(cons status argument))))
- field)
- #f)
+ #:field field))
((tls-certificate-error)
- (emit-warning package
+ (make-warning package
(format #f (G_ "TLS certificate error: ~a")
- (tls-certificate-error-string argument))))
+ (tls-certificate-error-string argument))
+ #:field field))
((invalid-http-response gnutls-error)
;; Probably a misbehaving server; ignore.
#f)
@@ -581,17 +613,23 @@ from ~a")
(let ((uri (and=> (package-home-page package) string->uri)))
(cond
((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))
- (unless (or (string-contains (package-name package) "bootstrap")
- (string=? (package-name package) "ld-wrapper"))
- (emit-warning package
- (G_ "invalid value for home page")
- 'home-page)))
+ (if (or (string-contains (package-name package) "bootstrap")
+ (string=? (package-name package) "ld-wrapper"))
+ '()
+ (list
+ (make-warning package
+ (G_ "invalid value for home page")
+ #:field 'home-page))))
(else
- (emit-warning package (format #f (G_ "invalid home page URL: ~s")
- (package-home-page package))
- 'home-page)))))
+ (list
+ (make-warning package (format #f (G_ "invalid home page URL: ~s")
+ (package-home-page package))
+ #:field 'home-page))))))
(define %distro-directory
(mlambda ()
@@ -601,42 +639,47 @@ from ~a")
"Emit a warning if the patches requires by PACKAGE are badly named or if the
patch could not be found."
(guard (c ((message-condition? c) ;raised by 'search-patch'
- (emit-warning package (condition-message c)
- 'patch-file-names)))
+ (list
+ (make-warning package (condition-message c)
+ #:field 'patch-file-names))))
(define patches
(or (and=> (package-source package) origin-patches)
'()))
- (unless (every (match-lambda ;patch starts with package name?
- ((? string? patch)
- (and=> (string-contains (basename patch)
- (package-name package))
- zero?))
- (_ #f)) ;must be an <origin> or something like that.
- patches)
- (emit-warning
- package
- (G_ "file names of patches should start with the package name")
- 'patch-file-names))
-
- ;; Check whether we're reaching tar's maximum file name length.
- (let ((prefix (string-length (%distro-directory)))
- (margin (string-length "guix-0.13.0-10-123456789/"))
- (max 99))
- (for-each (match-lambda
+ (append
+ (if (every (match-lambda ;patch starts with package name?
((? string? patch)
- (when (> (+ margin (if (string-prefix? (%distro-directory)
- patch)
- (- (string-length patch) prefix)
- (string-length patch)))
- max)
- (emit-warning
- package
- (format #f (G_ "~a: file name is too long")
- (basename patch))
- 'patch-file-names)))
- (_ #f))
- patches))))
+ (and=> (string-contains (basename patch)
+ (package-name package))
+ zero?))
+ (_ #f)) ;must be an <origin> or something like that.
+ patches)
+ '()
+ (list
+ (make-warning
+ package
+ (G_ "file names of patches should start with the package name")
+ #:field 'patch-file-names)))
+
+ ;; Check whether we're reaching tar's maximum file name length.
+ (let ((prefix (string-length (%distro-directory)))
+ (margin (string-length "guix-0.13.0-10-123456789/"))
+ (max 99))
+ (filter-map (match-lambda
+ ((? string? patch)
+ (if (> (+ margin (if (string-prefix? (%distro-directory)
+ patch)
+ (- (string-length patch) prefix)
+ (string-length patch)))
+ max)
+ (make-warning
+ package
+ (format #f (G_ "~a: file name is too long")
+ (basename patch))
+ #:field 'patch-file-names)
+ #f))
+ (_ #f))
+ patches)))))
(define (escape-quotes str)
"Replace any quote character in STR by an escaped quote character."
@@ -663,32 +706,35 @@ descriptions maintained upstream."
(package-name package)))
(official-gnu-packages*))
(#f ;not a GNU package, so nothing to do
- #t)
+ '())
(descriptor ;a genuine GNU package
- (let ((upstream (gnu-package-doc-summary descriptor))
- (downstream (package-synopsis package))
- (loc (or (package-field-location package 'synopsis)
- (package-location package))))
- (when (and upstream
- (or (not (string? downstream))
- (not (string=? upstream downstream))))
- (format (guix-warning-port)
- (G_ "~a: ~a: proposed synopsis: ~s~%")
- (location->string loc) (package-full-name package)
- upstream)))
-
- (let ((upstream (gnu-package-doc-description descriptor))
- (downstream (package-description package))
- (loc (or (package-field-location package 'description)
- (package-location package))))
- (when (and upstream
- (or (not (string? downstream))
- (not (string=? (fill-paragraph upstream 100)
- (fill-paragraph downstream 100)))))
- (format (guix-warning-port)
- (G_ "~a: ~a: proposed description:~% \"~a\"~%")
- (location->string loc) (package-full-name package)
- (fill-paragraph (escape-quotes upstream) 77 7)))))))
+ (append
+ (let ((upstream (gnu-package-doc-summary descriptor))
+ (downstream (package-synopsis package)))
+ (if (and upstream
+ (or (not (string? downstream))
+ (not (string=? upstream downstream))))
+ (list
+ (make-warning package
+ (format #f (G_ "proposed synopsis: ~s~%")
+ upstream)
+ #:field 'synopsis))
+ '()))
+
+ (let ((upstream (gnu-package-doc-description descriptor))
+ (downstream (package-description package)))
+ (if (and upstream
+ (or (not (string? downstream))
+ (not (string=? (fill-paragraph upstream 100)
+ (fill-paragraph downstream 100)))))
+ (list
+ (make-warning
+ package
+ (format #f
+ (G_ "proposed description:~% \"~a\"~%")
+ (fill-paragraph (escape-quotes upstream) 77 7))
+ #:field 'description))
+ '()))))))
(define (origin-uris origin)
"Return the list of URIs (strings) for ORIGIN."
@@ -701,38 +747,35 @@ descriptions maintained upstream."
(define (check-source package)
"Emit a warning if PACKAGE has an invalid 'source' field, or if that
'source' is not reachable."
- (define (try-uris uris)
- (run-with-state
- (anym %state-monad
- (lambda (uri)
- (with-accumulated-warnings
- (validate-uri uri package 'source)))
- (append-map (cut maybe-expand-mirrors <> %mirrors)
- uris))
- '()))
+ (define (warnings-for-uris uris)
+ (filter lint-warning?
+ (map
+ (lambda (uri)
+ (validate-uri uri package 'source))
+ (append-map (cut maybe-expand-mirrors <> %mirrors)
+ uris))))
(let ((origin (package-source package)))
- (when (and origin
- (eqv? (origin-method origin) url-fetch))
- (let ((uris (map string->uri (origin-uris origin))))
-
- ;; Just make sure that at least one of the URIs is valid.
- (call-with-values
- (lambda () (try-uris uris))
- (lambda (success? warnings)
- ;; When everything fails, report all of WARNINGS, otherwise don't
- ;; report anything.
- ;;
- ;; XXX: Ideally we'd still allow warnings to be raised if *some*
- ;; URIs are unreachable, but distinguish that from the error case
- ;; where *all* the URIs are unreachable.
- (unless success?
- (emit-warning package
- (G_ "all the source URIs are unreachable:")
- 'source)
- (for-each (lambda (warning)
- (display warning (guix-warning-port)))
- (reverse warnings)))))))))
+ (if (and origin
+ (eqv? (origin-method origin) url-fetch))
+ (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.
+ (if (eq? (length uris) (length warnings))
+ ;; When everything fails, report all of WARNINGS, otherwise don't
+ ;; report anything.
+ ;;
+ ;; XXX: Ideally we'd still allow warnings to be raised if *some*
+ ;; URIs are unreachable, but distinguish that from the error case
+ ;; where *all* the URIs are unreachable.
+ (cons*
+ (make-warning package
+ (G_ "all the source URIs are unreachable:")
+ #:field 'source)
+ warnings)
+ '()))
+ '())))
(define (check-source-file-name package)
"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)))))
(let ((origin (package-source package)))
- (unless (or (not origin) (origin-file-name-valid? origin))
- (emit-warning package
- (G_ "the source file name should contain the package name")
- 'source))))
+ (if (or (not origin) (origin-file-name-valid? origin))
+ '()
+ (list
+ (make-warning package
+ (G_ "the source file name should contain the package name")
+ #:field 'source)))))
(define (check-source-unstable-tarball package)
"Emit a warning if PACKAGE's source is an autogenerated tarball."
(define (check-source-uri uri)
- (when (and (string=? (uri-host (string->uri uri)) "github.com")
- (match (split-and-decode-uri-path
- (uri-path (string->uri uri)))
- ((_ _ "archive" _ ...) #t)
- (_ #f)))
- (emit-warning package
- (G_ "the source URI should not be an autogenerated tarball")
- 'source)))
+ (if (and (string=? (uri-host (string->uri uri)) "github.com")
+ (match (split-and-decode-uri-path
+ (uri-path (string->uri uri)))
+ ((_ _ "archive" _ ...) #t)
+ (_ #f)))
+ (make-warning package
+ (G_ "the source URI should not be an autogenerated tarball")
+ #:field 'source)
+ #f))
+
(let ((origin (package-source package)))
- (when (and (origin? origin)
- (eqv? (origin-method origin) url-fetch))
- (let ((uris (origin-uris origin)))
- (for-each check-source-uri uris)))))
+ (if (and (origin? origin)
+ (eqv? (origin-method origin) url-fetch))
+ (filter-map check-source-uri
+ (origin-uris origin))
+ '())))
(define (check-mirror-url package)
"Check whether PACKAGE uses source URLs that should be 'mirror://'."
@@ -776,24 +824,25 @@ descriptions maintained upstream."
(let loop ((mirrors %mirrors))
(match mirrors
(()
- #t)
+ #f)
(((mirror-id mirror-urls ...) rest ...)
(match (find (cut string-prefix? <> uri) mirror-urls)
(#f
(loop rest))
(prefix
- (emit-warning package
+ (make-warning package
(format #f (G_ "URL should be \
'mirror://~a/~a'")
mirror-id
(string-drop uri (string-length prefix)))
- 'source)))))))
+ #:field 'source)))))))
(let ((origin (package-source package)))
- (when (and (origin? origin)
- (eqv? (origin-method origin) url-fetch))
- (let ((uris (origin-uris origin)))
- (for-each check-mirror-uri uris)))))
+ (if (and (origin? origin)
+ (eqv? (origin-method origin) url-fetch))
+ (let ((uris (origin-uris origin)))
+ (filter-map check-mirror-uri uris))
+ '())))
(define* (check-github-url package #:key (timeout 3))
"Check whether PACKAGE uses source URLs that redirect to GitHub."
@@ -817,18 +866,20 @@ descriptions maintained upstream."
(else #f)))
(let ((origin (package-source package)))
- (when (and (origin? origin)
- (eqv? (origin-method origin) url-fetch))
- (for-each
- (lambda (uri)
- (and=> (follow-redirects-to-github uri)
- (lambda (github-uri)
- (unless (string=? github-uri uri)
- (emit-warning
- package
- (format #f (G_ "URL should be '~a'") github-uri)
- 'source)))))
- (origin-uris origin)))))
+ (if (and (origin? origin)
+ (eqv? (origin-method origin) url-fetch))
+ (filter-map
+ (lambda (uri)
+ (and=> (follow-redirects-to-github uri)
+ (lambda (github-uri)
+ (if (string=? github-uri uri)
+ #f
+ (make-warning
+ package
+ (format #f (G_ "URL should be '~a'") github-uri)
+ #:field 'source)))))
+ (origin-uris origin))
+ '())))
(define (check-derivation package)
"Emit a warning if we fail to compile PACKAGE to a derivation."
@@ -836,12 +887,12 @@ descriptions maintained upstream."
(catch #t
(lambda ()
(guard (c ((store-protocol-error? c)
- (emit-warning package
+ (make-warning package
(format #f (G_ "failed to create ~a derivation: ~a")
system
(store-protocol-error-message c))))
((message-condition? c)
- (emit-warning package
+ (make-warning package
(format #f (G_ "failed to create ~a derivation: ~a")
system
(condition-message c)))))
@@ -858,21 +909,23 @@ descriptions maintained upstream."
(package-derivation store replacement system
#:graft? #f)))))))
(lambda args
- (emit-warning package
+ (make-warning package
(format #f (G_ "failed to create ~a derivation: ~s")
system args)))))
- (for-each try (package-supported-systems package)))
+ (filter lint-warning?
+ (map try (package-supported-systems package))))
(define (check-license package)
"Warn about type errors of the 'license' field of PACKAGE."
(match (package-license package)
((or (? license?)
((? license?) ...))
- #t)
+ '())
(x
- (emit-warning package (G_ "invalid license field")
- 'license))))
+ (list
+ (make-warning package (G_ "invalid license field")
+ #:field 'license)))))
(define (call-with-networking-fail-safe message error-value proc)
"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)))
(match (package-vulnerabilities package)
(()
- #t)
+ '())
((vulnerabilities ...)
(let* ((patched (package-patched-vulnerabilities package))
(known-safe (or (assq-ref (package-properties package)
@@ -943,11 +996,14 @@ the NIST server non-fatal."
(or (member id patched)
(member id known-safe))))
vulnerabilities)))
- (unless (null? unpatched)
- (emit-warning package
- (format #f (G_ "probably vulnerable to ~a")
- (string-join (map vulnerability-id unpatched)
- ", ")))))))))
+ (if (null? unpatched)
+ '()
+ (list
+ (make-warning
+ package
+ (format #f (G_ "probably vulnerable to ~a")
+ (string-join (map vulnerability-id unpatched)
+ ", "))))))))))
(define (check-for-updates package)
"Check if there is an update available for PACKAGE."
@@ -957,12 +1013,15 @@ the NIST server non-fatal."
#f
(package-latest-release* package (force %updaters)))
((? upstream-source? source)
- (when (version>? (upstream-source-version source)
- (package-version package))
- (emit-warning package
- (format #f (G_ "can be upgraded to ~a")
- (upstream-source-version source)))))
- (#f #f))) ; cannot find newer upstream release
+ (if (version>? (upstream-source-version source)
+ (package-version package))
+ (list
+ (make-warning package
+ (format #f (G_ "can be upgraded to ~a")
+ (upstream-source-version source))
+ #:field 'version))
+ '()))
+ (#f '()))) ; cannot find newer upstream release
\f
;;;
@@ -974,18 +1033,26 @@ the NIST server non-fatal."
(match (string-index line #\tab)
(#f #t)
(index
- (emit-warning package
+ (make-warning package
(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)
"Warn about trailing white space in LINE."
(unless (or (string=? line (string-trim-right line))
(string=? line (string #\page)))
- (emit-warning package
+ (make-warning package
(format #f
(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)
"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
;; much noise.
(when (> (string-length line) 90)
- (emit-warning package
+ (make-warning package
(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
(make-regexp "^[[:blank:]]*[()]+[[:blank:]]*$"))
@@ -1003,11 +1074,15 @@ the NIST server non-fatal."
(define (report-lone-parentheses package line line-number)
"Emit a warning if LINE contains hanging parentheses."
(when (regexp-exec %hanging-paren-rx line)
- (emit-warning package
+ (make-warning package
(format #f
- (G_ "line ~a: parentheses feel lonely, \
+ (G_ "parentheses feel lonely, \
move to the previous or next line")
- line-number))))
+ line-number)
+ #:location
+ (location (package-file package)
+ line-number
+ 0))))
(define %formatting-reporters
;; List of procedures that report formatting issues. These are not separate
@@ -1040,31 +1115,40 @@ them for PACKAGE."
(call-with-input-file file
(lambda (port)
(let loop ((line-number 1)
- (last-line #f))
+ (last-line #f)
+ (warnings '()))
(let ((line (read-line port)))
- (or (eof-object? line)
- (and last-line (> line-number last-line))
+ (if (or (eof-object? line)
+ (and last-line (> line-number last-line)))
+ warnings
(if (and (= line-number starting-line)
(not last-line))
(loop (+ 1 line-number)
- (+ 1 (sexp-last-line port)))
- (begin
- (unless (< line-number starting-line)
- (for-each (lambda (report)
- (report package line line-number))
- reporters))
- (loop (+ 1 line-number) last-line)))))))))
+ (+ 1 (sexp-last-line port))
+ warnings)
+ (loop (+ 1 line-number)
+ last-line
+ (append
+ warnings
+ (if (< line-number starting-line)
+ '()
+ (filter
+ lint-warning?
+ (map (lambda (report)
+ (report package line line-number))
+ reporters))))))))))))
(define (check-formatting package)
"Check the formatting of the source code of PACKAGE."
(let ((location (package-location package)))
- (when location
- (and=> (search-path %load-path (location-file location))
- (lambda (file)
- ;; Report issues starting from the line before the 'package'
- ;; form, which usually contains the 'define' form.
- (report-formatting-issues package file
- (- (location-line location) 1)))))))
+ (if location
+ (and=> (search-path %load-path (location-file location))
+ (lambda (file)
+ ;; Report issues starting from the line before the 'package'
+ ;; form, which usually contains the 'define' form.
+ (report-formatting-issues package file
+ (- (location-line location) 1))))
+ '())))
\f
;;;
@@ -1155,7 +1239,8 @@ or a list thereof")
(package-name package) (package-version package)
(lint-checker-name checker))
(force-output (current-error-port)))
- ((lint-checker-check checker) package))
+ (emit-warnings
+ ((lint-checker-check checker) package)))
checkers)
(when tty?
(format (current-error-port) "\x1b[K")
diff --git a/tests/lint.scm b/tests/lint.scm
index dc2b17aeec..d8b2ca54cd 100644
--- a/tests/lint.scm
+++ b/tests/lint.scm
@@ -44,7 +44,12 @@
#: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.
@@ -60,781 +65,696 @@
(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))))
+
\f
(test-begin "lint")
-(define (call-with-warnings thunk)
- (let ((port (open-output-string)))
- (parameterize ((guix-warning-port port))
- (thunk))
- (get-output-string port)))
-
-(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
- (let ((pkg (dummy-package "x"
- (description ""))))
- (check-description-style pkg)))
- "description should not be empty")))
-
-(test-assert "description: valid Texinfo markup"
- (->bool
- (string-contains
- (with-warnings
- (check-description-style (dummy-package "x" (description "f{oo}b@r"))))
- "Texinfo markup in description is invalid")))
-
-(test-assert "description: does not start with an upper-case letter"
- (->bool
- (string-contains (with-warnings
- (let ((pkg (dummy-package "x"
- (description "bad description."))))
- (check-description-style pkg)))
- "description should start with an upper-case letter")))
-
-(test-assert "description: may start with a digit"
- (string-null?
- (with-warnings
- (let ((pkg (dummy-package "x"
- (description "2-component library."))))
- (check-description-style pkg)))))
-
-(test-assert "description: may start with lower-case package name"
- (string-null?
- (with-warnings
- (let ((pkg (dummy-package "x"
- (description "x is a dummy package."))))
- (check-description-style pkg)))))
-
-(test-assert "description: two spaces after end of sentence"
- (->bool
- (string-contains (with-warnings
- (let ((pkg (dummy-package "x"
- (description "Bad. Quite bad."))))
- (check-description-style pkg)))
- "sentences in description should be followed by two spaces")))
-
-(test-assert "description: end-of-sentence detection with abbreviations"
- (string-null?
- (with-warnings
- (let ((pkg (dummy-package "x"
- (description
- "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 "description: suggest ornament instead of quotes"
- (->bool
- (string-contains (with-warnings
- (let ((pkg (dummy-package "x"
- (description "This is a 'quoted' thing."))))
- (check-description-style pkg)))
- "use @code")))
-
-(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
- (let ((pkg (dummy-package "x"
- (synopsis ""))))
- (check-synopsis-style pkg)))
- "synopsis should not be empty")))
-
-(test-assert "synopsis: valid Texinfo markup"
- (->bool
- (string-contains
- (with-warnings
- (check-synopsis-style (dummy-package "x" (synopsis "Bad $@ texinfo"))))
- "Texinfo markup in synopsis is invalid")))
-
-(test-assert "synopsis: does not start with an upper-case letter"
- (->bool
- (string-contains (with-warnings
- (let ((pkg (dummy-package "x"
- (synopsis "bad synopsis."))))
- (check-synopsis-style pkg)))
- "synopsis should start with an upper-case letter")))
-
-(test-assert "synopsis: may start with a digit"
- (string-null?
- (with-warnings
- (let ((pkg (dummy-package "x"
- (synopsis "5-dimensional frobnicator"))))
- (check-synopsis-style pkg)))))
-
-(test-assert "synopsis: ends with a period"
- (->bool
- (string-contains (with-warnings
- (let ((pkg (dummy-package "x"
- (synopsis "Bad synopsis."))))
- (check-synopsis-style pkg)))
- "no period allowed at the end of the synopsis")))
-
-(test-assert "synopsis: ends with 'etc.'"
- (string-null? (with-warnings
- (let ((pkg (dummy-package "x"
- (synopsis "Foo, bar, etc."))))
- (check-synopsis-style pkg)))))
-
-(test-assert "synopsis: starts with 'A'"
- (->bool
- (string-contains (with-warnings
- (let ((pkg (dummy-package "x"
- (synopsis "A bad synopŝis"))))
- (check-synopsis-style pkg)))
- "no article allowed at the beginning of the synopsis")))
-
-(test-assert "synopsis: starts with 'An'"
- (->bool
- (string-contains (with-warnings
- (let ((pkg (dummy-package "x"
- (synopsis "An awful synopsis"))))
- (check-synopsis-style pkg)))
- "no article allowed at the beginning of the synopsis")))
-
-(test-assert "synopsis: starts with 'a'"
- (->bool
- (string-contains (with-warnings
- (let ((pkg (dummy-package "x"
- (synopsis "a bad synopsis"))))
- (check-synopsis-style pkg)))
- "no article allowed at the beginning of the synopsis")))
-
-(test-assert "synopsis: starts with 'an'"
- (->bool
- (string-contains (with-warnings
- (let ((pkg (dummy-package "x"
- (synopsis "an awful synopsis"))))
- (check-synopsis-style pkg)))
- "no article allowed at the beginning of the synopsis")))
-
-(test-assert "synopsis: too long"
- (->bool
- (string-contains (with-warnings
- (let ((pkg (dummy-package "x"
- (synopsis (make-string 80 #\x)))))
- (check-synopsis-style pkg)))
- "synopsis should be less than 80 characters long")))
-
-(test-assert "synopsis: start with package name"
- (->bool
- (string-contains (with-warnings
- (let ((pkg (dummy-package "x"
- (name "foo")
- (synopsis "foo, a nice package"))))
- (check-synopsis-style pkg)))
- "synopsis should not start with the package name")))
-
-(test-assert "synopsis: start with package name prefix"
- (string-null?
- (with-warnings
- (let ((pkg (dummy-package "arb"
- (synopsis "Arbitrary precision"))))
- (check-synopsis-style pkg)))))
-
-(test-assert "synopsis: start with abbreviation"
- (string-null?
- (with-warnings
- (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-assert "inputs: pkg-config is probably a native input"
- (->bool
- (string-contains
- (with-warnings
- (let ((pkg (dummy-package "x"
- (inputs `(("pkg-config" ,pkg-config))))))
- (check-inputs-should-be-native pkg)))
- "'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
+(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)"
- (->bool
- (string-contains
- (with-warnings
- (let ((pkg (dummy-package "x"
- (inputs `(("python-setuptools" ,python-setuptools))))))
- (check-inputs-should-not-be-an-input-at-all pkg)))
- "'python-setuptools' should probably not be an input at all")))
-
-(test-assert
+ "'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)"
- (->bool
- (string-contains
- (with-warnings
- (let ((pkg (dummy-package "x"
- (native-inputs
- `(("python-setuptools" ,python-setuptools))))))
- (check-inputs-should-not-be-an-input-at-all pkg)))
- "'python-setuptools' should probably not be an input at all")))
-
-(test-assert
+ "'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)"
- (->bool
- (string-contains
- (with-warnings
- (let ((pkg (dummy-package "x"
- (propagated-inputs
- `(("python-setuptools" ,python-setuptools))))))
- (check-inputs-should-not-be-an-input-at-all pkg)))
- "'python-setuptools' should probably not be an input at all")))
-
-(test-assert "patches: file names"
- (->bool
- (string-contains
- (with-warnings
- (let ((pkg (dummy-package "x"
- (source
- (dummy-origin
- (patches (list "/path/to/y.patch")))))))
- (check-patch-file-names pkg)))
- "file names of patches should start with the package name")))
-
-(test-assert "patches: file name too long"
- (->bool
- (string-contains
- (with-warnings
- (let ((pkg (dummy-package "x"
- (source
- (dummy-origin
- (patches (list (string-append "x-"
- (make-string 100 #\a)
- ".patch"))))))))
- (check-patch-file-names pkg)))
- "file name is too long")))
-
-(test-assert "patches: not found"
- (->bool
- (string-contains
- (with-warnings
- (let ((pkg (dummy-package "x"
- (source
- (dummy-origin
- (patches
- (list (search-patch "this-patch-does-not-exist!"))))))))
- (check-patch-file-names pkg)))
- "patch not found")))
-
-(test-assert "derivation: invalid arguments"
- (->bool
- (string-contains
- (with-warnings
- (let ((pkg (dummy-package "x"
- (arguments
- '(#:imported-modules (invalid-module))))))
- (check-derivation pkg)))
- "failed to create")))
-
-(test-assert "license: invalid license"
- (string-contains
- (with-warnings
- (check-license (dummy-package "x" (license #f))))
- "invalid license"))
-
-(test-assert "home-page: wrong home-page"
- (->bool
- (string-contains
- (with-warnings
- (let ((pkg (package
- (inherit (dummy-package "x"))
- (home-page #f))))
- (check-home-page pkg)))
- "invalid")))
-
-(test-assert "home-page: invalid URI"
- (->bool
- (string-contains
- (with-warnings
- (let ((pkg (package
- (inherit (dummy-package "x"))
- (home-page "foobar"))))
- (check-home-page pkg)))
- "invalid home page URL")))
-
-(test-assert "home-page: host not found"
- (->bool
- (string-contains
- (with-warnings
- (let ((pkg (package
- (inherit (dummy-package "x"))
- (home-page "http://does-not-exist"))))
- (check-home-page pkg)))
- "domain not found")))
+ "'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-assert "home-page: Connection refused"
- (->bool
- (string-contains
- (with-warnings
- (let ((pkg (package
- (inherit (dummy-package "x"))
- (home-page (%local-url)))))
- (check-home-page pkg)))
- "Connection refused")))
+(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-warnings
- (with-http-server 200 %long-string
- (let ((pkg (package
- (inherit (dummy-package "x"))
- (home-page (%local-url)))))
- (check-home-page pkg)))))
+ '()
+ (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-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-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-assert "home-page: 404"
- (->bool
- (string-contains
- (with-warnings
- (with-http-server 404 %long-string
- (let ((pkg (package
- (inherit (dummy-package "x"))
- (home-page (%local-url)))))
- (check-home-page pkg))))
- "not reachable: 404")))
+(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-assert "home-page: 301, invalid"
- (->bool
- (string-contains
- (with-warnings
- (with-http-server 301 %long-string
- (let ((pkg (package
- (inherit (dummy-package "x"))
- (home-page (%local-url)))))
- (check-home-page pkg))))
- "invalid permanent redirect")))
+(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-assert "home-page: 301 -> 200"
- (->bool
- (string-contains
- (with-warnings
- (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)))))
- (check-home-page pkg)))))))
- "permanent redirect")))
+(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-assert "home-page: 301 -> 404"
- (->bool
- (string-contains
- (with-warnings
- (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)))))
- (check-home-page pkg)))))))
- "not reachable: 404")))
-
-(test-assert "source-file-name"
- (->bool
- (string-contains
- (with-warnings
- (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))))))
- (check-source-file-name pkg)))
- "file name should contain the package name")))
-
-(test-assert "source-file-name: v prefix"
- (->bool
- (string-contains
- (with-warnings
- (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))))))
- (check-source-file-name pkg)))
- "file name should contain the package name")))
-
-(test-assert "source-file-name: bad checkout"
- (->bool
- (string-contains
- (with-warnings
- (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))))))
- (check-source-file-name pkg)))
- "file name should contain the package name")))
-
-(test-assert "source-file-name: good checkout"
- (not
- (->bool
- (string-contains
- (with-warnings
- (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)))
- "file name should contain the package name"))))
-
-(test-assert "source-file-name: valid"
- (not
- (->bool
- (string-contains
- (with-warnings
- (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)))
- "file name should contain the package name"))))
-
-(test-assert "source-unstable-tarball"
- (string-contains
- (with-warnings
- (let ((pkg (dummy-package "x"
- (source
- (origin
- (method url-fetch)
- (uri "https://github.com/example/example/archive/v0.0.tar.gz")
- (sha256 %null-sha256))))))
- (check-source-unstable-tarball pkg)))
- "source URI should not be an autogenerated tarball"))
-
-(test-assert "source-unstable-tarball: source #f"
- (not
- (->bool
- (string-contains
- (with-warnings
- (let ((pkg (dummy-package "x"
- (source #f))))
- (check-source-unstable-tarball pkg)))
- "source URI should not be an autogenerated tarball"))))
-
-(test-assert "source-unstable-tarball: valid"
- (not
- (->bool
- (string-contains
- (with-warnings
- (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)))
- "source URI should not be an autogenerated tarball"))))
-
-(test-assert "source-unstable-tarball: package named archive"
- (not
- (->bool
- (string-contains
- (with-warnings
- (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)))
- "source URI should not be an autogenerated tarball"))))
-
-(test-assert "source-unstable-tarball: not-github"
- (not
- (->bool
- (string-contains
- (with-warnings
- (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)))
- "source URI should not be an autogenerated tarball"))))
-
-(test-assert "source-unstable-tarball: git-fetch"
- (not
- (->bool
- (string-contains
- (with-warnings
- (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)))
- "source URI should not be an autogenerated tarball"))))
+(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-skip (if (http-server-can-listen?) 0 1))
-(test-equal "source: 200"
- ""
- (with-warnings
- (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-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-skip (if (http-server-can-listen?) 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
+(test-equal "source-unstable-tarball: package named archive"
+ '()
+ (let ((pkg (dummy-package "x"
+ (source
+ (origin
(method url-fetch)
- (uri (%local-url))
+ (uri "https://github.com/example/archive/releases/download/x-0.0/x-0.0.tar.gz")
(sha256 %null-sha256))))))
- (check-source pkg))))
- "suspiciously small")))
+ (check-source-unstable-tarball pkg)))
-(test-skip (if (http-server-can-listen?) 0 1))
-(test-assert "source: 404"
- (->bool
- (string-contains
- (with-warnings
- (with-http-server 404 %long-string
- (let ((pkg (package
- (inherit (dummy-package "x"))
- (source (origin
+(test-equal "source-unstable-tarball: not-github"
+ '()
+ (let ((pkg (dummy-package "x"
+ (source
+ (origin
(method url-fetch)
- (uri (%local-url))
+ (uri "https://bitbucket.org/archive/example/download/x-0.0.tar.gz")
(sha256 %null-sha256))))))
- (check-source pkg))))
- "not reachable: 404")))
+ (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"
- ""
- (with-warnings
- (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))))))
- (check-source pkg))))))))
+ "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-assert "source: 301 -> 404"
- (->bool
- (string-contains
- (with-warnings
- (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))))))
- (check-source pkg)))))))
- "not reachable: 404")))
-
-(test-assert "mirror-url"
- (string-null?
- (with-warnings
- (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-assert "mirror-url: one suggestion"
- (string-contains
- (with-warnings
- (let ((source (origin
- (method url-fetch)
- (uri "http://ftp.gnu.org/pub/gnu/foo/foo.tar.gz")
- (sha256 %null-sha256))))
- (check-mirror-url (dummy-package "x" (source source)))))
- "mirror://gnu/foo/foo.tar.gz"))
-
-(test-assert "github-url"
- (string-null?
- (with-warnings
- (with-http-server 200 %long-string
- (check-github-url
- (dummy-package "x" (source
- (origin
- (method url-fetch)
- (uri (%local-url))
- (sha256 %null-sha256)))))))))
+(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-assert "github-url: one suggestion"
- (string-contains
- (with-warnings
- (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)))) ""
- (check-github-url
- (dummy-package "x" (source
- (origin
- (method url-fetch)
- (uri (%local-url))
- (sha256 %null-sha256))))))))))
- github-url))
- (test-assert "github-url: already the correct github url"
- (string-null?
- (with-warnings
- (check-github-url
- (dummy-package "x" (source
- (origin
- (method url-fetch)
- (uri github-url)
- (sha256 %null-sha256)))))))))
-
-(test-assert "cve"
+ (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 '()))
- (string-null?
- (with-warnings (check-vulnerabilities (dummy-package "x"))))))
+ (check-vulnerabilities (dummy-package "x"))))
-(test-assert "cve: one vulnerability"
+(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)))))))
- (string-contains
- (with-warnings
- (check-vulnerabilities (dummy-package "pi" (version "3.14"))))
- "vulnerable to CVE-2015-1234")))
+ (single-lint-warning-message
+ (check-vulnerabilities (dummy-package "pi" (version "3.14"))))))
-(test-assert "cve: one patched vulnerability"
+(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)))))))
- (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: known safe from vulnerability"
+ (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)))))))
- (string-null?
- (with-warnings
- (check-vulnerabilities
- (dummy-package "pi"
- (version "3.14")
- (properties `((lint-hidden-cve . ("CVE-2015-1234"))))))))))
-
-(test-assert "cve: vulnerability fixed in replacement version"
+ (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)
@@ -845,71 +765,60 @@
(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"
+ (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)))))))
- (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
- (check-formatting
- (
- dummy-package "ugly as hell!"
- )
- ))
- "lonely"))
+ (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-contains
- (with-warnings
- (check-formatting (dummy-package "leave the tab here: ")))
- "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-contains
- (with-warnings
- ;; Leave the trailing white space on the next line!
- (check-formatting (dummy-package "x")))
- "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-contains
- (with-warnings
- (check-formatting
- (dummy-package "x" ;here is a stupid comment just to make a long line
- )))
- "too long"))
-
-(test-assert "formatting: alright"
- (string-null?
- (with-warnings
- (check-formatting (dummy-package "x")))))
+ (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")
--
2.22.0
^ permalink raw reply related [flat|nested] 37+ messages in thread
* [bug#35790] [PATCH 2/4] scripts: lint: Separate the message warning text and data.
2019-07-15 19:45 ` [bug#35790] [PATCH 1/4] scripts: lint: Handle warnings with a record type Christopher Baines
@ 2019-07-15 19:45 ` Christopher Baines
2019-07-15 19:45 ` [bug#35790] [PATCH 3/4] lint: Move the linting code to a different module Christopher Baines
2019-07-15 19:45 ` [bug#35790] [PATCH 4/4] lint: Separate checkers by dependence on the internet Christopher Baines
2 siblings, 0 replies; 37+ messages in thread
From: Christopher Baines @ 2019-07-15 19:45 UTC (permalink / raw)
To: 35790
So that translations can be handled more flexibly, rather than having to
translate the message text within the checker.
* guix/scripts/lint.scm (lint-warning-message-text,
lint-warning-message-data): New procedures.
(lint-warning-message): Remove record field accessor, replace with procedure
that handles the lint warning data and translating the message.
(make-warning): Rename to %make-warning.
(make-warning): New macro.
(emit-warnings): Handle the message-text and message-data fields.
(check-description-style): Adjust for changes to make-warning.
[check-trademarks, check-end-of-sentence-space): Adjust for changes to
make-warning.
(check-inputs-should-be-native, check-inputs-should-not-be-an-input-at-all,
check-synopsis-style, validate-uri, check-home-page, check-patch-file-names,
check-gnu-synopsis+description, 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): Adjust for changes to make-warning.
---
guix/scripts/lint.scm | 198 ++++++++++++++++++++++--------------------
1 file changed, 106 insertions(+), 92 deletions(-)
diff --git a/guix/scripts/lint.scm b/guix/scripts/lint.scm
index 1b08068669..4eb7e0e200 100644
--- a/guix/scripts/lint.scm
+++ b/guix/scripts/lint.scm
@@ -88,6 +88,8 @@
lint-warning?
lint-warning-package
lint-warning-message
+ lint-warning-message-text
+ lint-warning-message-data
lint-warning-location
%checkers
@@ -105,35 +107,49 @@
(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)))
+ (package lint-warning-package)
+ (message-text lint-warning-message-text)
+ (message-data lint-warning-message-data
+ (default '()))
+ (location lint-warning-location
+ (default #f)))
+
+(define (lint-warning-message warning)
+ (apply format #f
+ (G_ (lint-warning-message-text warning))
+ (lint-warning-message-data warning)))
(define (package-file package)
(location-file
(package-location package)))
-(define* (make-warning package message
- #:key field location)
+(define* (%make-warning package message-text
+ #:optional (message-data '())
+ #:key field location)
(make-lint-warning
package
- message
+ message-text
+ message-data
(or location
(package-field-location package field)
(package-location package))))
+(define-syntax make-warning
+ (syntax-rules (G_)
+ ((_ package (G_ message) rest ...)
+ (%make-warning package message rest ...))))
+
(define (emit-warnings warnings)
;; 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
;; provided MESSAGE.
(for-each
(match-lambda
- (($ <lint-warning> package message loc)
+ (($ <lint-warning> package message-text message-data loc)
(format (guix-warning-port) "~a: ~a@~a: ~a~%"
(location->string loc)
(package-name package) (package-version package)
- message)))
+ (apply format #f (G_ message-text) message-data))))
warnings))
\f
@@ -199,9 +215,9 @@ http://www.gnu.org/prep/standards/html_node/Trademarks.html."
((and (? number?) index)
(list
(make-warning package
- (format #f (G_ "description should not contain ~
+ (G_ "description should not contain ~
trademark sign '~a' at ~d")
- (string-ref description index) index)
+ (list (string-ref description index) index)
#:field 'description)))
(else '())))
@@ -242,10 +258,10 @@ trademark sign '~a' at ~d")
'()
(list
(make-warning package
- (format #f (G_ "sentences in description should be followed ~
+ (G_ "sentences in description should be followed ~
by two spaces; possible infraction~p at ~{~a~^, ~}")
- (length infractions)
- infractions)
+ (list (length infractions)
+ infractions)
#:field 'description)))))
(let ((description (package-description package)))
@@ -263,7 +279,8 @@ by two spaces; possible infraction~p at ~{~a~^, ~}")
(check-proper-start plain-description))))
(list
(make-warning package
- (format #f (G_ "invalid description: ~s") description)
+ (G_ "invalid description: ~s")
+ (list description)
#:field 'description)))))
(define (package-input-intersection inputs-to-check input-names)
@@ -308,8 +325,8 @@ of a package, and INPUT-NAMES, a list of package specifications such as
(map (lambda (input)
(make-warning
package
- (format #f (G_ "'~a' should probably be a native input")
- input)
+ (G_ "'~a' should probably be a native input")
+ (list input)
#:field 'inputs))
(package-input-intersection inputs input-names))))
@@ -323,9 +340,8 @@ of a package, and INPUT-NAMES, a list of package specifications such as
(map (lambda (input)
(make-warning
package
- (format #f
- (G_ "'~a' should probably not be an input at all")
- input)
+ (G_ "'~a' should probably not be an input at all")
+ (list input)
#:field 'inputs))
(package-input-intersection (package-direct-inputs package)
input-names))))
@@ -423,7 +439,9 @@ markup is valid return a plain-text version of SYNOPSIS, otherwise #f."
checks))
(invalid
(list
- (make-warning package (format #f (G_ "invalid synopsis: ~s") invalid)
+ (make-warning package
+ (G_ "invalid synopsis: ~s")
+ (list invalid)
#:field 'synopsis)))))
(define* (probe-uri uri #:key timeout)
@@ -540,64 +558,59 @@ PACKAGE mentionning the FIELD."
;; such malicious behavior.
(or (> length 1000)
(make-warning package
- (format #f
- (G_ "URI ~a returned \
+ (G_ "URI ~a returned \
suspiciously small file (~a bytes)")
- (uri->string uri)
- length)
+ (list (uri->string uri)
+ length)
#:field field)))
(_ #t)))
((= 301 (response-code argument))
(if (response-location argument)
(make-warning package
- (format #f (G_ "permanent redirect from ~a to ~a")
- (uri->string uri)
- (uri->string
- (response-location argument)))
+ (G_ "permanent redirect from ~a to ~a")
+ (list (uri->string uri)
+ (uri->string
+ (response-location argument)))
#:field field)
(make-warning package
- (format #f (G_ "invalid permanent redirect \
+ (G_ "invalid permanent redirect \
from ~a")
- (uri->string uri))
+ (list (uri->string uri))
#:field field)))
(else
(make-warning package
- (format #f
- (G_ "URI ~a not reachable: ~a (~s)")
- (uri->string uri)
- (response-code argument)
- (response-reason-phrase argument))
+ (G_ "URI ~a not reachable: ~a (~s)")
+ (list (uri->string uri)
+ (response-code argument)
+ (response-reason-phrase argument))
#:field field))))
((ftp-response)
(match argument
(('ok) #t)
(('error port command code message)
(make-warning package
- (format #f
- (G_ "URI ~a not reachable: ~a (~s)")
- (uri->string uri)
- code (string-trim-both message))
+ (G_ "URI ~a not reachable: ~a (~s)")
+ (list (uri->string uri)
+ code (string-trim-both message))
#:field field))))
((getaddrinfo-error)
(make-warning package
- (format #f
- (G_ "URI ~a domain not found: ~a")
- (uri->string uri)
- (gai-strerror (car argument)))
+ (G_ "URI ~a domain not found: ~a")
+ (list (uri->string uri)
+ (gai-strerror (car argument)))
#:field field))
((system-error)
(make-warning package
- (format #f
- (G_ "URI ~a unreachable: ~a")
- (uri->string uri)
- (strerror
- (system-error-errno
- (cons status argument))))
+ (G_ "URI ~a unreachable: ~a")
+ (list (uri->string uri)
+ (strerror
+ (system-error-errno
+ (cons status argument))))
#:field field))
((tls-certificate-error)
(make-warning package
- (format #f (G_ "TLS certificate error: ~a")
- (tls-certificate-error-string argument))
+ (G_ "TLS certificate error: ~a")
+ (list (tls-certificate-error-string argument))
#:field field))
((invalid-http-response gnutls-error)
;; Probably a misbehaving server; ignore.
@@ -627,8 +640,9 @@ from ~a")
#:field 'home-page))))
(else
(list
- (make-warning package (format #f (G_ "invalid home page URL: ~s")
- (package-home-page package))
+ (make-warning package
+ (G_ "invalid home page URL: ~s")
+ (list (package-home-page package))
#:field 'home-page))))))
(define %distro-directory
@@ -640,8 +654,10 @@ from ~a")
patch could not be found."
(guard (c ((message-condition? c) ;raised by 'search-patch'
(list
- (make-warning package (condition-message c)
- #:field 'patch-file-names))))
+ ;; Use %make-warning, as condition-mesasge is already
+ ;; translated.
+ (%make-warning package (condition-message c)
+ #:field 'patch-file-names))))
(define patches
(or (and=> (package-source package) origin-patches)
'()))
@@ -674,8 +690,8 @@ patch could not be found."
max)
(make-warning
package
- (format #f (G_ "~a: file name is too long")
- (basename patch))
+ (G_ "~a: file name is too long")
+ (list (basename patch))
#:field 'patch-file-names)
#f))
(_ #f))
@@ -716,8 +732,8 @@ descriptions maintained upstream."
(not (string=? upstream downstream))))
(list
(make-warning package
- (format #f (G_ "proposed synopsis: ~s~%")
- upstream)
+ (G_ "proposed synopsis: ~s~%")
+ (list upstream)
#:field 'synopsis))
'()))
@@ -730,9 +746,8 @@ descriptions maintained upstream."
(list
(make-warning
package
- (format #f
- (G_ "proposed description:~% \"~a\"~%")
- (fill-paragraph (escape-quotes upstream) 77 7))
+ (G_ "proposed description:~% \"~a\"~%")
+ (list (fill-paragraph (escape-quotes upstream) 77 7))
#:field 'description))
'()))))))
@@ -831,10 +846,10 @@ descriptions maintained upstream."
(loop rest))
(prefix
(make-warning package
- (format #f (G_ "URL should be \
+ (G_ "URL should be \
'mirror://~a/~a'")
- mirror-id
- (string-drop uri (string-length prefix)))
+ (list mirror-id
+ (string-drop uri (string-length prefix)))
#:field 'source)))))))
(let ((origin (package-source package)))
@@ -876,7 +891,8 @@ descriptions maintained upstream."
#f
(make-warning
package
- (format #f (G_ "URL should be '~a'") github-uri)
+ (G_ "URL should be '~a'")
+ (list github-uri)
#:field 'source)))))
(origin-uris origin))
'())))
@@ -888,14 +904,14 @@ descriptions maintained upstream."
(lambda ()
(guard (c ((store-protocol-error? c)
(make-warning package
- (format #f (G_ "failed to create ~a derivation: ~a")
- system
- (store-protocol-error-message c))))
+ (G_ "failed to create ~a derivation: ~a")
+ (list system
+ (store-protocol-error-message c))))
((message-condition? c)
(make-warning package
- (format #f (G_ "failed to create ~a derivation: ~a")
- system
- (condition-message c)))))
+ (G_ "failed to create ~a derivation: ~a")
+ (list system
+ (condition-message c)))))
(with-store store
;; Disable grafts since it can entail rebuilds.
(parameterize ((%graft? #f))
@@ -910,8 +926,8 @@ descriptions maintained upstream."
#:graft? #f)))))))
(lambda args
(make-warning package
- (format #f (G_ "failed to create ~a derivation: ~s")
- system args)))))
+ (G_ "failed to create ~a derivation: ~s")
+ (list system args)))))
(filter lint-warning?
(map try (package-supported-systems package))))
@@ -1001,15 +1017,15 @@ the NIST server non-fatal."
(list
(make-warning
package
- (format #f (G_ "probably vulnerable to ~a")
- (string-join (map vulnerability-id unpatched)
- ", "))))))))))
+ (G_ "probably vulnerable to ~a")
+ (list (string-join (map vulnerability-id unpatched)
+ ", "))))))))))
(define (check-for-updates package)
"Check if there is an update available for PACKAGE."
(match (with-networking-fail-safe
- (format #f (G_ "while retrieving upstream info for '~a'")
- (package-name package))
+ (G_ "while retrieving upstream info for '~a'")
+ (list (package-name package))
#f
(package-latest-release* package (force %updaters)))
((? upstream-source? source)
@@ -1017,8 +1033,8 @@ the NIST server non-fatal."
(package-version package))
(list
(make-warning package
- (format #f (G_ "can be upgraded to ~a")
- (upstream-source-version source))
+ (G_ "can be upgraded to ~a")
+ (list (upstream-source-version source))
#:field 'version))
'()))
(#f '()))) ; cannot find newer upstream release
@@ -1034,8 +1050,8 @@ the NIST server non-fatal."
(#f #t)
(index
(make-warning package
- (format #f (G_ "tabulation on line ~a, column ~a")
- line-number index)
+ (G_ "tabulation on line ~a, column ~a")
+ (list line-number index)
#:location
(location (package-file package)
line-number
@@ -1046,9 +1062,8 @@ the NIST server non-fatal."
(unless (or (string=? line (string-trim-right line))
(string=? line (string #\page)))
(make-warning package
- (format #f
- (G_ "trailing white space on line ~a")
- line-number)
+ (G_ "trailing white space on line ~a")
+ (list line-number)
#:location
(location (package-file package)
line-number
@@ -1061,8 +1076,8 @@ the NIST server non-fatal."
;; much noise.
(when (> (string-length line) 90)
(make-warning package
- (format #f (G_ "line ~a is way too long (~a characters)")
- line-number (string-length line))
+ (G_ "line ~a is way too long (~a characters)")
+ (list line-number (string-length line))
#:location
(location (package-file package)
line-number
@@ -1075,10 +1090,9 @@ the NIST server non-fatal."
"Emit a warning if LINE contains hanging parentheses."
(when (regexp-exec %hanging-paren-rx line)
(make-warning package
- (format #f
- (G_ "parentheses feel lonely, \
+ (G_ "parentheses feel lonely, \
move to the previous or next line")
- line-number)
+ (list line-number)
#:location
(location (package-file package)
line-number
--
2.22.0
^ permalink raw reply related [flat|nested] 37+ messages in thread
* [bug#35790] [PATCH 3/4] lint: Move the linting code to a different module.
2019-07-15 19:45 ` [bug#35790] [PATCH 1/4] scripts: lint: Handle warnings with a record type Christopher Baines
2019-07-15 19:45 ` [bug#35790] [PATCH 2/4] scripts: lint: Separate the message warning text and data Christopher Baines
@ 2019-07-15 19:45 ` Christopher Baines
2019-07-15 19:45 ` [bug#35790] [PATCH 4/4] lint: Separate checkers by dependence on the internet Christopher Baines
2 siblings, 0 replies; 37+ messages in thread
From: Christopher Baines @ 2019-07-15 19:45 UTC (permalink / raw)
To: 35790
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).
---
Makefile.am | 1 +
guix/lint.scm | 1222 +++++++++++++++++++++++++++++++++++++++++
guix/scripts/lint.scm | 1220 +---------------------------------------
po/guix/POTFILES.in | 1 +
tests/lint.scm | 2 +-
5 files changed, 1244 insertions(+), 1202 deletions(-)
create mode 100644 guix/lint.scm
diff --git a/Makefile.am b/Makefile.am
index bb7156458c..b63c55d784 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -98,6 +98,7 @@ MODULES = \
guix/self.scm \
guix/upstream.scm \
guix/licenses.scm \
+ guix/lint.scm \
guix/glob.scm \
guix/git.scm \
guix/graph.scm \
diff --git a/guix/lint.scm b/guix/lint.scm
new file mode 100644
index 0000000000..c2c0914958
--- /dev/null
+++ b/guix/lint.scm
@@ -0,0 +1,1222 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2014 Cyril Roelandt <tipecaml@gmail.com>
+;;; Copyright © 2014, 2015 Eric Bavier <bavier@member.fsf.org>
+;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2015, 2016 Mathieu Lirzin <mthl@gnu.org>
+;;; Copyright © 2016 Danny Milosavljevic <dannym+a@scratchpost.org>
+;;; Copyright © 2016 Hartmut Goebel <h.goebel@crazy-compilers.com>
+;;; Copyright © 2017 Alex Kost <alezost@gmail.com>
+;;; Copyright © 2017 Tobias Geerinckx-Rice <me@tobias.gr>
+;;; Copyright © 2017, 2018 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/>.
+
+(define-module (guix lint)
+ #:use-module ((guix store) #:hide (close-connection))
+ #:use-module (guix base32)
+ #:use-module (guix diagnostics)
+ #:use-module (guix download)
+ #:use-module (guix ftp-client)
+ #:use-module (guix http-client)
+ #:use-module (guix packages)
+ #:use-module (guix i18n)
+ #:use-module (guix licenses)
+ #:use-module (guix records)
+ #:use-module (guix grafts)
+ #:use-module (guix upstream)
+ #:use-module (guix utils)
+ #:use-module (guix memoization)
+ #:use-module (guix scripts)
+ #:use-module ((guix ui) #:select (texi->plain-text fill-paragraph))
+ #:use-module (guix gnu-maintenance)
+ #:use-module (guix monads)
+ #:use-module (guix cve)
+ #:use-module (gnu packages)
+ #:use-module (ice-9 match)
+ #:use-module (ice-9 regex)
+ #:use-module (ice-9 format)
+ #:use-module (web client)
+ #:use-module (web uri)
+ #:use-module ((guix build download)
+ #:select (maybe-expand-mirrors
+ (open-connection-for-uri
+ . guix:open-connection-for-uri)
+ close-connection))
+ #:use-module (web request)
+ #:use-module (web response)
+ #:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-6) ;Unicode string ports
+ #:use-module (srfi srfi-9)
+ #:use-module (srfi srfi-11)
+ #:use-module (srfi srfi-26)
+ #:use-module (srfi srfi-34)
+ #:use-module (srfi srfi-35)
+ #:use-module (ice-9 rdelim)
+ #:export (check-description-style
+ check-inputs-should-be-native
+ check-inputs-should-not-be-an-input-at-all
+ check-patch-file-names
+ check-synopsis-style
+ check-derivation
+ check-home-page
+ check-source
+ check-source-file-name
+ check-source-unstable-tarball
+ check-mirror-url
+ check-github-url
+ check-license
+ check-vulnerabilities
+ check-for-updates
+ check-formatting
+
+ lint-warning
+ lint-warning?
+ lint-warning-package
+ lint-warning-message
+ lint-warning-message-text
+ lint-warning-message-data
+ lint-warning-location
+
+ %checkers
+
+ lint-checker
+ lint-checker?
+ lint-checker-name
+ lint-checker-description
+ lint-checker-check))
+
+\f
+;;;
+;;; Warnings
+;;;
+
+(define-record-type* <lint-warning>
+ lint-warning make-lint-warning
+ lint-warning?
+ (package lint-warning-package)
+ (message-text lint-warning-message-text)
+ (message-data lint-warning-message-data
+ (default '()))
+ (location lint-warning-location
+ (default #f)))
+
+(define (lint-warning-message warning)
+ (apply format #f
+ (G_ (lint-warning-message-text warning))
+ (lint-warning-message-data warning)))
+
+(define (package-file package)
+ (location-file
+ (package-location package)))
+
+(define* (%make-warning package message-text
+ #:optional (message-data '())
+ #:key field location)
+ (make-lint-warning
+ package
+ message-text
+ message-data
+ (or location
+ (package-field-location package field)
+ (package-location package))))
+
+(define-syntax make-warning
+ (syntax-rules (G_)
+ ((_ package (G_ message) rest ...)
+ (%make-warning package message rest ...))))
+
+\f
+;;;
+;;; Checkers
+;;;
+
+(define-record-type* <lint-checker>
+ lint-checker make-lint-checker
+ lint-checker?
+ ;; TODO: add a 'certainty' field that shows how confident we are in the
+ ;; checker. Then allow users to only run checkers that have a certain
+ ;; 'certainty' level.
+ (name lint-checker-name)
+ (description lint-checker-description)
+ (check lint-checker-check))
+
+(define (properly-starts-sentence? s)
+ (string-match "^[(\"'`[:upper:][:digit:]]" s))
+
+(define (starts-with-abbreviation? s)
+ "Return #t if S starts with what looks like an abbreviation or acronym."
+ (string-match "^[A-Z][A-Z0-9]+\\>" s))
+
+(define %quoted-identifier-rx
+ ;; A quoted identifier, like 'this'.
+ (make-regexp "['`][[:graph:]]+'"))
+
+(define (check-description-style package)
+ ;; Emit a warning if stylistic issues are found in the description of PACKAGE.
+ (define (check-not-empty description)
+ (if (string-null? description)
+ (list
+ (make-warning package
+ (G_ "description should not be empty")
+ #:field 'description))
+ '()))
+
+ (define (check-texinfo-markup description)
+ "Check that DESCRIPTION can be parsed as a Texinfo fragment. If the
+markup is valid return a plain-text version of DESCRIPTION, otherwise #f."
+ (catch #t
+ (lambda () (texi->plain-text description))
+ (lambda (keys . args)
+ (make-warning package
+ (G_ "Texinfo markup in description is invalid")
+ #:field 'description))))
+
+ (define (check-trademarks description)
+ "Check that DESCRIPTION does not contain '™' or '®' characters. See
+http://www.gnu.org/prep/standards/html_node/Trademarks.html."
+ (match (string-index description (char-set #\™ #\®))
+ ((and (? number?) index)
+ (list
+ (make-warning package
+ (G_ "description should not contain ~
+trademark sign '~a' at ~d")
+ (list (string-ref description index) index)
+ #:field 'description)))
+ (else '())))
+
+ (define (check-quotes description)
+ "Check whether DESCRIPTION contains single quotes and suggest @code."
+ (if (regexp-exec %quoted-identifier-rx description)
+ (list
+ (make-warning package
+ ;; TRANSLATORS: '@code' is Texinfo markup and must be kept
+ ;; as is.
+ (G_ "use @code or similar ornament instead of quotes")
+ #:field 'description))
+ '()))
+
+ (define (check-proper-start description)
+ (if (or (string-null? description)
+ (properly-starts-sentence? description)
+ (string-prefix-ci? (package-name package) description))
+ '()
+ (list
+ (make-warning
+ package
+ (G_ "description should start with an upper-case letter or digit")
+ #:field 'description))))
+
+ (define (check-end-of-sentence-space description)
+ "Check that an end-of-sentence period is followed by two spaces."
+ (let ((infractions
+ (reverse (fold-matches
+ "\\. [A-Z]" description '()
+ (lambda (m r)
+ ;; Filter out matches of common abbreviations.
+ (if (find (lambda (s)
+ (string-suffix-ci? s (match:prefix m)))
+ '("i.e" "e.g" "a.k.a" "resp"))
+ r (cons (match:start m) r)))))))
+ (if (null? infractions)
+ '()
+ (list
+ (make-warning package
+ (G_ "sentences in description should be followed ~
+by two spaces; possible infraction~p at ~{~a~^, ~}")
+ (list (length infractions)
+ infractions)
+ #:field 'description)))))
+
+ (let ((description (package-description package)))
+ (if (string? description)
+ (append
+ (check-not-empty description)
+ (check-quotes description)
+ (check-trademarks description)
+ ;; Use raw description for this because Texinfo rendering
+ ;; automatically fixes end of sentence space.
+ (check-end-of-sentence-space description)
+ (match (check-texinfo-markup description)
+ ((and warning (? lint-warning?)) (list warning))
+ (plain-description
+ (check-proper-start plain-description))))
+ (list
+ (make-warning package
+ (G_ "invalid description: ~s")
+ (list description)
+ #:field 'description)))))
+
+(define (package-input-intersection inputs-to-check input-names)
+ "Return the intersection between INPUTS-TO-CHECK, the list of input tuples
+of a package, and INPUT-NAMES, a list of package specifications such as
+\"glib:bin\"."
+ (match inputs-to-check
+ (((labels packages . outputs) ...)
+ (filter-map (lambda (package output)
+ (and (package? package)
+ (let ((input (string-append
+ (package-name package)
+ (if (> (length output) 0)
+ (string-append ":" (car output))
+ ""))))
+ (and (member input input-names)
+ input))))
+ packages outputs))))
+
+(define (check-inputs-should-be-native package)
+ ;; Emit a warning if some inputs of PACKAGE are likely to belong to its
+ ;; native inputs.
+ (let ((inputs (package-inputs package))
+ (input-names
+ '("pkg-config"
+ "cmake"
+ "extra-cmake-modules"
+ "glib:bin"
+ "intltool"
+ "itstool"
+ "qttools"
+ "python-coverage" "python2-coverage"
+ "python-cython" "python2-cython"
+ "python-docutils" "python2-docutils"
+ "python-mock" "python2-mock"
+ "python-nose" "python2-nose"
+ "python-pbr" "python2-pbr"
+ "python-pytest" "python2-pytest"
+ "python-pytest-cov" "python2-pytest-cov"
+ "python-setuptools-scm" "python2-setuptools-scm"
+ "python-sphinx" "python2-sphinx")))
+ (map (lambda (input)
+ (make-warning
+ package
+ (G_ "'~a' should probably be a native input")
+ (list input)
+ #:field 'inputs))
+ (package-input-intersection inputs input-names))))
+
+(define (check-inputs-should-not-be-an-input-at-all package)
+ ;; Emit a warning if some inputs of PACKAGE are likely to should not be
+ ;; an input at all.
+ (let ((input-names '("python-setuptools"
+ "python2-setuptools"
+ "python-pip"
+ "python2-pip")))
+ (map (lambda (input)
+ (make-warning
+ package
+ (G_ "'~a' should probably not be an input at all")
+ (list input)
+ #:field 'inputs))
+ (package-input-intersection (package-direct-inputs package)
+ input-names))))
+
+(define (package-name-regexp package)
+ "Return a regexp that matches PACKAGE's name as a word at the beginning of a
+line."
+ (make-regexp (string-append "^" (regexp-quote (package-name package))
+ "\\>")
+ regexp/icase))
+
+(define (check-synopsis-style package)
+ ;; Emit a warning if stylistic issues are found in the synopsis of PACKAGE.
+ (define (check-final-period synopsis)
+ ;; Synopsis should not end with a period, except for some special cases.
+ (if (and (string-suffix? "." synopsis)
+ (not (string-suffix? "etc." synopsis)))
+ (list
+ (make-warning package
+ (G_ "no period allowed at the end of the synopsis")
+ #:field 'synopsis))
+ '()))
+
+ (define check-start-article
+ ;; 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>.
+ (if (false-if-exception (gnu-package? package))
+ (const '())
+ (lambda (synopsis)
+ (if (or (string-prefix-ci? "A " synopsis)
+ (string-prefix-ci? "An " synopsis))
+ (list
+ (make-warning package
+ (G_ "no article allowed at the beginning of \
+the synopsis")
+ #:field 'synopsis))
+ '()))))
+
+ (define (check-synopsis-length synopsis)
+ (if (>= (string-length synopsis) 80)
+ (list
+ (make-warning package
+ (G_ "synopsis should be less than 80 characters long")
+ #:field 'synopsis))
+ '()))
+
+ (define (check-proper-start synopsis)
+ (if (properly-starts-sentence? synopsis)
+ '()
+ (list
+ (make-warning package
+ (G_ "synopsis should start with an upper-case letter or digit")
+ #:field 'synopsis))))
+
+ (define (check-start-with-package-name synopsis)
+ (if (and (regexp-exec (package-name-regexp package) synopsis)
+ (not (starts-with-abbreviation? synopsis)))
+ (list
+ (make-warning package
+ (G_ "synopsis should not start with the package name")
+ #:field 'synopsis))
+ '()))
+
+ (define (check-texinfo-markup synopsis)
+ "Check that SYNOPSIS can be parsed as a Texinfo fragment. If the
+markup is valid return a plain-text version of SYNOPSIS, otherwise #f."
+ (catch #t
+ (lambda ()
+ (texi->plain-text synopsis)
+ '())
+ (lambda (keys . args)
+ (list
+ (make-warning package
+ (G_ "Texinfo markup in synopsis is invalid")
+ #:field 'synopsis)))))
+
+ (define checks
+ (list check-proper-start
+ check-final-period
+ check-start-article
+ check-start-with-package-name
+ check-synopsis-length
+ check-texinfo-markup))
+
+ (match (package-synopsis package)
+ (""
+ (list
+ (make-warning package
+ (G_ "synopsis should not be empty")
+ #:field 'synopsis)))
+ ((? string? synopsis)
+ (append-map
+ (lambda (proc)
+ (proc synopsis))
+ checks))
+ (invalid
+ (list
+ (make-warning package
+ (G_ "invalid synopsis: ~s")
+ (list invalid)
+ #:field 'synopsis)))))
+
+(define* (probe-uri uri #:key timeout)
+ "Probe URI, a URI object, and return two values: a symbol denoting the
+probing status, such as 'http-response' when we managed to get an HTTP
+response from URI, and additional details, such as the actual HTTP response.
+
+TIMEOUT is the maximum number of seconds (possibly an inexact number) to wait
+for connections to complete; when TIMEOUT is #f, wait as long as needed."
+ (define headers
+ '((User-Agent . "GNU Guile")
+ (Accept . "*/*")))
+
+ (let loop ((uri uri)
+ (visited '()))
+ (match (uri-scheme uri)
+ ((or 'http 'https)
+ (catch #t
+ (lambda ()
+ (let ((port (guix:open-connection-for-uri
+ uri #:timeout timeout))
+ (request (build-request uri #:headers headers)))
+ (define response
+ (dynamic-wind
+ (const #f)
+ (lambda ()
+ (write-request request port)
+ (force-output port)
+ (read-response port))
+ (lambda ()
+ (close-connection port))))
+
+ (case (response-code response)
+ ((302 ; found (redirection)
+ 303 ; see other
+ 307 ; temporary redirection
+ 308) ; permanent redirection
+ (let ((location (response-location response)))
+ (if (or (not location) (member location visited))
+ (values 'http-response response)
+ (loop location (cons location visited))))) ;follow the redirect
+ ((301) ; moved permanently
+ (let ((location (response-location response)))
+ ;; Return RESPONSE, unless the final response as we follow
+ ;; redirects is not 200.
+ (if location
+ (let-values (((status response2)
+ (loop location (cons location visited))))
+ (case status
+ ((http-response)
+ (values 'http-response
+ (if (= 200 (response-code response2))
+ response
+ response2)))
+ (else
+ (values status response2))))
+ (values 'http-response response)))) ;invalid redirect
+ (else
+ (values 'http-response response)))))
+ (lambda (key . args)
+ (case key
+ ((bad-header bad-header-component)
+ ;; This can happen if the server returns an invalid HTTP header,
+ ;; as is the case with the 'Date' header at sqlite.org.
+ (values 'invalid-http-response #f))
+ ((getaddrinfo-error system-error
+ gnutls-error tls-certificate-error)
+ (values key args))
+ (else
+ (apply throw key args))))))
+ ('ftp
+ (catch #t
+ (lambda ()
+ (let ((conn (ftp-open (uri-host uri) #:timeout timeout)))
+ (define response
+ (dynamic-wind
+ (const #f)
+ (lambda ()
+ (ftp-chdir conn (dirname (uri-path uri)))
+ (ftp-size conn (basename (uri-path uri))))
+ (lambda ()
+ (ftp-close conn))))
+ (values 'ftp-response '(ok))))
+ (lambda (key . args)
+ (case key
+ ((ftp-error)
+ (values 'ftp-response `(error ,@args)))
+ ((getaddrinfo-error system-error gnutls-error)
+ (values key args))
+ (else
+ (apply throw key args))))))
+ (_
+ (values 'unknown-protocol #f)))))
+
+(define (tls-certificate-error-string args)
+ "Return a string explaining the 'tls-certificate-error' arguments ARGS."
+ (call-with-output-string
+ (lambda (port)
+ (print-exception port #f
+ 'tls-certificate-error args))))
+
+(define (validate-uri uri package field)
+ "Return #t if the given URI can be reached, otherwise return a warning for
+PACKAGE mentionning the FIELD."
+ (let-values (((status argument)
+ (probe-uri uri #:timeout 3))) ;wait at most 3 seconds
+ (case status
+ ((http-response)
+ (cond ((= 200 (response-code argument))
+ (match (response-content-length argument)
+ ((? number? length)
+ ;; As of July 2016, SourceForge returns 200 (instead of 404)
+ ;; with a small HTML page upon failure. Attempt to detect
+ ;; such malicious behavior.
+ (or (> length 1000)
+ (make-warning package
+ (G_ "URI ~a returned \
+suspiciously small file (~a bytes)")
+ (list (uri->string uri)
+ length)
+ #:field field)))
+ (_ #t)))
+ ((= 301 (response-code argument))
+ (if (response-location argument)
+ (make-warning package
+ (G_ "permanent redirect from ~a to ~a")
+ (list (uri->string uri)
+ (uri->string
+ (response-location argument)))
+ #:field field)
+ (make-warning package
+ (G_ "invalid permanent redirect \
+from ~a")
+ (list (uri->string uri))
+ #:field field)))
+ (else
+ (make-warning package
+ (G_ "URI ~a not reachable: ~a (~s)")
+ (list (uri->string uri)
+ (response-code argument)
+ (response-reason-phrase argument))
+ #:field field))))
+ ((ftp-response)
+ (match argument
+ (('ok) #t)
+ (('error port command code message)
+ (make-warning package
+ (G_ "URI ~a not reachable: ~a (~s)")
+ (list (uri->string uri)
+ code (string-trim-both message))
+ #:field field))))
+ ((getaddrinfo-error)
+ (make-warning package
+ (G_ "URI ~a domain not found: ~a")
+ (list (uri->string uri)
+ (gai-strerror (car argument)))
+ #:field field))
+ ((system-error)
+ (make-warning package
+ (G_ "URI ~a unreachable: ~a")
+ (list (uri->string uri)
+ (strerror
+ (system-error-errno
+ (cons status argument))))
+ #:field field))
+ ((tls-certificate-error)
+ (make-warning package
+ (G_ "TLS certificate error: ~a")
+ (list (tls-certificate-error-string argument))
+ #:field field))
+ ((invalid-http-response gnutls-error)
+ ;; Probably a misbehaving server; ignore.
+ #f)
+ ((unknown-protocol) ;nothing we can do
+ #f)
+ (else
+ (error "internal linter error" status)))))
+
+(define (check-home-page package)
+ "Emit a warning if PACKAGE has an invalid 'home-page' field, or if that
+'home-page' is not reachable."
+ (let ((uri (and=> (package-home-page package) string->uri)))
+ (cond
+ ((uri? uri)
+ (match (validate-uri uri package 'home-page)
+ ((and (? lint-warning? warning) warning)
+ (list warning))
+ (_ '())))
+ ((not (package-home-page package))
+ (if (or (string-contains (package-name package) "bootstrap")
+ (string=? (package-name package) "ld-wrapper"))
+ '()
+ (list
+ (make-warning package
+ (G_ "invalid value for home page")
+ #:field 'home-page))))
+ (else
+ (list
+ (make-warning package
+ (G_ "invalid home page URL: ~s")
+ (list (package-home-page package))
+ #:field 'home-page))))))
+
+(define %distro-directory
+ (mlambda ()
+ (dirname (search-path %load-path "gnu.scm"))))
+
+(define (check-patch-file-names package)
+ "Emit a warning if the patches requires by PACKAGE are badly named or if the
+patch could not be found."
+ (guard (c ((message-condition? c) ;raised by 'search-patch'
+ (list
+ ;; Use %make-warning, as condition-mesasge is already
+ ;; translated.
+ (%make-warning package (condition-message c)
+ #:field 'patch-file-names))))
+ (define patches
+ (or (and=> (package-source package) origin-patches)
+ '()))
+
+ (append
+ (if (every (match-lambda ;patch starts with package name?
+ ((? string? patch)
+ (and=> (string-contains (basename patch)
+ (package-name package))
+ zero?))
+ (_ #f)) ;must be an <origin> or something like that.
+ patches)
+ '()
+ (list
+ (make-warning
+ package
+ (G_ "file names of patches should start with the package name")
+ #:field 'patch-file-names)))
+
+ ;; Check whether we're reaching tar's maximum file name length.
+ (let ((prefix (string-length (%distro-directory)))
+ (margin (string-length "guix-0.13.0-10-123456789/"))
+ (max 99))
+ (filter-map (match-lambda
+ ((? string? patch)
+ (if (> (+ margin (if (string-prefix? (%distro-directory)
+ patch)
+ (- (string-length patch) prefix)
+ (string-length patch)))
+ max)
+ (make-warning
+ package
+ (G_ "~a: file name is too long")
+ (list (basename patch))
+ #:field 'patch-file-names)
+ #f))
+ (_ #f))
+ patches)))))
+
+(define (escape-quotes str)
+ "Replace any quote character in STR by an escaped quote character."
+ (list->string
+ (string-fold-right (lambda (chr result)
+ (match chr
+ (#\" (cons* #\\ #\"result))
+ (_ (cons chr result))))
+ '()
+ str)))
+
+(define official-gnu-packages*
+ (mlambda ()
+ "A memoizing version of 'official-gnu-packages' that returns the empty
+list when something goes wrong, such as a networking issue."
+ (let ((gnus (false-if-exception (official-gnu-packages))))
+ (or gnus '()))))
+
+(define (check-gnu-synopsis+description package)
+ "Make sure that, if PACKAGE is a GNU package, it uses the synopsis and
+descriptions maintained upstream."
+ (match (find (lambda (descriptor)
+ (string=? (gnu-package-name descriptor)
+ (package-name package)))
+ (official-gnu-packages*))
+ (#f ;not a GNU package, so nothing to do
+ '())
+ (descriptor ;a genuine GNU package
+ (append
+ (let ((upstream (gnu-package-doc-summary descriptor))
+ (downstream (package-synopsis package)))
+ (if (and upstream
+ (or (not (string? downstream))
+ (not (string=? upstream downstream))))
+ (list
+ (make-warning package
+ (G_ "proposed synopsis: ~s~%")
+ (list upstream)
+ #:field 'synopsis))
+ '()))
+
+ (let ((upstream (gnu-package-doc-description descriptor))
+ (downstream (package-description package)))
+ (if (and upstream
+ (or (not (string? downstream))
+ (not (string=? (fill-paragraph upstream 100)
+ (fill-paragraph downstream 100)))))
+ (list
+ (make-warning
+ package
+ (G_ "proposed description:~% \"~a\"~%")
+ (list (fill-paragraph (escape-quotes upstream) 77 7))
+ #:field 'description))
+ '()))))))
+
+(define (origin-uris origin)
+ "Return the list of URIs (strings) for ORIGIN."
+ (match (origin-uri origin)
+ ((? string? uri)
+ (list uri))
+ ((uris ...)
+ uris)))
+
+(define (check-source package)
+ "Emit a warning if PACKAGE has an invalid 'source' field, or if that
+'source' is not reachable."
+ (define (warnings-for-uris uris)
+ (filter lint-warning?
+ (map
+ (lambda (uri)
+ (validate-uri uri package 'source))
+ (append-map (cut maybe-expand-mirrors <> %mirrors)
+ uris))))
+
+ (let ((origin (package-source package)))
+ (if (and origin
+ (eqv? (origin-method origin) url-fetch))
+ (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.
+ (if (eq? (length uris) (length warnings))
+ ;; When everything fails, report all of WARNINGS, otherwise don't
+ ;; report anything.
+ ;;
+ ;; XXX: Ideally we'd still allow warnings to be raised if *some*
+ ;; URIs are unreachable, but distinguish that from the error case
+ ;; where *all* the URIs are unreachable.
+ (cons*
+ (make-warning package
+ (G_ "all the source URIs are unreachable:")
+ #:field 'source)
+ warnings)
+ '()))
+ '())))
+
+(define (check-source-file-name package)
+ "Emit a warning if PACKAGE's origin has no meaningful file name."
+ (define (origin-file-name-valid? origin)
+ ;; Return #f if the source file name contains only a version or is #f;
+ ;; indicates that the origin needs a 'file-name' field.
+ (let ((file-name (origin-actual-file-name origin))
+ (version (package-version package)))
+ (and file-name
+ ;; Common in many projects is for the filename to start
+ ;; with a "v" followed by the version,
+ ;; e.g. "v3.2.0.tar.gz".
+ (not (string-match (string-append "^v?" version) file-name)))))
+
+ (let ((origin (package-source package)))
+ (if (or (not origin) (origin-file-name-valid? origin))
+ '()
+ (list
+ (make-warning package
+ (G_ "the source file name should contain the package name")
+ #:field 'source)))))
+
+(define (check-source-unstable-tarball package)
+ "Emit a warning if PACKAGE's source is an autogenerated tarball."
+ (define (check-source-uri uri)
+ (if (and (string=? (uri-host (string->uri uri)) "github.com")
+ (match (split-and-decode-uri-path
+ (uri-path (string->uri uri)))
+ ((_ _ "archive" _ ...) #t)
+ (_ #f)))
+ (make-warning package
+ (G_ "the source URI should not be an autogenerated tarball")
+ #:field 'source)
+ #f))
+
+ (let ((origin (package-source package)))
+ (if (and (origin? origin)
+ (eqv? (origin-method origin) url-fetch))
+ (filter-map check-source-uri
+ (origin-uris origin))
+ '())))
+
+(define (check-mirror-url package)
+ "Check whether PACKAGE uses source URLs that should be 'mirror://'."
+ (define (check-mirror-uri uri) ;XXX: could be optimized
+ (let loop ((mirrors %mirrors))
+ (match mirrors
+ (()
+ #f)
+ (((mirror-id mirror-urls ...) rest ...)
+ (match (find (cut string-prefix? <> uri) mirror-urls)
+ (#f
+ (loop rest))
+ (prefix
+ (make-warning package
+ (G_ "URL should be \
+'mirror://~a/~a'")
+ (list mirror-id
+ (string-drop uri (string-length prefix)))
+ #:field 'source)))))))
+
+ (let ((origin (package-source package)))
+ (if (and (origin? origin)
+ (eqv? (origin-method origin) url-fetch))
+ (let ((uris (origin-uris origin)))
+ (filter-map check-mirror-uri uris))
+ '())))
+
+(define* (check-github-url package #:key (timeout 3))
+ "Check whether PACKAGE uses source URLs that redirect to GitHub."
+ (define (follow-redirect url)
+ (let* ((uri (string->uri url))
+ (port (guix:open-connection-for-uri uri #:timeout timeout))
+ (response (http-head uri #:port port)))
+ (close-port port)
+ (case (response-code response)
+ ((301 302)
+ (uri->string (assoc-ref (response-headers response) 'location)))
+ (else #f))))
+
+ (define (follow-redirects-to-github uri)
+ (cond
+ ((string-prefix? "https://github.com/" uri) uri)
+ ((string-prefix? "http" uri)
+ (and=> (follow-redirect uri) follow-redirects-to-github))
+ ;; Do not attempt to follow redirects on URIs other than http and https
+ ;; (such as mirror, file)
+ (else #f)))
+
+ (let ((origin (package-source package)))
+ (if (and (origin? origin)
+ (eqv? (origin-method origin) url-fetch))
+ (filter-map
+ (lambda (uri)
+ (and=> (follow-redirects-to-github uri)
+ (lambda (github-uri)
+ (if (string=? github-uri uri)
+ #f
+ (make-warning
+ package
+ (G_ "URL should be '~a'")
+ (list github-uri)
+ #:field 'source)))))
+ (origin-uris origin))
+ '())))
+
+(define (check-derivation package)
+ "Emit a warning if we fail to compile PACKAGE to a derivation."
+ (define (try system)
+ (catch #t
+ (lambda ()
+ (guard (c ((store-protocol-error? c)
+ (make-warning package
+ (G_ "failed to create ~a derivation: ~a")
+ (list system
+ (store-protocol-error-message c))))
+ ((message-condition? c)
+ (make-warning package
+ (G_ "failed to create ~a derivation: ~a")
+ (list system
+ (condition-message c)))))
+ (with-store store
+ ;; Disable grafts since it can entail rebuilds.
+ (parameterize ((%graft? #f))
+ (package-derivation store package system #:graft? #f)
+
+ ;; If there's a replacement, make sure we can compute its
+ ;; derivation.
+ (match (package-replacement package)
+ (#f #t)
+ (replacement
+ (package-derivation store replacement system
+ #:graft? #f)))))))
+ (lambda args
+ (make-warning package
+ (G_ "failed to create ~a derivation: ~s")
+ (list system args)))))
+
+ (filter lint-warning?
+ (map try (package-supported-systems package))))
+
+(define (check-license package)
+ "Warn about type errors of the 'license' field of PACKAGE."
+ (match (package-license package)
+ ((or (? license?)
+ ((? license?) ...))
+ '())
+ (x
+ (list
+ (make-warning package (G_ "invalid license field")
+ #:field 'license)))))
+
+(define (call-with-networking-fail-safe message error-value proc)
+ "Call PROC catching any network-related errors. Upon a networking error,
+display a message including MESSAGE and return ERROR-VALUE."
+ (guard (c ((http-get-error? c)
+ (warning (G_ "~a: HTTP GET error for ~a: ~a (~s)~%")
+ message
+ (uri->string (http-get-error-uri c))
+ (http-get-error-code c)
+ (http-get-error-reason c))
+ error-value))
+ (catch #t
+ proc
+ (match-lambda*
+ (('getaddrinfo-error errcode)
+ (warning (G_ "~a: host lookup failure: ~a~%")
+ message
+ (gai-strerror errcode))
+ error-value)
+ (('tls-certificate-error args ...)
+ (warning (G_ "~a: TLS certificate error: ~a")
+ message
+ (tls-certificate-error-string args))
+ error-value)
+ (args
+ (apply throw args))))))
+
+(define-syntax-rule (with-networking-fail-safe message error-value exp ...)
+ (call-with-networking-fail-safe message error-value
+ (lambda () exp ...)))
+
+(define (current-vulnerabilities*)
+ "Like 'current-vulnerabilities', but return the empty list upon networking
+or HTTP errors. This allows network-less operation and makes problems with
+the NIST server non-fatal."
+ (with-networking-fail-safe (G_ "while retrieving CVE vulnerabilities")
+ '()
+ (current-vulnerabilities)))
+
+(define package-vulnerabilities
+ (let ((lookup (delay (vulnerabilities->lookup-proc
+ (current-vulnerabilities*)))))
+ (lambda (package)
+ "Return a list of vulnerabilities affecting PACKAGE."
+ ;; First we retrieve the Common Platform Enumeration (CPE) name and
+ ;; version for PACKAGE, then we can pass them to LOOKUP.
+ (let ((name (or (assoc-ref (package-properties package)
+ 'cpe-name)
+ (package-name package)))
+ (version (or (assoc-ref (package-properties package)
+ 'cpe-version)
+ (package-version package))))
+ ((force lookup) name version)))))
+
+(define (check-vulnerabilities package)
+ "Check for known vulnerabilities for PACKAGE."
+ (let ((package (or (package-replacement package) package)))
+ (match (package-vulnerabilities package)
+ (()
+ '())
+ ((vulnerabilities ...)
+ (let* ((patched (package-patched-vulnerabilities package))
+ (known-safe (or (assq-ref (package-properties package)
+ 'lint-hidden-cve)
+ '()))
+ (unpatched (remove (lambda (vuln)
+ (let ((id (vulnerability-id vuln)))
+ (or (member id patched)
+ (member id known-safe))))
+ vulnerabilities)))
+ (if (null? unpatched)
+ '()
+ (list
+ (make-warning
+ package
+ (G_ "probably vulnerable to ~a")
+ (list (string-join (map vulnerability-id unpatched)
+ ", "))))))))))
+
+(define (check-for-updates package)
+ "Check if there is an update available for PACKAGE."
+ (match (with-networking-fail-safe
+ (G_ "while retrieving upstream info for '~a'")
+ (list (package-name package))
+ #f
+ (package-latest-release* package (force %updaters)))
+ ((? upstream-source? source)
+ (if (version>? (upstream-source-version source)
+ (package-version package))
+ (list
+ (make-warning package
+ (G_ "can be upgraded to ~a")
+ (list (upstream-source-version source))
+ #:field 'version))
+ '()))
+ (#f '()))) ; cannot find newer upstream release
+
+\f
+;;;
+;;; Source code formatting.
+;;;
+
+(define (report-tabulations package line line-number)
+ "Warn about tabulations found in LINE."
+ (match (string-index line #\tab)
+ (#f #t)
+ (index
+ (make-warning package
+ (G_ "tabulation on line ~a, column ~a")
+ (list line-number index)
+ #:location
+ (location (package-file package)
+ line-number
+ index)))))
+
+(define (report-trailing-white-space package line line-number)
+ "Warn about trailing white space in LINE."
+ (unless (or (string=? line (string-trim-right line))
+ (string=? line (string #\page)))
+ (make-warning package
+ (G_ "trailing white space on line ~a")
+ (list line-number)
+ #:location
+ (location (package-file package)
+ line-number
+ 0))))
+
+(define (report-long-line package line line-number)
+ "Emit a warning if LINE is too long."
+ ;; Note: We don't warn at 80 characters because sometimes hashes and URLs
+ ;; make it hard to fit within that limit and we want to avoid making too
+ ;; much noise.
+ (when (> (string-length line) 90)
+ (make-warning package
+ (G_ "line ~a is way too long (~a characters)")
+ (list line-number (string-length line))
+ #:location
+ (location (package-file package)
+ line-number
+ 0))))
+
+(define %hanging-paren-rx
+ (make-regexp "^[[:blank:]]*[()]+[[:blank:]]*$"))
+
+(define (report-lone-parentheses package line line-number)
+ "Emit a warning if LINE contains hanging parentheses."
+ (when (regexp-exec %hanging-paren-rx line)
+ (make-warning package
+ (G_ "parentheses feel lonely, \
+move to the previous or next line")
+ (list line-number)
+ #:location
+ (location (package-file package)
+ line-number
+ 0))))
+
+(define %formatting-reporters
+ ;; List of procedures that report formatting issues. These are not separate
+ ;; checkers because they would need to re-read the file.
+ (list report-tabulations
+ report-trailing-white-space
+ report-long-line
+ report-lone-parentheses))
+
+(define* (report-formatting-issues package file starting-line
+ #:key (reporters %formatting-reporters))
+ "Report white-space issues in FILE starting from STARTING-LINE, and report
+them for PACKAGE."
+ (define (sexp-last-line port)
+ ;; Return the last line of the sexp read from PORT or an estimate thereof.
+ (define &failure (list 'failure))
+
+ (let ((start (ftell port))
+ (start-line (port-line port))
+ (sexp (catch 'read-error
+ (lambda () (read port))
+ (const &failure))))
+ (let ((line (port-line port)))
+ (seek port start SEEK_SET)
+ (set-port-line! port start-line)
+ (if (eq? sexp &failure)
+ (+ start-line 60) ;conservative estimate
+ line))))
+
+ (call-with-input-file file
+ (lambda (port)
+ (let loop ((line-number 1)
+ (last-line #f)
+ (warnings '()))
+ (let ((line (read-line port)))
+ (if (or (eof-object? line)
+ (and last-line (> line-number last-line)))
+ warnings
+ (if (and (= line-number starting-line)
+ (not last-line))
+ (loop (+ 1 line-number)
+ (+ 1 (sexp-last-line port))
+ warnings)
+ (loop (+ 1 line-number)
+ last-line
+ (append
+ warnings
+ (if (< line-number starting-line)
+ '()
+ (filter
+ lint-warning?
+ (map (lambda (report)
+ (report package line line-number))
+ reporters))))))))))))
+
+(define (check-formatting package)
+ "Check the formatting of the source code of PACKAGE."
+ (let ((location (package-location package)))
+ (if location
+ (and=> (search-path %load-path (location-file location))
+ (lambda (file)
+ ;; Report issues starting from the line before the 'package'
+ ;; form, which usually contains the 'define' form.
+ (report-formatting-issues package file
+ (- (location-line location) 1))))
+ '())))
+
+\f
+;;;
+;;; List of checkers.
+;;;
+
+(define %checkers
+ (list
+ (lint-checker
+ (name 'description)
+ (description "Validate package descriptions")
+ (check check-description-style))
+ (lint-checker
+ (name 'gnu-description)
+ (description "Validate synopsis & description of GNU packages")
+ (check check-gnu-synopsis+description))
+ (lint-checker
+ (name 'inputs-should-be-native)
+ (description "Identify inputs that should be native inputs")
+ (check check-inputs-should-be-native))
+ (lint-checker
+ (name 'inputs-should-not-be-input)
+ (description "Identify inputs that shouldn't be inputs at all")
+ (check check-inputs-should-not-be-an-input-at-all))
+ (lint-checker
+ (name 'patch-file-names)
+ (description "Validate file names and availability of patches")
+ (check check-patch-file-names))
+ (lint-checker
+ (name 'home-page)
+ (description "Validate home-page URLs")
+ (check check-home-page))
+ (lint-checker
+ (name 'license)
+ ;; TRANSLATORS: <license> is the name of a data type and must not be
+ ;; translated.
+ (description "Make sure the 'license' field is a <license> \
+or a list thereof")
+ (check check-license))
+ (lint-checker
+ (name 'source)
+ (description "Validate source URLs")
+ (check check-source))
+ (lint-checker
+ (name 'mirror-url)
+ (description "Suggest 'mirror://' URLs")
+ (check check-mirror-url))
+ (lint-checker
+ (name 'github-url)
+ (description "Suggest GitHub URLs")
+ (check check-github-url))
+ (lint-checker
+ (name 'source-file-name)
+ (description "Validate file names of sources")
+ (check check-source-file-name))
+ (lint-checker
+ (name 'source-unstable-tarball)
+ (description "Check for autogenerated tarballs")
+ (check check-source-unstable-tarball))
+ (lint-checker
+ (name 'derivation)
+ (description "Report failure to compile a package to a derivation")
+ (check check-derivation))
+ (lint-checker
+ (name 'synopsis)
+ (description "Validate package synopses")
+ (check check-synopsis-style))
+ (lint-checker
+ (name 'cve)
+ (description "Check the Common Vulnerabilities and Exposures\
+ (CVE) database")
+ (check check-vulnerabilities))
+ (lint-checker
+ (name 'refresh)
+ (description "Check the package for new upstream releases")
+ (check check-for-updates))
+ (lint-checker
+ (name 'formatting)
+ (description "Look for formatting issues in the source")
+ (check check-formatting))))
diff --git a/guix/scripts/lint.scm b/guix/scripts/lint.scm
index 4eb7e0e200..1c46fba16b 100644
--- a/guix/scripts/lint.scm
+++ b/guix/scripts/lint.scm
@@ -26,1224 +26,32 @@
;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
(define-module (guix scripts lint)
- #:use-module ((guix store) #:hide (close-connection))
- #:use-module (guix base32)
- #:use-module (guix download)
- #:use-module (guix ftp-client)
- #:use-module (guix http-client)
#:use-module (guix packages)
- #:use-module (guix licenses)
- #:use-module (guix records)
- #:use-module (guix grafts)
+ #:use-module (guix lint)
#:use-module (guix ui)
- #:use-module (guix upstream)
- #:use-module (guix utils)
- #:use-module (guix memoization)
#:use-module (guix scripts)
- #:use-module (guix gnu-maintenance)
- #:use-module (guix monads)
- #:use-module (guix cve)
#:use-module (gnu packages)
#:use-module (ice-9 match)
- #:use-module (ice-9 regex)
#:use-module (ice-9 format)
- #:use-module (web client)
- #:use-module (web uri)
- #:use-module ((guix build download)
- #:select (maybe-expand-mirrors
- (open-connection-for-uri
- . guix:open-connection-for-uri)
- close-connection))
- #:use-module (web request)
- #:use-module (web response)
#:use-module (srfi srfi-1)
- #:use-module (srfi srfi-6) ;Unicode string ports
- #:use-module (srfi srfi-9)
- #:use-module (srfi srfi-11)
- #:use-module (srfi srfi-26)
- #:use-module (srfi srfi-34)
- #:use-module (srfi srfi-35)
#:use-module (srfi srfi-37)
- #:use-module (ice-9 rdelim)
#:export (guix-lint
- check-description-style
- check-inputs-should-be-native
- check-inputs-should-not-be-an-input-at-all
- check-patch-file-names
- check-synopsis-style
- check-derivation
- check-home-page
- check-source
- check-source-file-name
- check-source-unstable-tarball
- check-mirror-url
- check-github-url
- check-license
- check-vulnerabilities
- check-for-updates
- check-formatting
- run-checkers
-
- lint-warning
- lint-warning?
- lint-warning-package
- lint-warning-message
- lint-warning-message-text
- lint-warning-message-data
- lint-warning-location
-
- %checkers
- lint-checker
- lint-checker?
- lint-checker-name
- lint-checker-description
- lint-checker-check))
-
-\f
-;;;
-;;; Warnings
-;;;
-
-(define-record-type* <lint-warning>
- lint-warning make-lint-warning
- lint-warning?
- (package lint-warning-package)
- (message-text lint-warning-message-text)
- (message-data lint-warning-message-data
- (default '()))
- (location lint-warning-location
- (default #f)))
-
-(define (lint-warning-message warning)
- (apply format #f
- (G_ (lint-warning-message-text warning))
- (lint-warning-message-data warning)))
-
-(define (package-file package)
- (location-file
- (package-location package)))
-
-(define* (%make-warning package message-text
- #:optional (message-data '())
- #:key field location)
- (make-lint-warning
- package
- message-text
- message-data
- (or location
- (package-field-location package field)
- (package-location package))))
-
-(define-syntax make-warning
- (syntax-rules (G_)
- ((_ package (G_ message) rest ...)
- (%make-warning package message rest ...))))
+ run-checkers))
(define (emit-warnings warnings)
;; 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
;; provided MESSAGE.
(for-each
- (match-lambda
- (($ <lint-warning> package message-text message-data loc)
- (format (guix-warning-port) "~a: ~a@~a: ~a~%"
- (location->string loc)
- (package-name package) (package-version package)
- (apply format #f (G_ message-text) message-data))))
+ (lambda (lint-warning)
+ (let ((package (lint-warning-package lint-warning))
+ (loc (lint-warning-location lint-warning)))
+ (format (guix-warning-port) "~a: ~a@~a: ~a~%"
+ (location->string loc)
+ (package-name package) (package-version package)
+ (lint-warning-message lint-warning))))
warnings))
-\f
-;;;
-;;; Checkers
-;;;
-
-(define-record-type* <lint-checker>
- lint-checker make-lint-checker
- lint-checker?
- ;; TODO: add a 'certainty' field that shows how confident we are in the
- ;; checker. Then allow users to only run checkers that have a certain
- ;; 'certainty' level.
- (name lint-checker-name)
- (description lint-checker-description)
- (check lint-checker-check))
-
-(define (list-checkers-and-exit)
- ;; Print information about all available checkers and exit.
- (format #t (G_ "Available checkers:~%"))
- (for-each (lambda (checker)
- (format #t "- ~a: ~a~%"
- (lint-checker-name checker)
- (G_ (lint-checker-description checker))))
- %checkers)
- (exit 0))
-
-(define (properly-starts-sentence? s)
- (string-match "^[(\"'`[:upper:][:digit:]]" s))
-
-(define (starts-with-abbreviation? s)
- "Return #t if S starts with what looks like an abbreviation or acronym."
- (string-match "^[A-Z][A-Z0-9]+\\>" s))
-
-(define %quoted-identifier-rx
- ;; A quoted identifier, like 'this'.
- (make-regexp "['`][[:graph:]]+'"))
-
-(define (check-description-style package)
- ;; Emit a warning if stylistic issues are found in the description of PACKAGE.
- (define (check-not-empty description)
- (if (string-null? description)
- (list
- (make-warning package
- (G_ "description should not be empty")
- #:field 'description))
- '()))
-
- (define (check-texinfo-markup description)
- "Check that DESCRIPTION can be parsed as a Texinfo fragment. If the
-markup is valid return a plain-text version of DESCRIPTION, otherwise #f."
- (catch #t
- (lambda () (texi->plain-text description))
- (lambda (keys . args)
- (make-warning package
- (G_ "Texinfo markup in description is invalid")
- #:field 'description))))
-
- (define (check-trademarks description)
- "Check that DESCRIPTION does not contain '™' or '®' characters. See
-http://www.gnu.org/prep/standards/html_node/Trademarks.html."
- (match (string-index description (char-set #\™ #\®))
- ((and (? number?) index)
- (list
- (make-warning package
- (G_ "description should not contain ~
-trademark sign '~a' at ~d")
- (list (string-ref description index) index)
- #:field 'description)))
- (else '())))
-
- (define (check-quotes description)
- "Check whether DESCRIPTION contains single quotes and suggest @code."
- (if (regexp-exec %quoted-identifier-rx description)
- (list
- (make-warning package
- ;; TRANSLATORS: '@code' is Texinfo markup and must be kept
- ;; as is.
- (G_ "use @code or similar ornament instead of quotes")
- #:field 'description))
- '()))
-
- (define (check-proper-start description)
- (if (or (string-null? description)
- (properly-starts-sentence? description)
- (string-prefix-ci? (package-name package) description))
- '()
- (list
- (make-warning
- package
- (G_ "description should start with an upper-case letter or digit")
- #:field 'description))))
-
- (define (check-end-of-sentence-space description)
- "Check that an end-of-sentence period is followed by two spaces."
- (let ((infractions
- (reverse (fold-matches
- "\\. [A-Z]" description '()
- (lambda (m r)
- ;; Filter out matches of common abbreviations.
- (if (find (lambda (s)
- (string-suffix-ci? s (match:prefix m)))
- '("i.e" "e.g" "a.k.a" "resp"))
- r (cons (match:start m) r)))))))
- (if (null? infractions)
- '()
- (list
- (make-warning package
- (G_ "sentences in description should be followed ~
-by two spaces; possible infraction~p at ~{~a~^, ~}")
- (list (length infractions)
- infractions)
- #:field 'description)))))
-
- (let ((description (package-description package)))
- (if (string? description)
- (append
- (check-not-empty description)
- (check-quotes description)
- (check-trademarks description)
- ;; Use raw description for this because Texinfo rendering
- ;; automatically fixes end of sentence space.
- (check-end-of-sentence-space description)
- (match (check-texinfo-markup description)
- ((and warning (? lint-warning?)) (list warning))
- (plain-description
- (check-proper-start plain-description))))
- (list
- (make-warning package
- (G_ "invalid description: ~s")
- (list description)
- #:field 'description)))))
-
-(define (package-input-intersection inputs-to-check input-names)
- "Return the intersection between INPUTS-TO-CHECK, the list of input tuples
-of a package, and INPUT-NAMES, a list of package specifications such as
-\"glib:bin\"."
- (match inputs-to-check
- (((labels packages . outputs) ...)
- (filter-map (lambda (package output)
- (and (package? package)
- (let ((input (string-append
- (package-name package)
- (if (> (length output) 0)
- (string-append ":" (car output))
- ""))))
- (and (member input input-names)
- input))))
- packages outputs))))
-
-(define (check-inputs-should-be-native package)
- ;; Emit a warning if some inputs of PACKAGE are likely to belong to its
- ;; native inputs.
- (let ((inputs (package-inputs package))
- (input-names
- '("pkg-config"
- "cmake"
- "extra-cmake-modules"
- "glib:bin"
- "intltool"
- "itstool"
- "qttools"
- "python-coverage" "python2-coverage"
- "python-cython" "python2-cython"
- "python-docutils" "python2-docutils"
- "python-mock" "python2-mock"
- "python-nose" "python2-nose"
- "python-pbr" "python2-pbr"
- "python-pytest" "python2-pytest"
- "python-pytest-cov" "python2-pytest-cov"
- "python-setuptools-scm" "python2-setuptools-scm"
- "python-sphinx" "python2-sphinx")))
- (map (lambda (input)
- (make-warning
- package
- (G_ "'~a' should probably be a native input")
- (list input)
- #:field 'inputs))
- (package-input-intersection inputs input-names))))
-
-(define (check-inputs-should-not-be-an-input-at-all package)
- ;; Emit a warning if some inputs of PACKAGE are likely to should not be
- ;; an input at all.
- (let ((input-names '("python-setuptools"
- "python2-setuptools"
- "python-pip"
- "python2-pip")))
- (map (lambda (input)
- (make-warning
- package
- (G_ "'~a' should probably not be an input at all")
- (list input)
- #:field 'inputs))
- (package-input-intersection (package-direct-inputs package)
- input-names))))
-
-(define (package-name-regexp package)
- "Return a regexp that matches PACKAGE's name as a word at the beginning of a
-line."
- (make-regexp (string-append "^" (regexp-quote (package-name package))
- "\\>")
- regexp/icase))
-
-(define (check-synopsis-style package)
- ;; Emit a warning if stylistic issues are found in the synopsis of PACKAGE.
- (define (check-final-period synopsis)
- ;; Synopsis should not end with a period, except for some special cases.
- (if (and (string-suffix? "." synopsis)
- (not (string-suffix? "etc." synopsis)))
- (list
- (make-warning package
- (G_ "no period allowed at the end of the synopsis")
- #:field 'synopsis))
- '()))
-
- (define check-start-article
- ;; 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>.
- (if (false-if-exception (gnu-package? package))
- (const '())
- (lambda (synopsis)
- (if (or (string-prefix-ci? "A " synopsis)
- (string-prefix-ci? "An " synopsis))
- (list
- (make-warning package
- (G_ "no article allowed at the beginning of \
-the synopsis")
- #:field 'synopsis))
- '()))))
-
- (define (check-synopsis-length synopsis)
- (if (>= (string-length synopsis) 80)
- (list
- (make-warning package
- (G_ "synopsis should be less than 80 characters long")
- #:field 'synopsis))
- '()))
-
- (define (check-proper-start synopsis)
- (if (properly-starts-sentence? synopsis)
- '()
- (list
- (make-warning package
- (G_ "synopsis should start with an upper-case letter or digit")
- #:field 'synopsis))))
-
- (define (check-start-with-package-name synopsis)
- (if (and (regexp-exec (package-name-regexp package) synopsis)
- (not (starts-with-abbreviation? synopsis)))
- (list
- (make-warning package
- (G_ "synopsis should not start with the package name")
- #:field 'synopsis))
- '()))
-
- (define (check-texinfo-markup synopsis)
- "Check that SYNOPSIS can be parsed as a Texinfo fragment. If the
-markup is valid return a plain-text version of SYNOPSIS, otherwise #f."
- (catch #t
- (lambda ()
- (texi->plain-text synopsis)
- '())
- (lambda (keys . args)
- (list
- (make-warning package
- (G_ "Texinfo markup in synopsis is invalid")
- #:field 'synopsis)))))
-
- (define checks
- (list check-proper-start
- check-final-period
- check-start-article
- check-start-with-package-name
- check-synopsis-length
- check-texinfo-markup))
-
- (match (package-synopsis package)
- (""
- (list
- (make-warning package
- (G_ "synopsis should not be empty")
- #:field 'synopsis)))
- ((? string? synopsis)
- (append-map
- (lambda (proc)
- (proc synopsis))
- checks))
- (invalid
- (list
- (make-warning package
- (G_ "invalid synopsis: ~s")
- (list invalid)
- #:field 'synopsis)))))
-
-(define* (probe-uri uri #:key timeout)
- "Probe URI, a URI object, and return two values: a symbol denoting the
-probing status, such as 'http-response' when we managed to get an HTTP
-response from URI, and additional details, such as the actual HTTP response.
-
-TIMEOUT is the maximum number of seconds (possibly an inexact number) to wait
-for connections to complete; when TIMEOUT is #f, wait as long as needed."
- (define headers
- '((User-Agent . "GNU Guile")
- (Accept . "*/*")))
-
- (let loop ((uri uri)
- (visited '()))
- (match (uri-scheme uri)
- ((or 'http 'https)
- (catch #t
- (lambda ()
- (let ((port (guix:open-connection-for-uri
- uri #:timeout timeout))
- (request (build-request uri #:headers headers)))
- (define response
- (dynamic-wind
- (const #f)
- (lambda ()
- (write-request request port)
- (force-output port)
- (read-response port))
- (lambda ()
- (close-connection port))))
-
- (case (response-code response)
- ((302 ; found (redirection)
- 303 ; see other
- 307 ; temporary redirection
- 308) ; permanent redirection
- (let ((location (response-location response)))
- (if (or (not location) (member location visited))
- (values 'http-response response)
- (loop location (cons location visited))))) ;follow the redirect
- ((301) ; moved permanently
- (let ((location (response-location response)))
- ;; Return RESPONSE, unless the final response as we follow
- ;; redirects is not 200.
- (if location
- (let-values (((status response2)
- (loop location (cons location visited))))
- (case status
- ((http-response)
- (values 'http-response
- (if (= 200 (response-code response2))
- response
- response2)))
- (else
- (values status response2))))
- (values 'http-response response)))) ;invalid redirect
- (else
- (values 'http-response response)))))
- (lambda (key . args)
- (case key
- ((bad-header bad-header-component)
- ;; This can happen if the server returns an invalid HTTP header,
- ;; as is the case with the 'Date' header at sqlite.org.
- (values 'invalid-http-response #f))
- ((getaddrinfo-error system-error
- gnutls-error tls-certificate-error)
- (values key args))
- (else
- (apply throw key args))))))
- ('ftp
- (catch #t
- (lambda ()
- (let ((conn (ftp-open (uri-host uri) #:timeout timeout)))
- (define response
- (dynamic-wind
- (const #f)
- (lambda ()
- (ftp-chdir conn (dirname (uri-path uri)))
- (ftp-size conn (basename (uri-path uri))))
- (lambda ()
- (ftp-close conn))))
- (values 'ftp-response '(ok))))
- (lambda (key . args)
- (case key
- ((ftp-error)
- (values 'ftp-response `(error ,@args)))
- ((getaddrinfo-error system-error gnutls-error)
- (values key args))
- (else
- (apply throw key args))))))
- (_
- (values 'unknown-protocol #f)))))
-
-(define (tls-certificate-error-string args)
- "Return a string explaining the 'tls-certificate-error' arguments ARGS."
- (call-with-output-string
- (lambda (port)
- (print-exception port #f
- 'tls-certificate-error args))))
-
-(define (validate-uri uri package field)
- "Return #t if the given URI can be reached, otherwise return a warning for
-PACKAGE mentionning the FIELD."
- (let-values (((status argument)
- (probe-uri uri #:timeout 3))) ;wait at most 3 seconds
- (case status
- ((http-response)
- (cond ((= 200 (response-code argument))
- (match (response-content-length argument)
- ((? number? length)
- ;; As of July 2016, SourceForge returns 200 (instead of 404)
- ;; with a small HTML page upon failure. Attempt to detect
- ;; such malicious behavior.
- (or (> length 1000)
- (make-warning package
- (G_ "URI ~a returned \
-suspiciously small file (~a bytes)")
- (list (uri->string uri)
- length)
- #:field field)))
- (_ #t)))
- ((= 301 (response-code argument))
- (if (response-location argument)
- (make-warning package
- (G_ "permanent redirect from ~a to ~a")
- (list (uri->string uri)
- (uri->string
- (response-location argument)))
- #:field field)
- (make-warning package
- (G_ "invalid permanent redirect \
-from ~a")
- (list (uri->string uri))
- #:field field)))
- (else
- (make-warning package
- (G_ "URI ~a not reachable: ~a (~s)")
- (list (uri->string uri)
- (response-code argument)
- (response-reason-phrase argument))
- #:field field))))
- ((ftp-response)
- (match argument
- (('ok) #t)
- (('error port command code message)
- (make-warning package
- (G_ "URI ~a not reachable: ~a (~s)")
- (list (uri->string uri)
- code (string-trim-both message))
- #:field field))))
- ((getaddrinfo-error)
- (make-warning package
- (G_ "URI ~a domain not found: ~a")
- (list (uri->string uri)
- (gai-strerror (car argument)))
- #:field field))
- ((system-error)
- (make-warning package
- (G_ "URI ~a unreachable: ~a")
- (list (uri->string uri)
- (strerror
- (system-error-errno
- (cons status argument))))
- #:field field))
- ((tls-certificate-error)
- (make-warning package
- (G_ "TLS certificate error: ~a")
- (list (tls-certificate-error-string argument))
- #:field field))
- ((invalid-http-response gnutls-error)
- ;; Probably a misbehaving server; ignore.
- #f)
- ((unknown-protocol) ;nothing we can do
- #f)
- (else
- (error "internal linter error" status)))))
-
-(define (check-home-page package)
- "Emit a warning if PACKAGE has an invalid 'home-page' field, or if that
-'home-page' is not reachable."
- (let ((uri (and=> (package-home-page package) string->uri)))
- (cond
- ((uri? uri)
- (match (validate-uri uri package 'home-page)
- ((and (? lint-warning? warning) warning)
- (list warning))
- (_ '())))
- ((not (package-home-page package))
- (if (or (string-contains (package-name package) "bootstrap")
- (string=? (package-name package) "ld-wrapper"))
- '()
- (list
- (make-warning package
- (G_ "invalid value for home page")
- #:field 'home-page))))
- (else
- (list
- (make-warning package
- (G_ "invalid home page URL: ~s")
- (list (package-home-page package))
- #:field 'home-page))))))
-
-(define %distro-directory
- (mlambda ()
- (dirname (search-path %load-path "gnu.scm"))))
-
-(define (check-patch-file-names package)
- "Emit a warning if the patches requires by PACKAGE are badly named or if the
-patch could not be found."
- (guard (c ((message-condition? c) ;raised by 'search-patch'
- (list
- ;; Use %make-warning, as condition-mesasge is already
- ;; translated.
- (%make-warning package (condition-message c)
- #:field 'patch-file-names))))
- (define patches
- (or (and=> (package-source package) origin-patches)
- '()))
-
- (append
- (if (every (match-lambda ;patch starts with package name?
- ((? string? patch)
- (and=> (string-contains (basename patch)
- (package-name package))
- zero?))
- (_ #f)) ;must be an <origin> or something like that.
- patches)
- '()
- (list
- (make-warning
- package
- (G_ "file names of patches should start with the package name")
- #:field 'patch-file-names)))
-
- ;; Check whether we're reaching tar's maximum file name length.
- (let ((prefix (string-length (%distro-directory)))
- (margin (string-length "guix-0.13.0-10-123456789/"))
- (max 99))
- (filter-map (match-lambda
- ((? string? patch)
- (if (> (+ margin (if (string-prefix? (%distro-directory)
- patch)
- (- (string-length patch) prefix)
- (string-length patch)))
- max)
- (make-warning
- package
- (G_ "~a: file name is too long")
- (list (basename patch))
- #:field 'patch-file-names)
- #f))
- (_ #f))
- patches)))))
-
-(define (escape-quotes str)
- "Replace any quote character in STR by an escaped quote character."
- (list->string
- (string-fold-right (lambda (chr result)
- (match chr
- (#\" (cons* #\\ #\"result))
- (_ (cons chr result))))
- '()
- str)))
-
-(define official-gnu-packages*
- (mlambda ()
- "A memoizing version of 'official-gnu-packages' that returns the empty
-list when something goes wrong, such as a networking issue."
- (let ((gnus (false-if-exception (official-gnu-packages))))
- (or gnus '()))))
-
-(define (check-gnu-synopsis+description package)
- "Make sure that, if PACKAGE is a GNU package, it uses the synopsis and
-descriptions maintained upstream."
- (match (find (lambda (descriptor)
- (string=? (gnu-package-name descriptor)
- (package-name package)))
- (official-gnu-packages*))
- (#f ;not a GNU package, so nothing to do
- '())
- (descriptor ;a genuine GNU package
- (append
- (let ((upstream (gnu-package-doc-summary descriptor))
- (downstream (package-synopsis package)))
- (if (and upstream
- (or (not (string? downstream))
- (not (string=? upstream downstream))))
- (list
- (make-warning package
- (G_ "proposed synopsis: ~s~%")
- (list upstream)
- #:field 'synopsis))
- '()))
-
- (let ((upstream (gnu-package-doc-description descriptor))
- (downstream (package-description package)))
- (if (and upstream
- (or (not (string? downstream))
- (not (string=? (fill-paragraph upstream 100)
- (fill-paragraph downstream 100)))))
- (list
- (make-warning
- package
- (G_ "proposed description:~% \"~a\"~%")
- (list (fill-paragraph (escape-quotes upstream) 77 7))
- #:field 'description))
- '()))))))
-
-(define (origin-uris origin)
- "Return the list of URIs (strings) for ORIGIN."
- (match (origin-uri origin)
- ((? string? uri)
- (list uri))
- ((uris ...)
- uris)))
-
-(define (check-source package)
- "Emit a warning if PACKAGE has an invalid 'source' field, or if that
-'source' is not reachable."
- (define (warnings-for-uris uris)
- (filter lint-warning?
- (map
- (lambda (uri)
- (validate-uri uri package 'source))
- (append-map (cut maybe-expand-mirrors <> %mirrors)
- uris))))
-
- (let ((origin (package-source package)))
- (if (and origin
- (eqv? (origin-method origin) url-fetch))
- (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.
- (if (eq? (length uris) (length warnings))
- ;; When everything fails, report all of WARNINGS, otherwise don't
- ;; report anything.
- ;;
- ;; XXX: Ideally we'd still allow warnings to be raised if *some*
- ;; URIs are unreachable, but distinguish that from the error case
- ;; where *all* the URIs are unreachable.
- (cons*
- (make-warning package
- (G_ "all the source URIs are unreachable:")
- #:field 'source)
- warnings)
- '()))
- '())))
-
-(define (check-source-file-name package)
- "Emit a warning if PACKAGE's origin has no meaningful file name."
- (define (origin-file-name-valid? origin)
- ;; Return #f if the source file name contains only a version or is #f;
- ;; indicates that the origin needs a 'file-name' field.
- (let ((file-name (origin-actual-file-name origin))
- (version (package-version package)))
- (and file-name
- ;; Common in many projects is for the filename to start
- ;; with a "v" followed by the version,
- ;; e.g. "v3.2.0.tar.gz".
- (not (string-match (string-append "^v?" version) file-name)))))
-
- (let ((origin (package-source package)))
- (if (or (not origin) (origin-file-name-valid? origin))
- '()
- (list
- (make-warning package
- (G_ "the source file name should contain the package name")
- #:field 'source)))))
-
-(define (check-source-unstable-tarball package)
- "Emit a warning if PACKAGE's source is an autogenerated tarball."
- (define (check-source-uri uri)
- (if (and (string=? (uri-host (string->uri uri)) "github.com")
- (match (split-and-decode-uri-path
- (uri-path (string->uri uri)))
- ((_ _ "archive" _ ...) #t)
- (_ #f)))
- (make-warning package
- (G_ "the source URI should not be an autogenerated tarball")
- #:field 'source)
- #f))
-
- (let ((origin (package-source package)))
- (if (and (origin? origin)
- (eqv? (origin-method origin) url-fetch))
- (filter-map check-source-uri
- (origin-uris origin))
- '())))
-
-(define (check-mirror-url package)
- "Check whether PACKAGE uses source URLs that should be 'mirror://'."
- (define (check-mirror-uri uri) ;XXX: could be optimized
- (let loop ((mirrors %mirrors))
- (match mirrors
- (()
- #f)
- (((mirror-id mirror-urls ...) rest ...)
- (match (find (cut string-prefix? <> uri) mirror-urls)
- (#f
- (loop rest))
- (prefix
- (make-warning package
- (G_ "URL should be \
-'mirror://~a/~a'")
- (list mirror-id
- (string-drop uri (string-length prefix)))
- #:field 'source)))))))
-
- (let ((origin (package-source package)))
- (if (and (origin? origin)
- (eqv? (origin-method origin) url-fetch))
- (let ((uris (origin-uris origin)))
- (filter-map check-mirror-uri uris))
- '())))
-
-(define* (check-github-url package #:key (timeout 3))
- "Check whether PACKAGE uses source URLs that redirect to GitHub."
- (define (follow-redirect url)
- (let* ((uri (string->uri url))
- (port (guix:open-connection-for-uri uri #:timeout timeout))
- (response (http-head uri #:port port)))
- (close-port port)
- (case (response-code response)
- ((301 302)
- (uri->string (assoc-ref (response-headers response) 'location)))
- (else #f))))
-
- (define (follow-redirects-to-github uri)
- (cond
- ((string-prefix? "https://github.com/" uri) uri)
- ((string-prefix? "http" uri)
- (and=> (follow-redirect uri) follow-redirects-to-github))
- ;; Do not attempt to follow redirects on URIs other than http and https
- ;; (such as mirror, file)
- (else #f)))
-
- (let ((origin (package-source package)))
- (if (and (origin? origin)
- (eqv? (origin-method origin) url-fetch))
- (filter-map
- (lambda (uri)
- (and=> (follow-redirects-to-github uri)
- (lambda (github-uri)
- (if (string=? github-uri uri)
- #f
- (make-warning
- package
- (G_ "URL should be '~a'")
- (list github-uri)
- #:field 'source)))))
- (origin-uris origin))
- '())))
-
-(define (check-derivation package)
- "Emit a warning if we fail to compile PACKAGE to a derivation."
- (define (try system)
- (catch #t
- (lambda ()
- (guard (c ((store-protocol-error? c)
- (make-warning package
- (G_ "failed to create ~a derivation: ~a")
- (list system
- (store-protocol-error-message c))))
- ((message-condition? c)
- (make-warning package
- (G_ "failed to create ~a derivation: ~a")
- (list system
- (condition-message c)))))
- (with-store store
- ;; Disable grafts since it can entail rebuilds.
- (parameterize ((%graft? #f))
- (package-derivation store package system #:graft? #f)
-
- ;; If there's a replacement, make sure we can compute its
- ;; derivation.
- (match (package-replacement package)
- (#f #t)
- (replacement
- (package-derivation store replacement system
- #:graft? #f)))))))
- (lambda args
- (make-warning package
- (G_ "failed to create ~a derivation: ~s")
- (list system args)))))
-
- (filter lint-warning?
- (map try (package-supported-systems package))))
-
-(define (check-license package)
- "Warn about type errors of the 'license' field of PACKAGE."
- (match (package-license package)
- ((or (? license?)
- ((? license?) ...))
- '())
- (x
- (list
- (make-warning package (G_ "invalid license field")
- #:field 'license)))))
-
-(define (call-with-networking-fail-safe message error-value proc)
- "Call PROC catching any network-related errors. Upon a networking error,
-display a message including MESSAGE and return ERROR-VALUE."
- (guard (c ((http-get-error? c)
- (warning (G_ "~a: HTTP GET error for ~a: ~a (~s)~%")
- message
- (uri->string (http-get-error-uri c))
- (http-get-error-code c)
- (http-get-error-reason c))
- error-value))
- (catch #t
- proc
- (match-lambda*
- (('getaddrinfo-error errcode)
- (warning (G_ "~a: host lookup failure: ~a~%")
- message
- (gai-strerror errcode))
- error-value)
- (('tls-certificate-error args ...)
- (warning (G_ "~a: TLS certificate error: ~a")
- message
- (tls-certificate-error-string args))
- error-value)
- (args
- (apply throw args))))))
-
-(define-syntax-rule (with-networking-fail-safe message error-value exp ...)
- (call-with-networking-fail-safe message error-value
- (lambda () exp ...)))
-
-(define (current-vulnerabilities*)
- "Like 'current-vulnerabilities', but return the empty list upon networking
-or HTTP errors. This allows network-less operation and makes problems with
-the NIST server non-fatal."
- (with-networking-fail-safe (G_ "while retrieving CVE vulnerabilities")
- '()
- (current-vulnerabilities)))
-
-(define package-vulnerabilities
- (let ((lookup (delay (vulnerabilities->lookup-proc
- (current-vulnerabilities*)))))
- (lambda (package)
- "Return a list of vulnerabilities affecting PACKAGE."
- ;; First we retrieve the Common Platform Enumeration (CPE) name and
- ;; version for PACKAGE, then we can pass them to LOOKUP.
- (let ((name (or (assoc-ref (package-properties package)
- 'cpe-name)
- (package-name package)))
- (version (or (assoc-ref (package-properties package)
- 'cpe-version)
- (package-version package))))
- ((force lookup) name version)))))
-
-(define (check-vulnerabilities package)
- "Check for known vulnerabilities for PACKAGE."
- (let ((package (or (package-replacement package) package)))
- (match (package-vulnerabilities package)
- (()
- '())
- ((vulnerabilities ...)
- (let* ((patched (package-patched-vulnerabilities package))
- (known-safe (or (assq-ref (package-properties package)
- 'lint-hidden-cve)
- '()))
- (unpatched (remove (lambda (vuln)
- (let ((id (vulnerability-id vuln)))
- (or (member id patched)
- (member id known-safe))))
- vulnerabilities)))
- (if (null? unpatched)
- '()
- (list
- (make-warning
- package
- (G_ "probably vulnerable to ~a")
- (list (string-join (map vulnerability-id unpatched)
- ", "))))))))))
-
-(define (check-for-updates package)
- "Check if there is an update available for PACKAGE."
- (match (with-networking-fail-safe
- (G_ "while retrieving upstream info for '~a'")
- (list (package-name package))
- #f
- (package-latest-release* package (force %updaters)))
- ((? upstream-source? source)
- (if (version>? (upstream-source-version source)
- (package-version package))
- (list
- (make-warning package
- (G_ "can be upgraded to ~a")
- (list (upstream-source-version source))
- #:field 'version))
- '()))
- (#f '()))) ; cannot find newer upstream release
-
-\f
-;;;
-;;; Source code formatting.
-;;;
-
-(define (report-tabulations package line line-number)
- "Warn about tabulations found in LINE."
- (match (string-index line #\tab)
- (#f #t)
- (index
- (make-warning package
- (G_ "tabulation on line ~a, column ~a")
- (list line-number index)
- #:location
- (location (package-file package)
- line-number
- index)))))
-
-(define (report-trailing-white-space package line line-number)
- "Warn about trailing white space in LINE."
- (unless (or (string=? line (string-trim-right line))
- (string=? line (string #\page)))
- (make-warning package
- (G_ "trailing white space on line ~a")
- (list line-number)
- #:location
- (location (package-file package)
- line-number
- 0))))
-
-(define (report-long-line package line line-number)
- "Emit a warning if LINE is too long."
- ;; Note: We don't warn at 80 characters because sometimes hashes and URLs
- ;; make it hard to fit within that limit and we want to avoid making too
- ;; much noise.
- (when (> (string-length line) 90)
- (make-warning package
- (G_ "line ~a is way too long (~a characters)")
- (list line-number (string-length line))
- #:location
- (location (package-file package)
- line-number
- 0))))
-
-(define %hanging-paren-rx
- (make-regexp "^[[:blank:]]*[()]+[[:blank:]]*$"))
-
-(define (report-lone-parentheses package line line-number)
- "Emit a warning if LINE contains hanging parentheses."
- (when (regexp-exec %hanging-paren-rx line)
- (make-warning package
- (G_ "parentheses feel lonely, \
-move to the previous or next line")
- (list line-number)
- #:location
- (location (package-file package)
- line-number
- 0))))
-
-(define %formatting-reporters
- ;; List of procedures that report formatting issues. These are not separate
- ;; checkers because they would need to re-read the file.
- (list report-tabulations
- report-trailing-white-space
- report-long-line
- report-lone-parentheses))
-
-(define* (report-formatting-issues package file starting-line
- #:key (reporters %formatting-reporters))
- "Report white-space issues in FILE starting from STARTING-LINE, and report
-them for PACKAGE."
- (define (sexp-last-line port)
- ;; Return the last line of the sexp read from PORT or an estimate thereof.
- (define &failure (list 'failure))
-
- (let ((start (ftell port))
- (start-line (port-line port))
- (sexp (catch 'read-error
- (lambda () (read port))
- (const &failure))))
- (let ((line (port-line port)))
- (seek port start SEEK_SET)
- (set-port-line! port start-line)
- (if (eq? sexp &failure)
- (+ start-line 60) ;conservative estimate
- line))))
-
- (call-with-input-file file
- (lambda (port)
- (let loop ((line-number 1)
- (last-line #f)
- (warnings '()))
- (let ((line (read-line port)))
- (if (or (eof-object? line)
- (and last-line (> line-number last-line)))
- warnings
- (if (and (= line-number starting-line)
- (not last-line))
- (loop (+ 1 line-number)
- (+ 1 (sexp-last-line port))
- warnings)
- (loop (+ 1 line-number)
- last-line
- (append
- warnings
- (if (< line-number starting-line)
- '()
- (filter
- lint-warning?
- (map (lambda (report)
- (report package line line-number))
- reporters))))))))))))
-
-(define (check-formatting package)
- "Check the formatting of the source code of PACKAGE."
- (let ((location (package-location package)))
- (if location
- (and=> (search-path %load-path (location-file location))
- (lambda (file)
- ;; Report issues starting from the line before the 'package'
- ;; form, which usually contains the 'define' form.
- (report-formatting-issues package file
- (- (location-line location) 1))))
- '())))
-
-\f
-;;;
-;;; List of checkers.
-;;;
-
-(define %checkers
- (list
- (lint-checker
- (name 'description)
- (description "Validate package descriptions")
- (check check-description-style))
- (lint-checker
- (name 'gnu-description)
- (description "Validate synopsis & description of GNU packages")
- (check check-gnu-synopsis+description))
- (lint-checker
- (name 'inputs-should-be-native)
- (description "Identify inputs that should be native inputs")
- (check check-inputs-should-be-native))
- (lint-checker
- (name 'inputs-should-not-be-input)
- (description "Identify inputs that shouldn't be inputs at all")
- (check check-inputs-should-not-be-an-input-at-all))
- (lint-checker
- (name 'patch-file-names)
- (description "Validate file names and availability of patches")
- (check check-patch-file-names))
- (lint-checker
- (name 'home-page)
- (description "Validate home-page URLs")
- (check check-home-page))
- (lint-checker
- (name 'license)
- ;; TRANSLATORS: <license> is the name of a data type and must not be
- ;; translated.
- (description "Make sure the 'license' field is a <license> \
-or a list thereof")
- (check check-license))
- (lint-checker
- (name 'source)
- (description "Validate source URLs")
- (check check-source))
- (lint-checker
- (name 'mirror-url)
- (description "Suggest 'mirror://' URLs")
- (check check-mirror-url))
- (lint-checker
- (name 'github-url)
- (description "Suggest GitHub URLs")
- (check check-github-url))
- (lint-checker
- (name 'source-file-name)
- (description "Validate file names of sources")
- (check check-source-file-name))
- (lint-checker
- (name 'source-unstable-tarball)
- (description "Check for autogenerated tarballs")
- (check check-source-unstable-tarball))
- (lint-checker
- (name 'derivation)
- (description "Report failure to compile a package to a derivation")
- (check check-derivation))
- (lint-checker
- (name 'synopsis)
- (description "Validate package synopses")
- (check check-synopsis-style))
- (lint-checker
- (name 'cve)
- (description "Check the Common Vulnerabilities and Exposures\
- (CVE) database")
- (check check-vulnerabilities))
- (lint-checker
- (name 'refresh)
- (description "Check the package for new upstream releases")
- (check check-for-updates))
- (lint-checker
- (name 'formatting)
- (description "Look for formatting issues in the source")
- (check check-formatting))))
-
(define* (run-checkers package #:optional (checkers %checkers))
"Run the given CHECKERS on PACKAGE."
(let ((tty? (isatty? (current-error-port))))
@@ -1260,6 +68,16 @@ or a list thereof")
(format (current-error-port) "\x1b[K")
(force-output (current-error-port)))))
+(define (list-checkers-and-exit)
+ ;; Print information about all available checkers and exit.
+ (format #t (G_ "Available checkers:~%"))
+ (for-each (lambda (checker)
+ (format #t "- ~a: ~a~%"
+ (lint-checker-name checker)
+ (G_ (lint-checker-description checker))))
+ %checkers)
+ (exit 0))
+
\f
;;;
;;; Command-line options.
diff --git a/po/guix/POTFILES.in b/po/guix/POTFILES.in
index ad06ebce95..8b556ac0ec 100644
--- a/po/guix/POTFILES.in
+++ b/po/guix/POTFILES.in
@@ -40,6 +40,7 @@ gnu/machine/ssh.scm
guix/scripts.scm
guix/scripts/build.scm
guix/discovery.scm
+guix/lint.scm
guix/scripts/download.scm
guix/scripts/package.scm
guix/scripts/install.scm
diff --git a/tests/lint.scm b/tests/lint.scm
index d8b2ca54cd..59be061a99 100644
--- a/tests/lint.scm
+++ b/tests/lint.scm
@@ -33,7 +33,7 @@
#:use-module (guix git-download)
#:use-module (guix build-system gnu)
#:use-module (guix packages)
- #:use-module (guix scripts lint)
+ #:use-module (guix lint)
#:use-module (guix ui)
#:use-module (gnu packages)
#:use-module (gnu packages glib)
--
2.22.0
^ permalink raw reply related [flat|nested] 37+ messages in thread
* [bug#35790] [PATCH 4/4] lint: Separate checkers by dependence on the internet.
2019-07-15 19:45 ` [bug#35790] [PATCH 1/4] scripts: lint: Handle warnings with a record type Christopher Baines
2019-07-15 19:45 ` [bug#35790] [PATCH 2/4] scripts: lint: Separate the message warning text and data Christopher Baines
2019-07-15 19:45 ` [bug#35790] [PATCH 3/4] lint: Move the linting code to a different module Christopher Baines
@ 2019-07-15 19:45 ` Christopher Baines
2019-07-15 20:17 ` Ludovic Courtès
2 siblings, 1 reply; 37+ messages in thread
From: Christopher Baines @ 2019-07-15 19:45 UTC (permalink / raw)
To: 35790
I think there are a couple of potential uses for this. It's somewhat a
separation in to what checkers are just checking the contents of the
repository (line length for example), and other checkers which are bringing in
external information which could change.
I'm thinking particularly, about treating network dependent checkers
differently when automatically running them, but this commit also adds a
--no-network flag to guix lint, which selects the checkers that don't access
the network, which could be useful if no network access is available.
* guix/lint.scm (%checkers): Rename to %all-checkers.
(%local-checkers, %network-dependent-checkers): New variables.
* guix/scripts/lint.scm (run-checkers): Make the checkers argument mandatory.
(list-checkers-and-exit): Handle the checkers as an argument.
(%options): Adjust for changes to %checkers, add a --no-network option, and
change how the --list-checkers option is handled.
(guix-lint): Adjust indentation, and update how the checkers are handled.
---
guix/lint.scm | 63 ++++++++++++++++++++++++-------------------
guix/scripts/lint.scm | 49 ++++++++++++++++++++-------------
2 files changed, 66 insertions(+), 46 deletions(-)
diff --git a/guix/lint.scm b/guix/lint.scm
index c2c0914958..2542a81a2d 100644
--- a/guix/lint.scm
+++ b/guix/lint.scm
@@ -91,7 +91,9 @@
lint-warning-message-data
lint-warning-location
- %checkers
+ %local-checkers
+ %network-dependent-checkers
+ %all-checkers
lint-checker
lint-checker?
@@ -1146,16 +1148,12 @@ them for PACKAGE."
;;; List of checkers.
;;;
-(define %checkers
+(define %local-checkers
(list
(lint-checker
(name 'description)
(description "Validate package descriptions")
(check check-description-style))
- (lint-checker
- (name 'gnu-description)
- (description "Validate synopsis & description of GNU packages")
- (check check-gnu-synopsis+description))
(lint-checker
(name 'inputs-should-be-native)
(description "Identify inputs that should be native inputs")
@@ -1164,14 +1162,6 @@ them for PACKAGE."
(name 'inputs-should-not-be-input)
(description "Identify inputs that shouldn't be inputs at all")
(check check-inputs-should-not-be-an-input-at-all))
- (lint-checker
- (name 'patch-file-names)
- (description "Validate file names and availability of patches")
- (check check-patch-file-names))
- (lint-checker
- (name 'home-page)
- (description "Validate home-page URLs")
- (check check-home-page))
(lint-checker
(name 'license)
;; TRANSLATORS: <license> is the name of a data type and must not be
@@ -1179,18 +1169,10 @@ them for PACKAGE."
(description "Make sure the 'license' field is a <license> \
or a list thereof")
(check check-license))
- (lint-checker
- (name 'source)
- (description "Validate source URLs")
- (check check-source))
(lint-checker
(name 'mirror-url)
(description "Suggest 'mirror://' URLs")
(check check-mirror-url))
- (lint-checker
- (name 'github-url)
- (description "Suggest GitHub URLs")
- (check check-github-url))
(lint-checker
(name 'source-file-name)
(description "Validate file names of sources")
@@ -1203,10 +1185,37 @@ or a list thereof")
(name 'derivation)
(description "Report failure to compile a package to a derivation")
(check check-derivation))
+ (lint-checker
+ (name 'patch-file-names)
+ (description "Validate file names and availability of patches")
+ (check check-patch-file-names))
+ (lint-checker
+ (name 'formatting)
+ (description "Look for formatting issues in the source")
+ (check check-formatting))))
+
+(define %network-dependent-checkers
+ (list
(lint-checker
(name 'synopsis)
(description "Validate package synopses")
(check check-synopsis-style))
+ (lint-checker
+ (name 'gnu-description)
+ (description "Validate synopsis & description of GNU packages")
+ (check check-gnu-synopsis+description))
+ (lint-checker
+ (name 'home-page)
+ (description "Validate home-page URLs")
+ (check check-home-page))
+ (lint-checker
+ (name 'source)
+ (description "Validate source URLs")
+ (check check-source))
+ (lint-checker
+ (name 'github-url)
+ (description "Suggest GitHub URLs")
+ (check check-github-url))
(lint-checker
(name 'cve)
(description "Check the Common Vulnerabilities and Exposures\
@@ -1215,8 +1224,8 @@ or a list thereof")
(lint-checker
(name 'refresh)
(description "Check the package for new upstream releases")
- (check check-for-updates))
- (lint-checker
- (name 'formatting)
- (description "Look for formatting issues in the source")
- (check check-formatting))))
+ (check check-for-updates))))
+
+(define %all-checkers
+ (append %local-checkers
+ %network-dependent-checkers))
diff --git a/guix/scripts/lint.scm b/guix/scripts/lint.scm
index 1c46fba16b..98ee469501 100644
--- a/guix/scripts/lint.scm
+++ b/guix/scripts/lint.scm
@@ -52,7 +52,7 @@
(lint-warning-message lint-warning))))
warnings))
-(define* (run-checkers package #:optional (checkers %checkers))
+(define (run-checkers package checkers)
"Run the given CHECKERS on PACKAGE."
(let ((tty? (isatty? (current-error-port))))
(for-each (lambda (checker)
@@ -68,14 +68,14 @@
(format (current-error-port) "\x1b[K")
(force-output (current-error-port)))))
-(define (list-checkers-and-exit)
+(define (list-checkers-and-exit checkers)
;; Print information about all available checkers and exit.
(format #t (G_ "Available checkers:~%"))
(for-each (lambda (checker)
(format #t "- ~a: ~a~%"
(lint-checker-name checker)
(G_ (lint-checker-description checker))))
- %checkers)
+ checkers)
(exit 0))
\f
@@ -111,26 +111,33 @@ run the checkers on all packages.\n"))
;; 'certainty'.
(list (option '(#\c "checkers") #t #f
(lambda (opt name arg result)
- (let ((names (map string->symbol (string-split arg #\,))))
+ (let ((names (map string->symbol (string-split arg #\,)))
+ (checker-names (map lint-checker-name %all-checkers)))
(for-each (lambda (c)
- (unless (memq c
- (map lint-checker-name
- %checkers))
+ (unless (memq c checker-names)
(leave (G_ "~a: invalid checker~%") c)))
names)
(alist-cons 'checkers
(filter (lambda (checker)
(member (lint-checker-name checker)
names))
- %checkers)
+ %all-checkers)
result))))
+ (option '(#\n "no-network") #f #f
+ (lambda (opt name arg result)
+ (alist-cons 'checkers
+ %local-checkers
+ (alist-delete 'checkers
+ result))))
(option '(#\h "help") #f #f
(lambda args
(show-help)
(exit 0)))
(option '(#\l "list-checkers") #f #f
- (lambda args
- (list-checkers-and-exit)))
+ (lambda (opt name arg result)
+ (alist-cons 'list?
+ #t
+ result)))
(option '(#\V "version") #f #f
(lambda args
(show-version-and-exit "guix lint")))))
@@ -148,13 +155,17 @@ run the checkers on all packages.\n"))
(let* ((opts (parse-options))
(args (filter-map (match-lambda
- (('argument . value)
- value)
- (_ #f))
+ (('argument . value)
+ value)
+ (_ #f))
(reverse opts)))
- (checkers (or (assoc-ref opts 'checkers) %checkers)))
- (if (null? args)
- (fold-packages (lambda (p r) (run-checkers p checkers)) '())
- (for-each (lambda (spec)
- (run-checkers (specification->package spec) checkers))
- args))))
+ (checkers (or (assoc-ref opts 'checkers) %all-checkers)))
+ (cond
+ ((assoc-ref opts 'list?)
+ (list-checkers-and-exit checkers))
+ ((null? args)
+ (fold-packages (lambda (p r) (run-checkers p checkers)) '()))
+ (else
+ (for-each (lambda (spec)
+ (run-checkers (specification->package spec) checkers))
+ args)))))
--
2.22.0
^ permalink raw reply related [flat|nested] 37+ messages in thread
* [bug#35790] [PATCH 1/2] lint: Move the linting code to a different module.
2019-07-15 9:20 ` Ludovic Courtès
2019-07-15 19:45 ` [bug#35790] [PATCH 1/4] scripts: lint: Handle warnings with a record type Christopher Baines
@ 2019-07-15 19:51 ` Christopher Baines
1 sibling, 0 replies; 37+ messages in thread
From: Christopher Baines @ 2019-07-15 19:51 UTC (permalink / raw)
To: Ludovic Courtès; +Cc: 35790
[-- Attachment #1: Type: text/plain, Size: 2203 bytes --]
Ludovic Courtès <ludo@gnu.org> writes:
> Hi Chris!
>
> Christopher Baines <mail@cbaines.net> skribis:
>
>> Ludovic Courtès <ludo@gnu.org> writes:
>>
>>> Christopher Baines <mail@cbaines.net> skribis:
>>>
>>>> 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.
>>>
>>> For the final version, please write a change log.
>>
>> Sure, any suggestions about how to write it? I wasn't sure whether to
>> list everything that had been moved from (guix scripts lint) to (guix
>> lint), or say that the file has moved, and list the things that have
>> been moved back.
>
> Maybe something like:
>
> * guix/scripts/lint.scm (check-foo, check-bar): Move to…
> * guix/lint.scm: … here.
>
> and also mention things that go beyond simply moving things around (if
> applicable).
>
> But again, don’t spend a whole day on this, it’s mostly so the future us
> have an easily searchable log.
Ok, I've made an initial attempt at this, and re-sent the patches.
>> Actually, now that I've run make, that's spotted some problems in some
>> checks.
>>
>> guix/lint.scm:198:17: warning: possibly unbound variable `texi->plain-text'
>> guix/lint.scm:406:8: warning: possibly unbound variable `texi->plain-text'
>> guix/lint.scm:737:36: warning: possibly unbound variable `fill-paragraph'
>> guix/lint.scm:738:36: warning: possibly unbound variable `fill-paragraph'
>> guix/lint.scm:743:20: warning: possibly unbound variable `fill-paragraph'
>>
>> I don't think these are as easy to solve, as these functions come from
>> (guix ui).
>
> Ah yes, indeed.
>
> In that case it’s OK because (guix ui) is used as part of the linter’s
> job. Perhaps for clarity we should write:
>
> #:use-module ((guix ui) #:select (texi->plain-text fill-paragraph))
>
> Uses of the ‘warning’ procedure or similar UI functionality should be
> left to (guix scripts lint), though.
I've made this #:use-module change, and also moved emit-warnings to the
(guix scripts lint) module.
I've re-sent all 4 patches now.
Thanks,
Chris
[-- Attachment #2: signature.asc --]
[-- Type: application/pgp-signature, Size: 962 bytes --]
^ permalink raw reply [flat|nested] 37+ messages in thread
* [bug#35790] [PATCH 4/4] lint: Separate checkers by dependence on the internet.
2019-07-15 19:45 ` [bug#35790] [PATCH 4/4] lint: Separate checkers by dependence on the internet Christopher Baines
@ 2019-07-15 20:17 ` Ludovic Courtès
2019-07-15 22:23 ` bug#35790: " Christopher Baines
0 siblings, 1 reply; 37+ messages in thread
From: Ludovic Courtès @ 2019-07-15 20:17 UTC (permalink / raw)
To: Christopher Baines; +Cc: 35790
Hi!
It seems to me we’re all set now.
Thanks a lot for all the work and for your patience!
Ludo’.
^ permalink raw reply [flat|nested] 37+ messages in thread
* bug#35790: [PATCH 4/4] lint: Separate checkers by dependence on the internet.
2019-07-15 20:17 ` Ludovic Courtès
@ 2019-07-15 22:23 ` Christopher Baines
2019-07-16 21:34 ` [bug#35790] " Ludovic Courtès
0 siblings, 1 reply; 37+ messages in thread
From: Christopher Baines @ 2019-07-15 22:23 UTC (permalink / raw)
To: Ludovic Courtès; +Cc: 35790-done
[-- Attachment #1: Type: text/plain, Size: 1311 bytes --]
Ludovic Courtès <ludo@gnu.org> writes:
> Hi!
>
> It seems to me we’re all set now.
Great, I've pushed these to master now.
> Thanks a lot for all the work and for your patience!
No problem :)
In terms of next steps, I think this is a big bit of the work needed to
get lint warnings in to the Guix Data Service done, but there's still a
big chunk to do.
I hope to start looking at actually trying to load in the lint warnings
soon. This might involve extending the inferior API if that's helpful. I
also want to attempt to store translations for the lint warnings in one
way or another, as that'll begin to address the lack of localisation in
the Guix Data Service.
There's also some thinking about how to manage the network dependent
checkers. I'd like to get that information in anyway, but also, I think
it might be possible to maybe separate out the network independant parts
of the checkers that are currently in the network dependent list. For
example, the synopsis checker is only in there as it attempts to connect
to the network to check if packages are a GNU package, and I'm wondering
if that can be avoided.
Anyway, hopefully the code refactoring is generally helpful, and maybe
the --no-network option for guix lint will come in useful as well.
Chris
[-- Attachment #2: signature.asc --]
[-- Type: application/pgp-signature, Size: 962 bytes --]
^ permalink raw reply [flat|nested] 37+ messages in thread
* [bug#35790] [PATCH 4/4] lint: Separate checkers by dependence on the internet.
2019-07-15 22:23 ` bug#35790: " Christopher Baines
@ 2019-07-16 21:34 ` Ludovic Courtès
0 siblings, 0 replies; 37+ messages in thread
From: Ludovic Courtès @ 2019-07-16 21:34 UTC (permalink / raw)
To: Christopher Baines; +Cc: 35790-done
Hi!
Christopher Baines <mail@cbaines.net> skribis:
> Great, I've pushed these to master now.
Yay! \o/
> I hope to start looking at actually trying to load in the lint warnings
> soon. This might involve extending the inferior API if that's helpful. I
> also want to attempt to store translations for the lint warnings in one
> way or another, as that'll begin to address the lack of localisation in
> the Guix Data Service.
Regarding inferiors, you could always build up an “inferior lint
warning” API, similar to what’s done for <inferior-package>, and
likewise for l10n.
It needs some thought because we don’t want to mirror every single Guix
API with an inferior equivalent. So perhaps you can run a large part of
the processing in the inferior.
> There's also some thinking about how to manage the network dependent
> checkers. I'd like to get that information in anyway, but also, I think
> it might be possible to maybe separate out the network independant parts
> of the checkers that are currently in the network dependent list. For
> example, the synopsis checker is only in there as it attempts to connect
> to the network to check if packages are a GNU package, and I'm wondering
> if that can be avoided.
Dunno, but I don’t think it’s super important either.
What might be more useful is to indicate how critical a warning is: lack
of source code is critical, but missing-space-after-period less so.
> Anyway, hopefully the code refactoring is generally helpful, and maybe
> the --no-network option for guix lint will come in useful as well.
Definitely.
Thanks!
Ludo’.
^ permalink raw reply [flat|nested] 37+ messages in thread
end of thread, other threads:[~2019-07-16 21:35 UTC | newest]
Thread overview: 37+ messages (download: mbox.gz follow: Atom feed
-- links below jump to the message on this page --
2019-05-18 9:32 [bug#35790] [PATCH] scripts: lint: Handle warnings with a record type Christopher Baines
2019-05-21 14:41 ` Ludovic Courtès
2019-06-01 18:31 ` Christopher Baines
2019-06-07 7:44 ` Ludovic Courtès
2019-06-16 13:00 ` Christopher Baines
2019-06-20 11:40 ` Ludovic Courtès
2019-06-01 19:09 ` Christopher Baines
2019-06-07 7:38 ` Ludovic Courtès
2019-06-16 12:56 ` [bug#35790] [PATCH] scripts: lint: Separate the message warning text and data Christopher Baines
2019-06-24 8:36 ` Ludovic Courtès
2019-06-29 8:46 ` Christopher Baines
2019-06-16 13:05 ` [bug#35790] [PATCH] scripts: lint: Handle warnings with a record type Christopher Baines
2019-06-20 11:49 ` Ludovic Courtès
2019-06-24 6:46 ` Christopher Baines
2019-06-24 8:33 ` Ludovic Courtès
2019-06-24 8:39 ` Ludovic Courtès
2019-06-29 11:25 ` [bug#35790] [PATCH 1/2] " Christopher Baines
2019-06-29 11:25 ` [bug#35790] [PATCH 2/2] scripts: lint: Separate the message warning text and data Christopher Baines
2019-06-29 11:56 ` [bug#35790] [PATCH] scripts: lint: Handle warnings with a record type Christopher Baines
2019-07-01 12:32 ` Ludovic Courtès
2019-07-02 19:25 ` [bug#35790] [PATCH 1/2] lint: Move the linting code to a different module Christopher Baines
2019-07-02 19:25 ` [bug#35790] [PATCH 2/2] lint: Separate checkers by dependence on the internet Christopher Baines
2019-07-12 14:38 ` Ludovic Courtès
2019-07-14 18:17 ` Christopher Baines
2019-07-12 14:36 ` [bug#35790] [PATCH 1/2] lint: Move the linting code to a different module Ludovic Courtès
2019-07-14 18:03 ` Christopher Baines
2019-07-14 18:23 ` Christopher Baines
2019-07-15 9:20 ` Ludovic Courtès
2019-07-15 19:45 ` [bug#35790] [PATCH 1/4] scripts: lint: Handle warnings with a record type Christopher Baines
2019-07-15 19:45 ` [bug#35790] [PATCH 2/4] scripts: lint: Separate the message warning text and data Christopher Baines
2019-07-15 19:45 ` [bug#35790] [PATCH 3/4] lint: Move the linting code to a different module Christopher Baines
2019-07-15 19:45 ` [bug#35790] [PATCH 4/4] lint: Separate checkers by dependence on the internet Christopher Baines
2019-07-15 20:17 ` Ludovic Courtès
2019-07-15 22:23 ` bug#35790: " Christopher Baines
2019-07-16 21:34 ` [bug#35790] " Ludovic Courtès
2019-07-15 19:51 ` [bug#35790] [PATCH 1/2] lint: Move the linting code to a different module Christopher Baines
2019-07-02 20:15 ` [bug#35790] [PATCH] scripts: lint: Handle warnings with a record type Christopher Baines
Code repositories for project(s) associated with this external index
https://git.savannah.gnu.org/cgit/guix.git
This is an external index of several public inboxes,
see mirroring instructions on how to clone and mirror
all data and code used by this external index.