--- Begin Message ---
|
Subject: |
[PATCH] scripts: lint: Handle warnings with a record type. |
|
Date: |
Sat, 18 May 2019 10:32:06 +0100 |
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 @@
;;;
-;;; 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))
;;;
;;; 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
@@ -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)))
+
(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
--- End Message ---
signature.asc