From patchwork Sat May 18 09:32:06 2019 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 8bit X-Patchwork-Submitter: Christopher Baines X-Patchwork-Id: 13995 Return-Path: X-Original-To: patchwork@mira.cbaines.net Delivered-To: patchwork@mira.cbaines.net Received: by mira.cbaines.net (Postfix, from userid 113) id BD2341701E; Sat, 18 May 2019 10:43:23 +0100 (BST) X-Spam-Checker-Version: SpamAssassin 3.4.0 (2014-02-07) on mira.cbaines.net X-Spam-Level: X-Spam-Status: No, score=-1.9 required=5.0 tests=BAYES_00,UNPARSEABLE_RELAY, URIBL_BLOCKED autolearn=ham autolearn_force=no version=3.4.0 Received: from lists.gnu.org (lists.gnu.org [209.51.188.17]) by mira.cbaines.net (Postfix) with ESMTP id BBB6516FC0 for ; Sat, 18 May 2019 10:43:19 +0100 (BST) Received: from localhost ([127.0.0.1]:59976 helo=lists.gnu.org) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1hRvs7-000240-3t for patchwork@mira.cbaines.net; Sat, 18 May 2019 05:43:19 -0400 Received: from eggs.gnu.org ([209.51.188.92]:44838) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1hRvry-00023k-8C for guix-patches@gnu.org; Sat, 18 May 2019 05:43:17 -0400 Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.71) (envelope-from ) id 1hRvrq-0003Ts-H9 for guix-patches@gnu.org; Sat, 18 May 2019 05:43:10 -0400 Received: from debbugs.gnu.org ([209.51.188.43]:46176) by eggs.gnu.org with esmtps (TLS1.0:RSA_AES_128_CBC_SHA1:16) (Exim 4.71) (envelope-from ) id 1hRvrq-0003Tf-Al for guix-patches@gnu.org; Sat, 18 May 2019 05:43:02 -0400 Received: from Debian-debbugs by debbugs.gnu.org with local (Exim 4.84_2) (envelope-from ) id 1hRvrq-0004hw-7q for guix-patches@gnu.org; Sat, 18 May 2019 05:43:02 -0400 X-Loop: help-debbugs@gnu.org Subject: [bug#35790] [PATCH] scripts: lint: Handle warnings with a record type. Resent-From: Christopher Baines Original-Sender: "Debbugs-submit" Resent-CC: guix-patches@gnu.org Resent-Date: Sat, 18 May 2019 09:43:02 +0000 Resent-Message-ID: Resent-Sender: help-debbugs@gnu.org X-GNU-PR-Message: report 35790 X-GNU-PR-Package: guix-patches X-GNU-PR-Keywords: patch To: 35790@debbugs.gnu.org X-Debbugs-Original-To: guix-patches@gnu.org Received: via spool by submit@debbugs.gnu.org id=B.155817255618054 (code B ref -1); Sat, 18 May 2019 09:43:02 +0000 Received: (at submit) by debbugs.gnu.org; 18 May 2019 09:42:36 +0000 Received: from localhost ([127.0.0.1]:59721 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1hRvrP-0004h8-U9 for submit@debbugs.gnu.org; Sat, 18 May 2019 05:42:35 -0400 Received: from eggs.gnu.org ([209.51.188.92]:58493) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1hRvrL-0004gs-KW for submit@debbugs.gnu.org; Sat, 18 May 2019 05:42:34 -0400 Received: from lists.gnu.org ([209.51.188.17]:50418) by eggs.gnu.org with esmtps (TLS1.0:RSA_AES_256_CBC_SHA1:32) (Exim 4.71) (envelope-from ) id 1hRvrG-0002u7-DY for submit@debbugs.gnu.org; Sat, 18 May 2019 05:42:26 -0400 Received: from eggs.gnu.org ([209.51.188.92]:44318) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1hRvr9-0001TC-9V for guix-patches@gnu.org; Sat, 18 May 2019 05:42:26 -0400 Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.71) (envelope-from ) id 1hRvhM-0003M2-PA for guix-patches@gnu.org; Sat, 18 May 2019 05:32:19 -0400 Received: from mira.cbaines.net ([212.71.252.8]:36974) by eggs.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1hRvhM-0003G2-5c for guix-patches@gnu.org; Sat, 18 May 2019 05:32:12 -0400 Received: from localhost (cpc102582-walt20-2-0-cust14.13-2.cable.virginm.net [86.27.34.15]) by mira.cbaines.net (Postfix) with ESMTPSA id 0F8F916FC0 for ; Sat, 18 May 2019 10:32:07 +0100 (BST) Received: from localhost (localhost [local]) by localhost (OpenSMTPD) with ESMTPA id 8b8f1cd5 for ; Sat, 18 May 2019 09:32:06 +0000 (UTC) From: Christopher Baines Date: Sat, 18 May 2019 10:32:06 +0100 Message-Id: <20190518093206.22069-1-mail@cbaines.net> X-Mailer: git-send-email 2.21.0 MIME-Version: 1.0 X-detected-operating-system: by eggs.gnu.org: GNU/Linux 2.2.x-3.x [generic] X-detected-operating-system: by eggs.gnu.org: GNU/Linux 2.6.x X-BeenThere: debbugs-submit@debbugs.gnu.org X-Mailman-Version: 2.1.18 Precedence: list X-detected-operating-system: by eggs.gnu.org: GNU/Linux 2.2.x-3.x [generic] X-Received-From: 209.51.188.43 X-BeenThere: guix-patches@gnu.org List-Id: List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: guix-patches-bounces+patchwork=mira.cbaines.net@gnu.org Sender: "Guix-patches" X-getmail-retrieved-from-mailbox: Patches 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 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-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 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 + (($ 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 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 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 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 ""))) + ((($ 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"))) + ((($ 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)) + ((($ 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)) + ((($ 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)) + ((($ 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)) + ((($ 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)) + ((($ 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))) + ((($ 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)) + (($ 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"))) + ((($ 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)) + ((($ 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)) + ((($ 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)) + ((($ 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)) + ((($ 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 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)) + ((($ 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)) + ((($ 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)) + ((($ 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)) + ((($ 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)) + ((($ 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)) + ((($ 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)) + ((($ 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)) + ((($ 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)) + (($ 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)) + ((($ 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) + ((($ 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 + ($ 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 + ($ 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 + ($ 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 + ($ 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))) + ((($ 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))))) + ((($ 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) ) 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"))) + (($ 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) ) 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) ) 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) ) 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!" + ) + ) + ((($ 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: ")) + ((($ 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")) + ((($ 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 + ((($ package message location)) message)))) + +(test-equal "formatting: alright" + '() + (append-warnings (check-formatting (dummy-package "x")))) (test-end "lint")