diff options
| -rw-r--r-- | guix/scripts/lint.scm | 757 | ||||
| -rw-r--r-- | 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 @@ ;;; -;;; 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)) ;;; ;;; 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 ;;; @@ -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)))) + '()))) ;;; @@ -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)))) + (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") |