From unknown Thu Sep 11 20:11:55 2025 Content-Disposition: inline Content-Transfer-Encoding: quoted-printable MIME-Version: 1.0 X-Mailer: MIME-tools 5.509 (Entity 5.509) Content-Type: text/plain; charset=utf-8 From: bug#35790 <35790@debbugs.gnu.org> To: bug#35790 <35790@debbugs.gnu.org> Subject: Status: [PATCH] scripts: lint: Handle warnings with a record type. Reply-To: bug#35790 <35790@debbugs.gnu.org> Date: Fri, 12 Sep 2025 03:11:55 +0000 retitle 35790 [PATCH] scripts: lint: Handle warnings with a record type. reassign 35790 guix-patches submitter 35790 Christopher Baines severity 35790 normal tag 35790 patch thanks From debbugs-submit-bounces@debbugs.gnu.org Sat May 18 05:42:36 2019 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 X-Spam-Checker-Version: SpamAssassin 3.3.2 (2011-06-06) on eggs.gnu.org X-Spam-Level: X-Spam-Status: No, score=0.8 required=5.0 tests=BAYES_50,UNPARSEABLE_RELAY, URIBL_BLOCKED autolearn=disabled version=3.3.2 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 To: guix-patches@gnu.org Subject: [PATCH] scripts: lint: Handle warnings with a record type. 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 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: quoted-printable X-detected-operating-system: by eggs.gnu.org: GNU/Linux 2.2.x-3.x [generic] X-Received-From: 212.71.252.8 X-detected-operating-system: by eggs.gnu.org: GNU/Linux 2.6.x X-Spam-Score: -1.3 (-) X-Debbugs-Envelope-To: submit X-BeenThere: debbugs-submit@debbugs.gnu.org X-Mailman-Version: 2.1.18 Precedence: list List-Id: List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: debbugs-submit-bounces@debbugs.gnu.org Sender: "Debbugs-submit" 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 =20 + + lint-warning + lint-warning-package + lint-warning-message + lint-warning-location + + append-warnings + %checkers lint-checker lint-checker? @@ -93,42 +101,65 @@ =20 =0C ;;; -;;; 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 po= rt)) - (thunk))) - (warning -> (get-output-string port))) - (mbegin %state-monad - (munless (string=3D? "" 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)) =20 =0C ;;; ;;; 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))) =20 (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 DESC= RIPTION, 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)))) =20 (define (check-trademarks description) "Check that DESCRIPTION does not contain '=E2=84=A2' or '=C2=AE' cha= racters. See http://www.gnu.org/prep/standards/html_node/Trademarks.html." (match (string-index description (char-set #\=E2=84=A2 #\=C2=AE)) ((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))) =20 (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 b= e kept ;; as is. (G_ "use @code or similar ornament instead of quotes= ") - 'description))) + #:field 'description))) =20 (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 let= ter or digit") - 'description))) + (make-warning + package + (G_ "description should start with an upper-case letter or digit"= ) + #:field 'description))) =20 (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)))) =20 (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=3D> (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=3D> (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") descript= ion) - 'description)))) + #:field 'description)))) =20 (define (package-input-intersection inputs-to-check input-names) "Return the intersection between INPUTS-TO-CHECK, the list of input tu= ples @@ -281,13 +315,13 @@ of a package, and INPUT-NAMES, a list of package sp= ecifications 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)))) =20 (define (check-inputs-should-not-be-an-input-at-all package) ;; Emit a warning if some inputs of PACKAGE are likely to should not b= e @@ -296,14 +330,15 @@ of a package, and INPUT-NAMES, a list of package sp= ecifications 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 al= l") - 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)))) =20 (define (package-name-regexp package) "Return a regexp that matches PACKAGE's name as a word at the beginnin= g of a @@ -314,19 +349,13 @@ line." =20 (define (check-synopsis-style package) ;; Emit a warning if stylistic issues are found in the synopsis of PAC= KAGE. - (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 ca= ses. (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))) =20 (define check-start-article ;; Skip this check for GNU packages, as suggested by Karl Berry's re= ply 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))))) =20 (define (check-synopsis-length synopsis) (when (>=3D (string-length synopsis) 80) - (emit-warning package + (make-warning package (G_ "synopsis should be less than 80 characters long= ") - 'synopsis))) + #:field 'synopsis))) =20 (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))) =20 (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))) =20 (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 SYNO= PSIS, 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)))) =20 (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 SYNO= PSIS, otherwise #f." check-texinfo-markup)) =20 (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") invali= d) - 'synopsis)))) + (make-warning package (format #f (G_ "invalid synopsis: ~s") invali= d) + #:field 'synopsis)))) =20 (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 det= ect ;; 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))) ((=3D 301 (response-code argument)) (if (response-location argument) - (begin - (emit-warning package - (format #f (G_ "permanent redirect fro= m ~a to ~a") - (uri->string uri) - (uri->string - (response-location argument))= )) - #t) - (begin - (emit-warning package - (format #f (G_ "invalid permanent redi= rect \ + (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 redire= ct \ 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=3D? (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))))) =20 (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=3D> (package-source package) origin-patches) '())) =20 - (unless (every (match-lambda ;patch starts with package name? + (append-warnings + (unless (every (match-lambda ;patch starts with package name= ? + ((? string? patch) + (and=3D> (string-contains (basename patch) + (package-name package)) + zero?)) + (_ #f)) ;must be an or something lik= e 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=3D> (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-direc= tory) - patch) - (- (string-length patch) prefi= x) - (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-di= rectory) + patch) + (- (string-length patch) pr= efix) + (string-length patch))) + max) + (make-warning + package + (format #f (G_ "~a: file name is too long") + (basename patch)) + #:field 'patch-file-names))) + (_ #f)) + patches))))) =20 (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=3D? 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=3D? (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=3D? 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=3D? (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))))))) =20 (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)))) =20 (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))) =20 ;; 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 *s= ome* ;; 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)))))) =20 (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." =20 (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)))) =20 (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 t= arball") - '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))))) =20 (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))))))) =20 (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))))) =20 (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=3D> (follow-redirects-to-github uri) (lambda (github-uri) (unless (string=3D? github-uri uri) - (emit-warning + (make-warning package (format #f (G_ "URL should be '~a'") github-uri) - 'source))))) + #:field 'source))))) (origin-uris origin))))) =20 (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 der= ivation: ~a") system (store-protocol-error-message c= )))) ((message-condition? c) - (emit-warning package + (make-warning package (format #f (G_ "failed to create ~a der= ivation: ~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))))) =20 - (for-each try (package-supported-systems package))) + (filter-map try (package-supported-systems package))) =20 (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)))) =20 (define (call-with-networking-fail-safe message error-value proc) "Call PROC catching any network-related errors. Upon a networking err= or, @@ -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 unpa= tched) - ", "))))))))) + (make-warning package + (format #f (G_ "probably vulnerable to ~a"= ) + (string-join (map vulnerability-id= unpatched) + ", "))))))))) =20 (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 =20 =0C @@ -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))))) =20 (define (report-trailing-white-space package line line-number) "Warn about trailing white space in LINE." (unless (or (string=3D? line (string-trim-right line)) (string=3D? 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)))) =20 (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 t= oo ;; 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)))) =20 (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)))) =20 (define %formatting-reporters ;; List of procedures that report formatting issues. These are not se= parate @@ -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 (=3D 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))))))))))) =20 (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 packag= e) (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)) =20 ;; Test the linter. @@ -60,781 +65,705 @@ (define %long-string (make-string 2000 #\a)) =20 +(define (string-match-or-error pattern str) + (or (string-match pattern str) + (error str "did not match" pattern))) + =0C (test-begin "lint") =20 -(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 i= nfraction 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 Thi= ng=E2=84=A2")))) - (check-description-style pkg))) - "should not contain trademark sign")) - (->bool - (string-contains (with-warnings - (let ((pkg (dummy-package "x" - (description "Works with Format=C2= =AE")))) - (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: =E2=84=A2" + "description should not contain trademark sign '=E2=84=A2' at 20" + (match (let ((pkg (dummy-package "x" + (description "Does The Right Thing=E2= =84=A2")))) + (check-description-style pkg)) + ((($ package message location)) message))) + +(test-equal "description: may not contain trademark signs: =C2=AE" + "description should not contain trademark sign '=C2=AE' at 17" + (match (let ((pkg (dummy-package "x" + (description "Works with Format=C2=AE= ")))) + (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' thin= g.")))) - (check-description-style pkg))) - "use @code"))) + (check-description-style pkg)) + ((($ package message location)) message))) =20 -(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))) =20 -(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=C5=9Dis")))) - (check-synopsis-style pkg))) - "no article allowed at the beginning of the synopsis= "))) + (check-synopsis-style pkg)) + ((($ package message location)) message))) =20 -(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-inp= ut)" - (->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-setup= tools)))))) + (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\" \"W= rong 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)))) =20 (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)))) =20 (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))))) =20 (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 (1= 8 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))))) =20 (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))))) =20 (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))))) =20 (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://loca= lhost: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)))))))) =20 (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/v= 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: 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/releas= es/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/releas= es/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/dow= nload/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.g= z") + (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/examp= le/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/ex= ample.git") + (commit "0"))) + (sha256 %null-sha256)))))) + (append-warnings + (check-source-unstable-tarball pkg)))) =20 (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))))) =20 (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 (1= 8 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))))) =20 (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))))) =20 (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://loca= lhost: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))))= )))) =20 (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-u= rl)))) - "" - (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 ar= e + ; 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)))))))) =20 (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"))))) =20 -(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)))) =20 -(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-1= 234")))))))))) - -(test-assert "cve: vulnerability fixed in replacement version" + (append-warnings + (check-vulnerabilities + (dummy-package "pi" + (version "3.14") + (properties `((lint-hidden-cve . ("CVE-2015-123= 4"))))))))) + +(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))) =20 (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)))) =20 (test-assert "formatting: trailing white space" - (string-contains - (with-warnings - ;; Leave the trailing white space on the next line! - (check-formatting (dummy-package "x"))) =20 - "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")) =20 + ((($ package message location)) + message)))) =20 (test-assert "formatting: long line" - (string-contains - (with-warnings - (check-formatting - (dummy-package "x" ;here is a stupid comm= ent 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")) ;her= e 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")))) =20 (test-end "lint") =20 --=20 2.21.0 From debbugs-submit-bounces@debbugs.gnu.org Tue May 21 10:42:05 2019 Received: (at 35790) by debbugs.gnu.org; 21 May 2019 14:42:05 +0000 Received: from localhost ([127.0.0.1]:40517 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1hT5xs-0005iD-Jk for submit@debbugs.gnu.org; Tue, 21 May 2019 10:42:04 -0400 Received: from eggs.gnu.org ([209.51.188.92]:60688) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1hT5xr-0005hg-3b for 35790@debbugs.gnu.org; Tue, 21 May 2019 10:42:03 -0400 Received: from fencepost.gnu.org ([2001:470:142:3::e]:46995) by eggs.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1hT5xl-0007Yo-Iy; Tue, 21 May 2019 10:41:57 -0400 Received: from [2001:660:6102:320:e120:2c8f:8909:cdfe] (port=40298 helo=ribbon) by fencepost.gnu.org with esmtpsa (TLS1.2:RSA_AES_256_CBC_SHA1:256) (Exim 4.82) (envelope-from ) id 1hT5xj-00057f-M6; Tue, 21 May 2019 10:41:57 -0400 From: =?utf-8?Q?Ludovic_Court=C3=A8s?= To: Christopher Baines Subject: Re: [bug#35790] [PATCH] scripts: lint: Handle warnings with a record type. References: <20190518093206.22069-1-mail@cbaines.net> Date: Tue, 21 May 2019 16:41:53 +0200 In-Reply-To: <20190518093206.22069-1-mail@cbaines.net> (Christopher Baines's message of "Sat, 18 May 2019 10:32:06 +0100") Message-ID: <878suz27ke.fsf@gnu.org> User-Agent: Gnus/5.13 (Gnus v5.13) Emacs/26.2 (gnu/linux) MIME-Version: 1.0 Content-Type: text/plain; charset=utf-8 Content-Transfer-Encoding: quoted-printable X-detected-operating-system: by eggs.gnu.org: GNU/Linux 2.2.x-3.x [generic] X-Spam-Score: -2.3 (--) X-Debbugs-Envelope-To: 35790 Cc: 35790@debbugs.gnu.org X-BeenThere: debbugs-submit@debbugs.gnu.org X-Mailman-Version: 2.1.18 Precedence: list List-Id: List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: debbugs-submit-bounces@debbugs.gnu.org Sender: "Debbugs-submit" X-Spam-Score: -3.3 (---) Hello! Christopher Baines skribis: > Rather than emiting warnings directly to a port, have the checkers return= the > warning or warnings. > > This makes it easier to use the warnings in different ways, for example, > loading the data in to a database, as you can work with the > records directly, rather than having to parse the output to determine the > package and location. Yay! > + As a rule of thumb, it=E2=80=99s best to not export the record type descrip= tor (RTD) because then anything could happen. In this case, I think the tests would be just as readable if we used =E2=80=98lint-warning-message=E2= =80=99 & co. instead of matching on the record. WDYT? > +(define* (make-warning package message > + #:key field location) > + (make-lint-warning > + package > + message In practice MESSAGE is already translated. I think it would be more flexible if it were not; =E2=80=98lint-warning-message=E2=80=99 would alway= s return the English message, and it=E2=80=99d be up to the user to call =E2=80=98gettex= t=E2=80=99 on it, like we do for package descriptions. To achieve this, you=E2=80=99d need a little trick so that =E2=80=98xgettex= t=E2=80=99 can still extract the messages, like: (define-syntax-rule make-warning (syntax-rule (G_) ((_ package (G_ message) rest ...) (%make-warning package message rest ...)))) where =E2=80=98%make-warning=E2=80=99 is the procedure you define above. Then you need an explicit call to =E2=80=98G_=E2=80=99 at the point where m= essages are displayed. Does that make sense? > +(define (append-warnings . args) > + (fold (lambda (arg warnings) > + (cond > + ((list? arg) > + (append warnings > + (filter lint-warning? > + arg))) > + ((lint-warning? arg) > + (append warnings > + (list arg))) > + (else warnings))) > + '() > + args)) I always feel that we should have procedures that operate on lists of anything, like =E2=80=98append=E2=80=99, and thus =E2=80=98append-warnings= =E2=80=99 looks like an anti-pattern to me. What about simply ensuring that every checker returns a list of s? That way, we wouldn=E2=80=99t have to do such things, I t= hink. That=E2=80=99s all! Thanks, Ludo=E2=80=99. From debbugs-submit-bounces@debbugs.gnu.org Sat Jun 01 14:31:42 2019 Received: (at 35790) by debbugs.gnu.org; 1 Jun 2019 18:31:42 +0000 Received: from localhost ([127.0.0.1]:38650 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1hX8n8-0008BI-Ke for submit@debbugs.gnu.org; Sat, 01 Jun 2019 14:31:42 -0400 Received: from mira.cbaines.net ([212.71.252.8]:53938) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1hX8n6-0008BA-T9 for 35790@debbugs.gnu.org; Sat, 01 Jun 2019 14:31:41 -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 E577917074 for <35790@debbugs.gnu.org>; Sat, 1 Jun 2019 19:31:35 +0100 (BST) Received: from localhost (localhost [local]) by localhost (OpenSMTPD) with ESMTPA id 3aa55fba for <35790@debbugs.gnu.org>; Sat, 1 Jun 2019 18:31:35 +0000 (UTC) From: Christopher Baines To: 35790@debbugs.gnu.org Subject: [PATCH] scripts: lint: Handle warnings with a record type. Date: Sat, 1 Jun 2019 19:31:35 +0100 Message-Id: <20190601183135.11882-1-mail@cbaines.net> X-Mailer: git-send-email 2.21.0 In-Reply-To: <878suz27ke.fsf@gnu.org> References: <878suz27ke.fsf@gnu.org> MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit X-Debbugs-Envelope-To: 35790 X-BeenThere: debbugs-submit@debbugs.gnu.org X-Mailman-Version: 2.1.18 Precedence: list List-Id: List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: debbugs-submit-bounces@debbugs.gnu.org Sender: "Debbugs-submit" 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 | 757 +++++++++++---------- tests/lint.scm | 1453 +++++++++++++++++++---------------------- 2 files changed, 1102 insertions(+), 1108 deletions(-) diff --git a/guix/scripts/lint.scm b/guix/scripts/lint.scm index dc338a1d7b..1b08068669 100644 --- a/guix/scripts/lint.scm +++ b/guix/scripts/lint.scm @@ -84,6 +84,12 @@ check-formatting run-checkers + lint-warning + lint-warning? + lint-warning-package + lint-warning-message + lint-warning-location + %checkers lint-checker lint-checker? @@ -93,42 +99,48 @@ ;;; -;;; 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))) + warnings)) ;;; ;;; Checkers ;;; + (define-record-type* 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 ;; . (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 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 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))) + stringbool - (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) ) 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) ) 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) ) 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) ) 0 "CVE-2015-1234" (list (cons (package-name package) (package-version package))))))) - (string-null? - (with-warnings - (check-vulnerabilities - (dummy-package - "pi" (version "3.14") (source (dummy-origin)) - (replacement (dummy-package - "pi" (version "3.14") - (source - (dummy-origin - (patches - (list "/a/b/pi-CVE-2015-1234.patch")))))))))))) - -(test-assert "formatting: lonely parentheses" - (string-contains - (with-warnings - (check-formatting - ( - dummy-package "ugly as hell!" - ) - )) - "lonely")) + (check-vulnerabilities + (dummy-package + "pi" (version "3.14") (source (dummy-origin)) + (replacement (dummy-package + "pi" (version "3.14") + (source + (dummy-origin + (patches + (list "/a/b/pi-CVE-2015-1234.patch")))))))))) + +(test-equal "formatting: lonely parentheses" + "parentheses feel lonely, move to the previous or next line" + (single-lint-warning-message + (check-formatting + (dummy-package "ugly as hell!" + ) + ))) (test-assert "formatting: tabulation" - (string-contains - (with-warnings - (check-formatting (dummy-package "leave the tab here: "))) - "tabulation")) + (string-match-or-error + "tabulation on line [0-9]+, column [0-9]+" + (single-lint-warning-message + (check-formatting (dummy-package "leave the tab here: "))))) (test-assert "formatting: trailing white space" - (string-contains - (with-warnings - ;; Leave the trailing white space on the next line! - (check-formatting (dummy-package "x"))) - "trailing white space")) + (string-match-or-error + "trailing white space .*" + ;; Leave the trailing white space on the next line! + (single-lint-warning-message + (check-formatting (dummy-package "x"))))) (test-assert "formatting: long line" - (string-contains - (with-warnings - (check-formatting - (dummy-package "x" ;here is a stupid comment just to make a long line - ))) - "too long")) - -(test-assert "formatting: alright" - (string-null? - (with-warnings - (check-formatting (dummy-package "x"))))) + (string-match-or-error + "line [0-9]+ is way too long \\([0-9]+ characters\\)" + (single-lint-warning-message (check-formatting + (dummy-package "x")) ;here is a stupid comment just to make a long line + ))) + +(test-equal "formatting: alright" + '() + (check-formatting (dummy-package "x"))) (test-end "lint") -- 2.21.0 From debbugs-submit-bounces@debbugs.gnu.org Sat Jun 01 15:09:11 2019 Received: (at 35790) by debbugs.gnu.org; 1 Jun 2019 19:09:11 +0000 Received: from localhost ([127.0.0.1]:38684 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1hX9NO-0002jo-T9 for submit@debbugs.gnu.org; Sat, 01 Jun 2019 15:09:11 -0400 Received: from mira.cbaines.net ([212.71.252.8]:53956) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1hX9NL-0002je-Ql for 35790@debbugs.gnu.org; Sat, 01 Jun 2019 15:09:09 -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 A9C3017071; Sat, 1 Jun 2019 20:09:04 +0100 (BST) Received: from capella (localhost [127.0.0.1]) by localhost (OpenSMTPD) with ESMTP id 9cc7b17e; Sat, 1 Jun 2019 19:09:04 +0000 (UTC) References: <20190518093206.22069-1-mail@cbaines.net> <878suz27ke.fsf@gnu.org> User-agent: mu4e 1.2.0; emacs 26.2 From: Christopher Baines To: Ludovic =?utf-8?Q?Court=C3=A8s?= Subject: Re: [bug#35790] [PATCH] scripts: lint: Handle warnings with a record type. In-reply-to: <878suz27ke.fsf@gnu.org> Date: Sat, 01 Jun 2019 20:09:02 +0100 Message-ID: <87ef4dxgvl.fsf@cbaines.net> MIME-Version: 1.0 Content-Type: multipart/signed; boundary="=-=-="; micalg=pgp-sha512; protocol="application/pgp-signature" X-Spam-Score: -0.0 (/) X-Debbugs-Envelope-To: 35790 Cc: 35790@debbugs.gnu.org X-BeenThere: debbugs-submit@debbugs.gnu.org X-Mailman-Version: 2.1.18 Precedence: list List-Id: List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: debbugs-submit-bounces@debbugs.gnu.org Sender: "Debbugs-submit" X-Spam-Score: -1.0 (-) --=-=-= Content-Type: text/plain; charset=utf-8 Content-Transfer-Encoding: quoted-printable Ludovic Court=C3=A8s writes: > Hello! > > Christopher Baines skribis: > >> Rather than emiting warnings directly to a port, have the checkers retur= n 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. > > Yay! > >> + > > As a rule of thumb, it=E2=80=99s best to not export the record type descr= iptor > (RTD) because then anything could happen. In this case, I think the > tests would be just as readable if we used =E2=80=98lint-warning-message= =E2=80=99 & > co. instead of matching on the record. > > WDYT? Interesting. I've now adjusted the tests accordingly and sent an updated patch. I've stuck with using match, as this gives much better error messages than using car, or lint-warning-message without checking the thing your working with is actually a list with a single warning. I've wrapped this up as a single-lint-warning-message that many of the tests use. >> +(define* (make-warning package message >> + #:key field location) >> + (make-lint-warning >> + package >> + message > > In practice MESSAGE is already translated. I think it would be more > flexible if it were not; =E2=80=98lint-warning-message=E2=80=99 would alw= ays return the > English message, and it=E2=80=99d be up to the user to call =E2=80=98gett= ext=E2=80=99 on it, > like we do for package descriptions. > > To achieve this, you=E2=80=99d need a little trick so that =E2=80=98xgett= ext=E2=80=99 can still > extract the messages, like: > > > (define-syntax-rule make-warning > (syntax-rule (G_) > ((_ package (G_ message) rest ...) > (%make-warning package message rest ...)))) > > where =E2=80=98%make-warning=E2=80=99 is the procedure you define above. > > Then you need an explicit call to =E2=80=98G_=E2=80=99 at the point where= messages are > displayed. > > Does that make sense? Yes, but I'm unsure it'll work for all the messages. Some of them it translates a format string first, then uses that format string, and that becomes the message, e.g. (format #f (G_ "invalid description: ~s") description) Given that you'd be trying to get the translation for "invalid description: guile" for example, I'm not sure you can defer the translation without also defering customising the message, if that makes sense? I haven't actually tried this yet, so I could be wrong. >> +(define (append-warnings . args) >> + (fold (lambda (arg warnings) >> + (cond >> + ((list? arg) >> + (append warnings >> + (filter lint-warning? >> + arg))) >> + ((lint-warning? arg) >> + (append warnings >> + (list arg))) >> + (else warnings))) >> + '() >> + args)) > > I always feel that we should have procedures that operate on lists of > anything, like =E2=80=98append=E2=80=99, and thus =E2=80=98append-warning= s=E2=80=99 looks like an > anti-pattern to me. > > What about simply ensuring that every checker returns a list of > s? That way, we wouldn=E2=80=99t have to do such things, I= think. I did consider that initially, but it involved restructuring the code even more, so I put it off. In this latest patch though, I have adjusted it so all the checkers return lists of warnings. Thanks for taking a look :) Chris --=-=-= Content-Type: application/pgp-signature; name="signature.asc" -----BEGIN PGP SIGNATURE----- iQKTBAEBCgB9FiEEPonu50WOcg2XVOCyXiijOwuE9XcFAlzyzU5fFIAAAAAALgAo aXNzdWVyLWZwckBub3RhdGlvbnMub3BlbnBncC5maWZ0aGhvcnNlbWFuLm5ldDNF ODlFRUU3NDU4RTcyMEQ5NzU0RTBCMjVFMjhBMzNCMEI4NEY1NzcACgkQXiijOwuE 9XfciA/+PintFk8rgFxv4dP9J8jJzehnYC7/cGNpGnfAf3JPN9uXmRRQlgPUJcvK Q1VP4fCqZVsLRWgRkjuLMseg58GRjCs/kXHp/6UX6uzfHFc+j75O5HDRfytK/ZpN 1yDq8rRogI+53HYJquVP2e1d25pWaqihWtHMt07ZKcAISNC6Shw0/lMKntI49yp+ pOwTBwuiysZLjpM5O6Gfbc0t2Slk7VW13t/c5WQp1Cs+ZEvKMlsCo5ra/gPF/YT3 YS0KoHATV0Ng4Qf92PzOsuXCnYDiAYQZqD3H7UNpL0nC3UbP6v4jZJ1t7FyXUHOV qfaO0XwStTa5+pdnz5W2iQPziyFVxL9JDMkpX+xSOwKrDFt1uDX0fBU/FtOapJiJ eIIrDdsHt66i3Ozz111OnLq7pPpeDcdKbW3E+hL9/WJ/OK/JxleXIx/ZEq32eECT DXEzg/HGZeD/ipCmFId5L58NnTxCwqy/fnrOl5pHmwixKA9HkuOis82ILJgdRACu Jd8TGxnyocJdQ6PqGX9nD9XHA7ecTJqN+wc5ujmA8FMJDN74pkasXqgzNEj3yAkg Lc3fobbL7qMYNMn+WKi/MqFlp5jlzukUHJtnc2V7GSX9NkpjuUG6FOiSnqD1ZB1Q Cn+nDVY6j/+aJpmE0XfiuArkqaNpWsUYTFmhvWUIlPz+XOXj51s= =j76C -----END PGP SIGNATURE----- --=-=-=-- From debbugs-submit-bounces@debbugs.gnu.org Fri Jun 07 03:38:22 2019 Received: (at 35790) by debbugs.gnu.org; 7 Jun 2019 07:38:23 +0000 Received: from localhost ([127.0.0.1]:51305 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1hZ9SA-00063Q-F6 for submit@debbugs.gnu.org; Fri, 07 Jun 2019 03:38:22 -0400 Received: from eggs.gnu.org ([209.51.188.92]:40583) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1hZ9S8-00063C-1L for 35790@debbugs.gnu.org; Fri, 07 Jun 2019 03:38:21 -0400 Received: from fencepost.gnu.org ([2001:470:142:3::e]:58992) by eggs.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1hZ9S2-0000VH-IF; Fri, 07 Jun 2019 03:38:14 -0400 Received: from [2001:660:6102:320:e120:2c8f:8909:cdfe] (port=37670 helo=ribbon) by fencepost.gnu.org with esmtpsa (TLS1.2:RSA_AES_256_CBC_SHA1:256) (Exim 4.82) (envelope-from ) id 1hZ9Rw-0001u7-4J; Fri, 07 Jun 2019 03:38:12 -0400 From: =?utf-8?Q?Ludovic_Court=C3=A8s?= To: Christopher Baines Subject: Re: [bug#35790] [PATCH] scripts: lint: Handle warnings with a record type. References: <20190518093206.22069-1-mail@cbaines.net> <878suz27ke.fsf@gnu.org> <87ef4dxgvl.fsf@cbaines.net> Date: Fri, 07 Jun 2019 09:38:05 +0200 In-Reply-To: <87ef4dxgvl.fsf@cbaines.net> (Christopher Baines's message of "Sat, 01 Jun 2019 20:09:02 +0100") Message-ID: <87pnnpj15u.fsf@gnu.org> User-Agent: Gnus/5.13 (Gnus v5.13) Emacs/26.2 (gnu/linux) MIME-Version: 1.0 Content-Type: text/plain; charset=utf-8 Content-Transfer-Encoding: quoted-printable X-detected-operating-system: by eggs.gnu.org: GNU/Linux 2.2.x-3.x [generic] X-Spam-Score: -2.3 (--) X-Debbugs-Envelope-To: 35790 Cc: 35790@debbugs.gnu.org X-BeenThere: debbugs-submit@debbugs.gnu.org X-Mailman-Version: 2.1.18 Precedence: list List-Id: List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: debbugs-submit-bounces@debbugs.gnu.org Sender: "Debbugs-submit" X-Spam-Score: -3.3 (---) Hello, Christopher Baines skribis: > Ludovic Court=C3=A8s writes: [...] >>> +(define* (make-warning package message >>> + #:key field location) >>> + (make-lint-warning >>> + package >>> + message >> >> In practice MESSAGE is already translated. I think it would be more >> flexible if it were not; =E2=80=98lint-warning-message=E2=80=99 would al= ways return the >> English message, and it=E2=80=99d be up to the user to call =E2=80=98get= text=E2=80=99 on it, >> like we do for package descriptions. >> >> To achieve this, you=E2=80=99d need a little trick so that =E2=80=98xget= text=E2=80=99 can still >> extract the messages, like: >> >> >> (define-syntax-rule make-warning >> (syntax-rule (G_) >> ((_ package (G_ message) rest ...) >> (%make-warning package message rest ...)))) >> >> where =E2=80=98%make-warning=E2=80=99 is the procedure you define above. >> >> Then you need an explicit call to =E2=80=98G_=E2=80=99 at the point wher= e messages are >> displayed. >> >> Does that make sense? > > Yes, but I'm unsure it'll work for all the messages. > > Some of them it translates a format string first, then uses that format > string, and that becomes the message, e.g. > > (format #f (G_ "invalid description: ~s") description) > > Given that you'd be trying to get the translation for "invalid > description: guile" for example, I'm not sure you can defer the > translation without also defering customising the message, if that makes > sense? Good point! A possibility would be to pass =E2=80=98make-warning=E2=80=99 a =E2=80=98fo= rmat=E2=80=99 list instead of a single string: (make-warning package (list (G_ "~a is bad") 'something) =E2=80=A6) That=E2=80=99d solve the problem but it=E2=80=99d have to be packaged nicel= y to avoid having too much boilerplate. WDYT? Thanks, Ludo=E2=80=99. From debbugs-submit-bounces@debbugs.gnu.org Fri Jun 07 03:44:44 2019 Received: (at 35790) by debbugs.gnu.org; 7 Jun 2019 07:44:44 +0000 Received: from localhost ([127.0.0.1]:51319 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1hZ9YK-0006CW-Dc for submit@debbugs.gnu.org; Fri, 07 Jun 2019 03:44:44 -0400 Received: from eggs.gnu.org ([209.51.188.92]:42234) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1hZ9YG-0006CG-Q0 for 35790@debbugs.gnu.org; Fri, 07 Jun 2019 03:44:41 -0400 Received: from fencepost.gnu.org ([2001:470:142:3::e]:59057) by eggs.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1hZ9YB-0004mk-42; Fri, 07 Jun 2019 03:44:35 -0400 Received: from [2001:660:6102:320:e120:2c8f:8909:cdfe] (port=37672 helo=ribbon) by fencepost.gnu.org with esmtpsa (TLS1.2:RSA_AES_256_CBC_SHA1:256) (Exim 4.82) (envelope-from ) id 1hZ9YA-0002MK-Nm; Fri, 07 Jun 2019 03:44:34 -0400 From: =?utf-8?Q?Ludovic_Court=C3=A8s?= To: Christopher Baines Subject: Re: [bug#35790] [PATCH] scripts: lint: Handle warnings with a record type. References: <878suz27ke.fsf@gnu.org> <20190601183135.11882-1-mail@cbaines.net> Date: Fri, 07 Jun 2019 09:44:33 +0200 In-Reply-To: <20190601183135.11882-1-mail@cbaines.net> (Christopher Baines's message of "Sat, 1 Jun 2019 19:31:35 +0100") Message-ID: <87ftolj0v2.fsf@gnu.org> User-Agent: Gnus/5.13 (Gnus v5.13) Emacs/26.2 (gnu/linux) MIME-Version: 1.0 Content-Type: text/plain; charset=utf-8 Content-Transfer-Encoding: quoted-printable X-detected-operating-system: by eggs.gnu.org: GNU/Linux 2.2.x-3.x [generic] X-Spam-Score: -2.3 (--) X-Debbugs-Envelope-To: 35790 Cc: 35790@debbugs.gnu.org X-BeenThere: debbugs-submit@debbugs.gnu.org X-Mailman-Version: 2.1.18 Precedence: list List-Id: List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: debbugs-submit-bounces@debbugs.gnu.org Sender: "Debbugs-submit" X-Spam-Score: -3.3 (---) Hello, Christopher Baines skribis: > Rather than emiting warnings directly to a port, have the checkers return= the > warning or warnings. > > This makes it easier to use the warnings in different ways, for example, > loading the data in to a database, as you can work with the > records directly, rather than having to parse the output to determine the > package and location. I like it! Maybe we should just ignore the i18n issue for now and keep already-translated messages in . One question I have: before, warnings would be emitted as we go; now, we first collect all the warnings for a given package, and emit all of them at once. How does it look in terms of UX? Perhaps an improvement would be to use SRFI-41 streams instead of lists to address this issue, but=E2=80=A6 future work. :-) WDYT? Ludo=E2=80=99. From debbugs-submit-bounces@debbugs.gnu.org Sun Jun 16 08:56:15 2019 Received: (at 35790) by debbugs.gnu.org; 16 Jun 2019 12:56:15 +0000 Received: from localhost ([127.0.0.1]:39972 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1hcUhi-0006JR-OB for submit@debbugs.gnu.org; Sun, 16 Jun 2019 08:56:15 -0400 Received: from mira.cbaines.net ([212.71.252.8]:35176) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1hcUhe-0006JG-Jc for 35790@debbugs.gnu.org; Sun, 16 Jun 2019 08:56:11 -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 16D5B1707A for <35790@debbugs.gnu.org>; Sun, 16 Jun 2019 13:56:09 +0100 (BST) Received: from localhost (localhost [local]) by localhost (OpenSMTPD) with ESMTPA id 60be5b86 for <35790@debbugs.gnu.org>; Sun, 16 Jun 2019 12:56:08 +0000 (UTC) From: Christopher Baines To: 35790@debbugs.gnu.org Subject: [PATCH] scripts: lint: Separate the message warning text and data. Date: Sun, 16 Jun 2019 13:56:08 +0100 Message-Id: <20190616125608.15690-1-mail@cbaines.net> X-Mailer: git-send-email 2.21.0 In-Reply-To: <87pnnpj15u.fsf@gnu.org> References: <87pnnpj15u.fsf@gnu.org> MIME-Version: 1.0 Content-Transfer-Encoding: 8bit X-Spam-Score: 0.0 (/) X-Debbugs-Envelope-To: 35790 X-BeenThere: debbugs-submit@debbugs.gnu.org X-Mailman-Version: 2.1.18 Precedence: list List-Id: List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: debbugs-submit-bounces@debbugs.gnu.org Sender: "Debbugs-submit" X-Spam-Score: -1.0 (-) So that translations can be handled more flexibly, rather than having to translate the message text within the checker. --- guix/scripts/lint.scm | 194 ++++++++++++++++++++++-------------------- 1 file changed, 104 insertions(+), 90 deletions(-) diff --git a/guix/scripts/lint.scm b/guix/scripts/lint.scm index 1b08068669..d1919d8e0a 100644 --- a/guix/scripts/lint.scm +++ b/guix/scripts/lint.scm @@ -88,6 +88,8 @@ lint-warning? lint-warning-package lint-warning-message + lint-warning-message-text + lint-warning-message-data lint-warning-location %checkers @@ -105,35 +107,51 @@ (define-record-type* lint-warning make-lint-warning lint-warning? - (package lint-warning-package) - (message lint-warning-message) - (location lint-warning-location - (default #f))) + (package lint-warning-package) + (message-text lint-warning-message-text) + (message-data lint-warning-message-data + (default '())) + (location lint-warning-location + (default #f))) + +(define (lint-warning-message warning) + (apply format #f + (G_ (lint-warning-message-text warning)) + (lint-warning-message-data warning))) (define (package-file package) (location-file (package-location package))) -(define* (make-warning package message - #:key field location) +(define* (%make-warning package message-text + #:optional (message-data '()) + #:key field location) (make-lint-warning package - message + message-text + message-data (or location (package-field-location package field) (package-location package)))) +(define-syntax make-warning + (syntax-rules (G_) + ((_ package (G_ message) rest ...) + (%make-warning package message rest ...)) + ((_ package message rest ...) + (%make-warning package message rest ...)))) + (define (emit-warnings warnings) ;; Emit a warning about PACKAGE, printing the location of FIELD if it is ;; given, the location of PACKAGE otherwise, the full name of PACKAGE and the ;; provided MESSAGE. (for-each (match-lambda - (($ package message loc) + (($ package message-text message-data loc) (format (guix-warning-port) "~a: ~a@~a: ~a~%" (location->string loc) (package-name package) (package-version package) - message))) + (apply format #f (G_ message-text) message-data)))) warnings)) @@ -199,9 +217,9 @@ http://www.gnu.org/prep/standards/html_node/Trademarks.html." ((and (? number?) index) (list (make-warning package - (format #f (G_ "description should not contain ~ + (G_ "description should not contain ~ trademark sign '~a' at ~d") - (string-ref description index) index) + (list (string-ref description index) index) #:field 'description))) (else '()))) @@ -242,10 +260,10 @@ trademark sign '~a' at ~d") '() (list (make-warning package - (format #f (G_ "sentences in description should be followed ~ + (G_ "sentences in description should be followed ~ by two spaces; possible infraction~p at ~{~a~^, ~}") - (length infractions) - infractions) + (list (length infractions) + infractions) #:field 'description))))) (let ((description (package-description package))) @@ -263,7 +281,8 @@ by two spaces; possible infraction~p at ~{~a~^, ~}") (check-proper-start plain-description)))) (list (make-warning package - (format #f (G_ "invalid description: ~s") description) + (G_ "invalid description: ~s") + (list description) #:field 'description))))) (define (package-input-intersection inputs-to-check input-names) @@ -308,8 +327,8 @@ of a package, and INPUT-NAMES, a list of package specifications such as (map (lambda (input) (make-warning package - (format #f (G_ "'~a' should probably be a native input") - input) + (G_ "'~a' should probably be a native input") + (list input) #:field 'inputs)) (package-input-intersection inputs input-names)))) @@ -323,9 +342,8 @@ of a package, and INPUT-NAMES, a list of package specifications such as (map (lambda (input) (make-warning package - (format #f - (G_ "'~a' should probably not be an input at all") - input) + (G_ "'~a' should probably not be an input at all") + (list input) #:field 'inputs)) (package-input-intersection (package-direct-inputs package) input-names)))) @@ -423,7 +441,9 @@ markup is valid return a plain-text version of SYNOPSIS, otherwise #f." checks)) (invalid (list - (make-warning package (format #f (G_ "invalid synopsis: ~s") invalid) + (make-warning package + (G_ "invalid synopsis: ~s") + (list invalid) #:field 'synopsis))))) (define* (probe-uri uri #:key timeout) @@ -540,64 +560,59 @@ PACKAGE mentionning the FIELD." ;; such malicious behavior. (or (> length 1000) (make-warning package - (format #f - (G_ "URI ~a returned \ + (G_ "URI ~a returned \ suspiciously small file (~a bytes)") - (uri->string uri) - length) + (list (uri->string uri) + length) #:field field))) (_ #t))) ((= 301 (response-code argument)) (if (response-location argument) (make-warning package - (format #f (G_ "permanent redirect from ~a to ~a") - (uri->string uri) - (uri->string - (response-location argument))) + (G_ "permanent redirect from ~a to ~a") + (list (uri->string uri) + (uri->string + (response-location argument))) #:field field) (make-warning package - (format #f (G_ "invalid permanent redirect \ + (G_ "invalid permanent redirect \ from ~a") - (uri->string uri)) + (list (uri->string uri)) #:field field))) (else (make-warning package - (format #f - (G_ "URI ~a not reachable: ~a (~s)") - (uri->string uri) - (response-code argument) - (response-reason-phrase argument)) + (G_ "URI ~a not reachable: ~a (~s)") + (list (uri->string uri) + (response-code argument) + (response-reason-phrase argument)) #:field field)))) ((ftp-response) (match argument (('ok) #t) (('error port command code message) (make-warning package - (format #f - (G_ "URI ~a not reachable: ~a (~s)") - (uri->string uri) - code (string-trim-both message)) + (G_ "URI ~a not reachable: ~a (~s)") + (list (uri->string uri) + code (string-trim-both message)) #:field field)))) ((getaddrinfo-error) (make-warning package - (format #f - (G_ "URI ~a domain not found: ~a") - (uri->string uri) - (gai-strerror (car argument))) + (G_ "URI ~a domain not found: ~a") + (list (uri->string uri) + (gai-strerror (car argument))) #:field field)) ((system-error) (make-warning package - (format #f - (G_ "URI ~a unreachable: ~a") - (uri->string uri) - (strerror - (system-error-errno - (cons status argument)))) + (G_ "URI ~a unreachable: ~a") + (list (uri->string uri) + (strerror + (system-error-errno + (cons status argument)))) #:field field)) ((tls-certificate-error) (make-warning package - (format #f (G_ "TLS certificate error: ~a") - (tls-certificate-error-string argument)) + (G_ "TLS certificate error: ~a") + (list (tls-certificate-error-string argument)) #:field field)) ((invalid-http-response gnutls-error) ;; Probably a misbehaving server; ignore. @@ -627,8 +642,9 @@ from ~a") #:field 'home-page)))) (else (list - (make-warning package (format #f (G_ "invalid home page URL: ~s") - (package-home-page package)) + (make-warning package + (G_ "invalid home page URL: ~s") + (list (package-home-page package)) #:field 'home-page)))))) (define %distro-directory @@ -674,8 +690,8 @@ patch could not be found." max) (make-warning package - (format #f (G_ "~a: file name is too long") - (basename patch)) + (G_ "~a: file name is too long") + (list (basename patch)) #:field 'patch-file-names) #f)) (_ #f)) @@ -716,8 +732,8 @@ descriptions maintained upstream." (not (string=? upstream downstream)))) (list (make-warning package - (format #f (G_ "proposed synopsis: ~s~%") - upstream) + (G_ "proposed synopsis: ~s~%") + (list upstream) #:field 'synopsis)) '())) @@ -730,9 +746,8 @@ descriptions maintained upstream." (list (make-warning package - (format #f - (G_ "proposed description:~% \"~a\"~%") - (fill-paragraph (escape-quotes upstream) 77 7)) + (G_ "proposed description:~% \"~a\"~%") + (list (fill-paragraph (escape-quotes upstream) 77 7)) #:field 'description)) '())))))) @@ -831,10 +846,10 @@ descriptions maintained upstream." (loop rest)) (prefix (make-warning package - (format #f (G_ "URL should be \ + (G_ "URL should be \ 'mirror://~a/~a'") - mirror-id - (string-drop uri (string-length prefix))) + (list mirror-id + (string-drop uri (string-length prefix))) #:field 'source))))))) (let ((origin (package-source package))) @@ -876,7 +891,8 @@ descriptions maintained upstream." #f (make-warning package - (format #f (G_ "URL should be '~a'") github-uri) + (G_ "URL should be '~a'") + (list github-uri) #:field 'source))))) (origin-uris origin)) '()))) @@ -888,14 +904,14 @@ descriptions maintained upstream." (lambda () (guard (c ((store-protocol-error? c) (make-warning package - (format #f (G_ "failed to create ~a derivation: ~a") - system - (store-protocol-error-message c)))) + (G_ "failed to create ~a derivation: ~a") + (list system + (store-protocol-error-message c)))) ((message-condition? c) (make-warning package - (format #f (G_ "failed to create ~a derivation: ~a") - system - (condition-message c))))) + (G_ "failed to create ~a derivation: ~a") + (list system + (condition-message c))))) (with-store store ;; Disable grafts since it can entail rebuilds. (parameterize ((%graft? #f)) @@ -910,8 +926,8 @@ descriptions maintained upstream." #:graft? #f))))))) (lambda args (make-warning package - (format #f (G_ "failed to create ~a derivation: ~s") - system args))))) + (G_ "failed to create ~a derivation: ~s") + (list system args))))) (filter lint-warning? (map try (package-supported-systems package)))) @@ -1001,15 +1017,15 @@ the NIST server non-fatal." (list (make-warning package - (format #f (G_ "probably vulnerable to ~a") - (string-join (map vulnerability-id unpatched) - ", ")))))))))) + (G_ "probably vulnerable to ~a") + (list (string-join (map vulnerability-id unpatched) + ", ")))))))))) (define (check-for-updates package) "Check if there is an update available for PACKAGE." (match (with-networking-fail-safe - (format #f (G_ "while retrieving upstream info for '~a'") - (package-name package)) + (G_ "while retrieving upstream info for '~a'") + (list (package-name package)) #f (package-latest-release* package (force %updaters))) ((? upstream-source? source) @@ -1017,8 +1033,8 @@ the NIST server non-fatal." (package-version package)) (list (make-warning package - (format #f (G_ "can be upgraded to ~a") - (upstream-source-version source)) + (G_ "can be upgraded to ~a") + (list (upstream-source-version source)) #:field 'version)) '())) (#f '()))) ; cannot find newer upstream release @@ -1034,8 +1050,8 @@ the NIST server non-fatal." (#f #t) (index (make-warning package - (format #f (G_ "tabulation on line ~a, column ~a") - line-number index) + (G_ "tabulation on line ~a, column ~a") + (list line-number index) #:location (location (package-file package) line-number @@ -1046,9 +1062,8 @@ the NIST server non-fatal." (unless (or (string=? line (string-trim-right line)) (string=? line (string #\page))) (make-warning package - (format #f - (G_ "trailing white space on line ~a") - line-number) + (G_ "trailing white space on line ~a") + (list line-number) #:location (location (package-file package) line-number @@ -1061,8 +1076,8 @@ the NIST server non-fatal." ;; much noise. (when (> (string-length line) 90) (make-warning package - (format #f (G_ "line ~a is way too long (~a characters)") - line-number (string-length line)) + (G_ "line ~a is way too long (~a characters)") + (list line-number (string-length line)) #:location (location (package-file package) line-number @@ -1075,10 +1090,9 @@ the NIST server non-fatal." "Emit a warning if LINE contains hanging parentheses." (when (regexp-exec %hanging-paren-rx line) (make-warning package - (format #f - (G_ "parentheses feel lonely, \ + (G_ "parentheses feel lonely, \ move to the previous or next line") - line-number) + (list line-number) #:location (location (package-file package) line-number -- 2.21.0 From debbugs-submit-bounces@debbugs.gnu.org Sun Jun 16 09:00:22 2019 Received: (at 35790) by debbugs.gnu.org; 16 Jun 2019 13:00:22 +0000 Received: from localhost ([127.0.0.1]:39976 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1hcUlh-0006SI-Ot for submit@debbugs.gnu.org; Sun, 16 Jun 2019 09:00:21 -0400 Received: from mira.cbaines.net ([212.71.252.8]:35184) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1hcUlf-0006S8-N9 for 35790@debbugs.gnu.org; Sun, 16 Jun 2019 09:00:20 -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 318461707A; Sun, 16 Jun 2019 14:00:19 +0100 (BST) Received: from capella (localhost [127.0.0.1]) by localhost (OpenSMTPD) with ESMTP id 3f0d5f56; Sun, 16 Jun 2019 13:00:19 +0000 (UTC) References: <878suz27ke.fsf@gnu.org> <20190601183135.11882-1-mail@cbaines.net> <87ftolj0v2.fsf@gnu.org> User-agent: mu4e 1.2.0; emacs 26.2 From: Christopher Baines To: Ludovic =?utf-8?Q?Court=C3=A8s?= Subject: Re: [bug#35790] [PATCH] scripts: lint: Handle warnings with a record type. In-reply-to: <87ftolj0v2.fsf@gnu.org> Date: Sun, 16 Jun 2019 14:00:16 +0100 Message-ID: <87imt5u1lr.fsf@cbaines.net> MIME-Version: 1.0 Content-Type: multipart/signed; boundary="=-=-="; micalg=pgp-sha512; protocol="application/pgp-signature" X-Spam-Score: -0.0 (/) X-Debbugs-Envelope-To: 35790 Cc: 35790@debbugs.gnu.org X-BeenThere: debbugs-submit@debbugs.gnu.org X-Mailman-Version: 2.1.18 Precedence: list List-Id: List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: debbugs-submit-bounces@debbugs.gnu.org Sender: "Debbugs-submit" X-Spam-Score: -1.0 (-) --=-=-= Content-Type: text/plain; charset=utf-8 Content-Transfer-Encoding: quoted-printable Ludovic Court=C3=A8s writes: > Hello, > > Christopher Baines skribis: > >> Rather than emiting warnings directly to a port, have the checkers retur= n 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. > > I like it! > > Maybe we should just ignore the i18n issue for now and keep > already-translated messages in . I want the Guix Data Service to support internationalisation at some point, so I've had a go at doing this. I'll say more in reply to your other email. > One question I have: before, warnings would be emitted as we go; now, we > first collect all the warnings for a given package, and emit all of them > at once. How does it look in terms of UX? Not quite, warnings are emitted once returned from each checker for each package. The display will only be delayed if a checker takes a long time to return the warnings, which I don't think happens (or at least happens much). --=-=-= Content-Type: application/pgp-signature; name="signature.asc" -----BEGIN PGP SIGNATURE----- iQKTBAEBCgB9FiEEPonu50WOcg2XVOCyXiijOwuE9XcFAl0GPWBfFIAAAAAALgAo aXNzdWVyLWZwckBub3RhdGlvbnMub3BlbnBncC5maWZ0aGhvcnNlbWFuLm5ldDNF ODlFRUU3NDU4RTcyMEQ5NzU0RTBCMjVFMjhBMzNCMEI4NEY1NzcACgkQXiijOwuE 9XdENBAAhWupmqSN5YSvpDqC9pcasK935jX60J7uUgWx1qiMVvti1viiD54bhHDP UwsDTfWDL1TYHPZzpoCMoCn0GZXWDR7fD5KclU4e7FlRgwxfsR7TKLc58i0LRYV4 Cxpf5+Jof5kNIiJTI1wHpK5s+aj1ZBzqj4G8PMbYAt8QM/f6BwCqCu3WSvOSsunm nHvhrIz7S5J1rvNKyGeyVZL24aogr3cmNFLyZLJCuvC8PsPyv7B6PCqB6aroA9cY Jjfppffz06PfMgoudZI+c8UDRm2X8kGtu5f6dgq5KQCkwjeouaFEGNi+fjCXP6u4 YYVNwUQDuVEx4Rtve+uZGXa5rZqJEL5B9N+7pCClBN9yixBRf11zqV+7VzZDoby2 FqQSFMoQVlBeXtsP7C/vjXstPPNH1yXMyoLSeH2Gnp/4juLttP4crszQFl/DUjjy VDnur6f3K4sM+QhUjciuG3pZ2SRRUXDGTpy7KWcYZVLjG2AgeX2Y7sGBmGKpWYPd KozFfFr0zANCELfwOYOwu/Ig6ItZMvPY0SobmnTEsJ2bPegw9kKDU+zyHK0IlpEG lRSfZSqxq/rWiqLra02v3utGi22GqDszT3ELe2JhrdJgsMrpR+AdqR+uLsgtI6sx MLkbsHdhUFsZlErFTMfvhfuiuSJSKS2XIWmUWjK8q07DBk4lyq0= =cG/F -----END PGP SIGNATURE----- --=-=-=-- From debbugs-submit-bounces@debbugs.gnu.org Sun Jun 16 09:06:05 2019 Received: (at 35790) by debbugs.gnu.org; 16 Jun 2019 13:06:06 +0000 Received: from localhost ([127.0.0.1]:39982 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1hcUrF-0006bT-F7 for submit@debbugs.gnu.org; Sun, 16 Jun 2019 09:06:05 -0400 Received: from mira.cbaines.net ([212.71.252.8]:35194) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1hcUrD-0006bI-68 for 35790@debbugs.gnu.org; Sun, 16 Jun 2019 09:06:04 -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 160311707A; Sun, 16 Jun 2019 14:05:58 +0100 (BST) Received: from capella (localhost [127.0.0.1]) by localhost (OpenSMTPD) with ESMTP id 97148565; Sun, 16 Jun 2019 13:05:57 +0000 (UTC) References: <20190518093206.22069-1-mail@cbaines.net> <878suz27ke.fsf@gnu.org> <87ef4dxgvl.fsf@cbaines.net> <87pnnpj15u.fsf@gnu.org> User-agent: mu4e 1.2.0; emacs 26.2 From: Christopher Baines To: Ludovic =?utf-8?Q?Court=C3=A8s?= Subject: Re: [bug#35790] [PATCH] scripts: lint: Handle warnings with a record type. In-reply-to: <87pnnpj15u.fsf@gnu.org> Date: Sun, 16 Jun 2019 14:05:55 +0100 Message-ID: <87h88pu1cc.fsf@cbaines.net> MIME-Version: 1.0 Content-Type: multipart/signed; boundary="=-=-="; micalg=pgp-sha512; protocol="application/pgp-signature" X-Spam-Score: -0.0 (/) X-Debbugs-Envelope-To: 35790 Cc: 35790@debbugs.gnu.org X-BeenThere: debbugs-submit@debbugs.gnu.org X-Mailman-Version: 2.1.18 Precedence: list List-Id: List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: debbugs-submit-bounces@debbugs.gnu.org Sender: "Debbugs-submit" X-Spam-Score: -1.0 (-) --=-=-= Content-Type: text/plain; charset=utf-8 Content-Transfer-Encoding: quoted-printable Ludovic Court=C3=A8s writes: > A possibility would be to pass =E2=80=98make-warning=E2=80=99 a =E2=80=98= format=E2=80=99 list instead of > a single string: > > (make-warning package (list (G_ "~a is bad") 'something) =E2=80=A6) > > That=E2=80=99d solve the problem but it=E2=80=99d have to be packaged nic= ely to avoid > having too much boilerplate. I've now made an attempt at doing this, I've kept the changes separate for now, and I've sent them as a separate patch. I'm not sure I've got it working yet though. I've been testing with the zile package, as there's a lint warning for the synopsis, however, if I try to set the language to Spanish, it isn't translated. I've also tried checking the existing behaviour, but that doesn't seem to work either: =E2=86=92 LC_MESSAGES=3Des_ES LANGUAGE=3Des_ES LC_ALL=3Des_ES ./pre-inst-= env guile ... scheme@(guile-user)> (use-modules (guix i18n)) scheme@(guile-user)> (G_ "~a: ~a: proposed synopsis: ~s~%") $1 =3D "~a: ~a: proposed synopsis: ~s~%" Many of the translated strings won't match up with the code now as I've changed them. I did try changing the Spanish translation for this proposed synopsis message to match the code, but it didn't seem to work. Any ideas on what's going on here? Chris --=-=-= Content-Type: application/pgp-signature; name="signature.asc" -----BEGIN PGP SIGNATURE----- iQKTBAEBCgB9FiEEPonu50WOcg2XVOCyXiijOwuE9XcFAl0GPrNfFIAAAAAALgAo aXNzdWVyLWZwckBub3RhdGlvbnMub3BlbnBncC5maWZ0aGhvcnNlbWFuLm5ldDNF ODlFRUU3NDU4RTcyMEQ5NzU0RTBCMjVFMjhBMzNCMEI4NEY1NzcACgkQXiijOwuE 9Xd+bhAAgQZAlj6XXyExZ03f+o+YxD00xnELzUBXTGXn9b+n/JdSJZ5UAcJaRqUK 8ciPIv0mzRbFKYiWRgM1vdSQo/4f9+YDhbRJOBbEApUs69HQfegqYE2Dv6TfZKiF fAYq3COzwaeYUZL0DQu6yz4+Kyq7ANMTomMtoyfoFMacMy2TEpV+eN3JvlPgj/YV 0nyzsCxxBnw20fx4L9DCV4IOaMA4wqBJmBwRahwWw9WOdpDlhIRUc3AydZxx2nzi s/UMlGuuov1WVLZ2fa3VJv5rE3hSguZxf8yUJypPMzsd37EUIhe0vpxVVc/Hl4qV 8231QwoRo9nuyTI2FPtIM+D6pu2RH+R3ZQUGhjqQD0mxCig5dMp46ZOf2xZQdDlC ovI115duhAjZQ3OGEkkQFqbEF8GqDdMl03UfX4jQ8Ky9/hb7jCJRboxq0n/zD7ua ygtyKxioyxkEaEf+r8x9PuQjJa+2UoXpnpVO/dCZCMzkFO3xU74SLthwJ30XGdqZ GQMZDtYLP/oh6Bl6vvWN5qzRtMTS+eGD6vfUuQmSJQwUhqMcT2cD+bw5KvUScR0S EycnKQuWrV44eu4FYA3rAyGaZK3Tsp5QCU9a68lDz1f8AjEaL4p1OHzd5+BCM8Cx 5Sq1dAqM8AyKakQ3Xvb0Omh4fafHcLdU5u+gixTgRUyBqq8ueM4= =v687 -----END PGP SIGNATURE----- --=-=-=-- From debbugs-submit-bounces@debbugs.gnu.org Thu Jun 20 07:40:51 2019 Received: (at 35790) by debbugs.gnu.org; 20 Jun 2019 11:40:51 +0000 Received: from localhost ([127.0.0.1]:47970 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1hdvQw-0002eS-Ra for submit@debbugs.gnu.org; Thu, 20 Jun 2019 07:40:51 -0400 Received: from eggs.gnu.org ([209.51.188.92]:44039) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1hdvQv-0002e2-Fk for 35790@debbugs.gnu.org; Thu, 20 Jun 2019 07:40:50 -0400 Received: from fencepost.gnu.org ([2001:470:142:3::e]:57654) by eggs.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1hdvQp-0006s3-7p; Thu, 20 Jun 2019 07:40:44 -0400 Received: from vpn-0-27.aquilenet.fr ([2a0c:e300:4:27::]:45724 helo=ribbon) by fencepost.gnu.org with esmtpsa (TLS1.2:RSA_AES_256_CBC_SHA1:256) (Exim 4.82) (envelope-from ) id 1hdvQo-0005dj-CL; Thu, 20 Jun 2019 07:40:43 -0400 From: =?utf-8?Q?Ludovic_Court=C3=A8s?= To: Christopher Baines Subject: Re: [bug#35790] [PATCH] scripts: lint: Handle warnings with a record type. References: <878suz27ke.fsf@gnu.org> <20190601183135.11882-1-mail@cbaines.net> <87ftolj0v2.fsf@gnu.org> <87imt5u1lr.fsf@cbaines.net> X-URL: http://www.fdn.fr/~lcourtes/ X-Revolutionary-Date: 2 Messidor an 227 de la =?utf-8?Q?R=C3=A9volution?= X-PGP-Key-ID: 0x090B11993D9AEBB5 X-PGP-Key: http://www.fdn.fr/~lcourtes/ludovic.asc X-PGP-Fingerprint: 3CE4 6455 8A84 FDC6 9DB4 0CFB 090B 1199 3D9A EBB5 X-OS: x86_64-pc-linux-gnu Date: Thu, 20 Jun 2019 13:40:38 +0200 In-Reply-To: <87imt5u1lr.fsf@cbaines.net> (Christopher Baines's message of "Sun, 16 Jun 2019 14:00:16 +0100") Message-ID: <87ef3olc21.fsf@gnu.org> User-Agent: Gnus/5.13 (Gnus v5.13) Emacs/26.2 (gnu/linux) MIME-Version: 1.0 Content-Type: text/plain; charset=utf-8 Content-Transfer-Encoding: quoted-printable X-detected-operating-system: by eggs.gnu.org: GNU/Linux 2.2.x-3.x [generic] X-Spam-Score: -2.3 (--) X-Debbugs-Envelope-To: 35790 Cc: 35790@debbugs.gnu.org X-BeenThere: debbugs-submit@debbugs.gnu.org X-Mailman-Version: 2.1.18 Precedence: list List-Id: List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: debbugs-submit-bounces@debbugs.gnu.org Sender: "Debbugs-submit" X-Spam-Score: -3.3 (---) Hi! Christopher Baines skribis: > Ludovic Court=C3=A8s writes: [...] >> One question I have: before, warnings would be emitted as we go; now, we >> first collect all the warnings for a given package, and emit all of them >> at once. How does it look in terms of UX? > > Not quite, warnings are emitted once returned from each checker for each > package. The display will only be delayed if a checker takes a long time > to return the warnings, which I don't think happens (or at least happens > much). True, so that shouldn=E2=80=99t be much of an issue I guess. Ludo=E2=80=99. From debbugs-submit-bounces@debbugs.gnu.org Thu Jun 20 07:49:59 2019 Received: (at 35790) by debbugs.gnu.org; 20 Jun 2019 11:49:59 +0000 Received: from localhost ([127.0.0.1]:47978 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1hdvZm-00053g-SV for submit@debbugs.gnu.org; Thu, 20 Jun 2019 07:49:59 -0400 Received: from eggs.gnu.org ([209.51.188.92]:47616) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1hdvZl-00053O-0W for 35790@debbugs.gnu.org; Thu, 20 Jun 2019 07:49:57 -0400 Received: from fencepost.gnu.org ([2001:470:142:3::e]:57904) by eggs.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1hdvZf-0006g4-PH; Thu, 20 Jun 2019 07:49:51 -0400 Received: from vpn-0-27.aquilenet.fr ([2a0c:e300:4:27::]:45836 helo=ribbon) by fencepost.gnu.org with esmtpsa (TLS1.2:RSA_AES_256_CBC_SHA1:256) (Exim 4.82) (envelope-from ) id 1hdvZd-0006Tf-VP; Thu, 20 Jun 2019 07:49:51 -0400 From: =?utf-8?Q?Ludovic_Court=C3=A8s?= To: Christopher Baines Subject: Re: [bug#35790] [PATCH] scripts: lint: Handle warnings with a record type. References: <20190518093206.22069-1-mail@cbaines.net> <878suz27ke.fsf@gnu.org> <87ef4dxgvl.fsf@cbaines.net> <87pnnpj15u.fsf@gnu.org> <87h88pu1cc.fsf@cbaines.net> X-URL: http://www.fdn.fr/~lcourtes/ X-Revolutionary-Date: 2 Messidor an 227 de la =?utf-8?Q?R=C3=A9volution?= X-PGP-Key-ID: 0x090B11993D9AEBB5 X-PGP-Key: http://www.fdn.fr/~lcourtes/ludovic.asc X-PGP-Fingerprint: 3CE4 6455 8A84 FDC6 9DB4 0CFB 090B 1199 3D9A EBB5 X-OS: x86_64-pc-linux-gnu Date: Thu, 20 Jun 2019 13:49:42 +0200 In-Reply-To: <87h88pu1cc.fsf@cbaines.net> (Christopher Baines's message of "Sun, 16 Jun 2019 14:05:55 +0100") Message-ID: <875zp0lbmx.fsf@gnu.org> User-Agent: Gnus/5.13 (Gnus v5.13) Emacs/26.2 (gnu/linux) MIME-Version: 1.0 Content-Type: text/plain; charset=utf-8 Content-Transfer-Encoding: quoted-printable X-detected-operating-system: by eggs.gnu.org: GNU/Linux 2.2.x-3.x [generic] X-Spam-Score: -2.3 (--) X-Debbugs-Envelope-To: 35790 Cc: 35790@debbugs.gnu.org X-BeenThere: debbugs-submit@debbugs.gnu.org X-Mailman-Version: 2.1.18 Precedence: list List-Id: List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: debbugs-submit-bounces@debbugs.gnu.org Sender: "Debbugs-submit" X-Spam-Score: -3.3 (---) Christopher Baines skribis: > Ludovic Court=C3=A8s writes: > >> A possibility would be to pass =E2=80=98make-warning=E2=80=99 a =E2=80= =98format=E2=80=99 list instead of >> a single string: >> >> (make-warning package (list (G_ "~a is bad") 'something) =E2=80=A6) >> >> That=E2=80=99d solve the problem but it=E2=80=99d have to be packaged ni= cely to avoid >> having too much boilerplate. > > I've now made an attempt at doing this, I've kept the changes separate > for now, and I've sent them as a separate patch. Nice! > I'm not sure I've got it working yet though. I've been testing with the > zile package, as there's a lint warning for the synopsis, however, if I > try to set the language to Spanish, it isn't translated. > > I've also tried checking the existing behaviour, but that doesn't seem > to work either: > > =E2=86=92 LC_MESSAGES=3Des_ES LANGUAGE=3Des_ES LC_ALL=3Des_ES ./pre-ins= t-env guile > ... > scheme@(guile-user)> (use-modules (guix i18n)) > scheme@(guile-user)> (G_ "~a: ~a: proposed synopsis: ~s~%") > $1 =3D "~a: ~a: proposed synopsis: ~s~%" > > Many of the translated strings won't match up with the code now as I've > changed them. I did try changing the Spanish translation for this > proposed synopsis message to match the code, but it didn't seem to work. > > Any ideas on what's going on here? You need to tell libc (gettext) where to look for message catalogs. This is normally done in scripts/guix: (bindtextdomain "guix" "@localedir@") For testing purposes, you can probably do: (bindtextdomain "guix" "/run/current-system/profile/share/locale") HTH! Ludo=E2=80=99. From debbugs-submit-bounces@debbugs.gnu.org Mon Jun 24 02:46:37 2019 Received: (at 35790) by debbugs.gnu.org; 24 Jun 2019 06:46:37 +0000 Received: from localhost ([127.0.0.1]:55439 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1hfIkO-0005b1-4V for submit@debbugs.gnu.org; Mon, 24 Jun 2019 02:46:36 -0400 Received: from mira.cbaines.net ([212.71.252.8]:40778) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1hfIkL-0005at-SD for 35790@debbugs.gnu.org; Mon, 24 Jun 2019 02:46:34 -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 2B34C170C5; Mon, 24 Jun 2019 07:46:32 +0100 (BST) Received: from capella (localhost [127.0.0.1]) by localhost (OpenSMTPD) with ESMTP id 55eb85b4; Mon, 24 Jun 2019 06:46:31 +0000 (UTC) References: <20190518093206.22069-1-mail@cbaines.net> <878suz27ke.fsf@gnu.org> <87ef4dxgvl.fsf@cbaines.net> <87pnnpj15u.fsf@gnu.org> <87h88pu1cc.fsf@cbaines.net> <875zp0lbmx.fsf@gnu.org> User-agent: mu4e 1.2.0; emacs 26.2 From: Christopher Baines To: Ludovic =?utf-8?Q?Court=C3=A8s?= Subject: Re: [bug#35790] [PATCH] scripts: lint: Handle warnings with a record type. In-reply-to: <875zp0lbmx.fsf@gnu.org> Date: Mon, 24 Jun 2019 07:46:29 +0100 Message-ID: <875zovmqey.fsf@cbaines.net> MIME-Version: 1.0 Content-Type: multipart/signed; boundary="=-=-="; micalg=pgp-sha512; protocol="application/pgp-signature" X-Spam-Score: -0.0 (/) X-Debbugs-Envelope-To: 35790 Cc: 35790@debbugs.gnu.org X-BeenThere: debbugs-submit@debbugs.gnu.org X-Mailman-Version: 2.1.18 Precedence: list List-Id: List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: debbugs-submit-bounces@debbugs.gnu.org Sender: "Debbugs-submit" X-Spam-Score: -1.0 (-) --=-=-= Content-Type: text/plain; charset=utf-8 Content-Transfer-Encoding: quoted-printable Ludovic Court=C3=A8s writes: > Christopher Baines skribis: > >> Ludovic Court=C3=A8s writes: >> >>> A possibility would be to pass =E2=80=98make-warning=E2=80=99 a =E2=80= =98format=E2=80=99 list instead of >>> a single string: >>> >>> (make-warning package (list (G_ "~a is bad") 'something) =E2=80=A6) >>> >>> That=E2=80=99d solve the problem but it=E2=80=99d have to be packaged n= icely to avoid >>> having too much boilerplate. >> >> I've now made an attempt at doing this, I've kept the changes separate >> for now, and I've sent them as a separate patch. > > Nice! > >> I'm not sure I've got it working yet though. I've been testing with the >> zile package, as there's a lint warning for the synopsis, however, if I >> try to set the language to Spanish, it isn't translated. >> >> I've also tried checking the existing behaviour, but that doesn't seem >> to work either: >> >> =E2=86=92 LC_MESSAGES=3Des_ES LANGUAGE=3Des_ES LC_ALL=3Des_ES ./pre-in= st-env guile >> ... >> scheme@(guile-user)> (use-modules (guix i18n)) >> scheme@(guile-user)> (G_ "~a: ~a: proposed synopsis: ~s~%") >> $1 =3D "~a: ~a: proposed synopsis: ~s~%" >> >> Many of the translated strings won't match up with the code now as I've >> changed them. I did try changing the Spanish translation for this >> proposed synopsis message to match the code, but it didn't seem to work. >> >> Any ideas on what's going on here? > > You need to tell libc (gettext) where to look for message catalogs. > This is normally done in scripts/guix: > > (bindtextdomain "guix" "@localedir@") > > For testing purposes, you can probably do: > > (bindtextdomain "guix" > "/run/current-system/profile/share/locale") Thanks, so if I set the bindtextdomain, things do indeed work better. So, regarding these two patches, I've got the following things on my mind... - As they change so many things, I'm not sure what to add for the GNU changelog at the end of the commit message? - Is it OK to break some of the translations, or should I fix some of those as well? - I'm thinking of the "proposed synopsis" related check specifically, as I've changed what goes in to the translated string. - How ready are these patches to merge? I don't know of any problems with them, but I am making lots of changes. Thanks, Chris --=-=-= Content-Type: application/pgp-signature; name="signature.asc" -----BEGIN PGP SIGNATURE----- iQKTBAEBCgB9FiEEPonu50WOcg2XVOCyXiijOwuE9XcFAl0QccVfFIAAAAAALgAo aXNzdWVyLWZwckBub3RhdGlvbnMub3BlbnBncC5maWZ0aGhvcnNlbWFuLm5ldDNF ODlFRUU3NDU4RTcyMEQ5NzU0RTBCMjVFMjhBMzNCMEI4NEY1NzcACgkQXiijOwuE 9Xd5OBAApQXAuitR8T/8zKm9evTcyjAPzO60yr9Fo+wgpgdqzhsAo4lP5nt1NWei hssuxDsLqRLnZ/N6CQrx6W9C+fT4tiuI2tkNWoCAECHaQZtmT4o5pwhUcK9G+sVc /gj5TVECEB7+5UTG4/hmur56hJdGLUkhRRvMcOzleOyTKDRWe1/sdm2saEH0qGSr aEZw8Qg2ykGPx8NXC7jJphGD3+R3ddJlj7M2v/kAvGEIs2WReD/IAhgVOeXYJkqD zKOcfM9bi1Lf9CVZ5nX2pyxdi0BOKrS/SB2X1BAb7qmo8Q41561+JLD74qSbKGNw iZS8E5Fx7yMR2sVqoS8Vto2ooBJ6IFTy42DSno0yTjIxTIAtmeHQcy0NJqXsmrcc 8UMK0Vu/iM8yY2y3e4X431TgNHGpWiy3O4A1a+P6fuBtEUuIfYwsaEm71yNy/4c5 cuGU5HxxmyActmnLO/5TBpUnnlh3+33jIBjjxP57aky+TKlsHeywuRku1gneJzFw LnMjvBqkBGI2UpICT6n94oODmk/M5q37CbLCHXG1mfDzmfg32fzpUkenrLgIlhjo b2779RjeOGe8Ogqt8FRsvj/19L0tV7cwtxnFqE/50Mab6xS36XSSBGcmTKZpKsDt ASZkElBxAflNaVGKf9N7+7W1peulSbCAkFM6eNz00jh/vfdetd0= =guy+ -----END PGP SIGNATURE----- --=-=-=-- From debbugs-submit-bounces@debbugs.gnu.org Mon Jun 24 04:33:36 2019 Received: (at 35790) by debbugs.gnu.org; 24 Jun 2019 08:33:36 +0000 Received: from localhost ([127.0.0.1]:55538 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1hfKPv-0001zK-Vw for submit@debbugs.gnu.org; Mon, 24 Jun 2019 04:33:36 -0400 Received: from eggs.gnu.org ([209.51.188.92]:34450) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1hfKPt-0001z1-N6 for 35790@debbugs.gnu.org; Mon, 24 Jun 2019 04:33:34 -0400 Received: from fencepost.gnu.org ([2001:470:142:3::e]:33354) by eggs.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1hfKPn-0005vw-Go; Mon, 24 Jun 2019 04:33:28 -0400 Received: from [2001:660:6102:320:e120:2c8f:8909:cdfe] (port=38818 helo=ribbon) by fencepost.gnu.org with esmtpsa (TLS1.2:RSA_AES_256_CBC_SHA1:256) (Exim 4.82) (envelope-from ) id 1hfKPm-0000A7-R8; Mon, 24 Jun 2019 04:33:27 -0400 From: =?utf-8?Q?Ludovic_Court=C3=A8s?= To: Christopher Baines Subject: Re: [bug#35790] [PATCH] scripts: lint: Handle warnings with a record type. References: <20190518093206.22069-1-mail@cbaines.net> <878suz27ke.fsf@gnu.org> <87ef4dxgvl.fsf@cbaines.net> <87pnnpj15u.fsf@gnu.org> <87h88pu1cc.fsf@cbaines.net> <875zp0lbmx.fsf@gnu.org> <875zovmqey.fsf@cbaines.net> X-URL: http://www.fdn.fr/~lcourtes/ X-Revolutionary-Date: 6 Messidor an 227 de la =?utf-8?Q?R=C3=A9volution?= X-PGP-Key-ID: 0x090B11993D9AEBB5 X-PGP-Key: http://www.fdn.fr/~lcourtes/ludovic.asc X-PGP-Fingerprint: 3CE4 6455 8A84 FDC6 9DB4 0CFB 090B 1199 3D9A EBB5 X-OS: x86_64-pc-linux-gnu Date: Mon, 24 Jun 2019 10:33:25 +0200 In-Reply-To: <875zovmqey.fsf@cbaines.net> (Christopher Baines's message of "Mon, 24 Jun 2019 07:46:29 +0100") Message-ID: <874l4fe622.fsf@gnu.org> User-Agent: Gnus/5.13 (Gnus v5.13) Emacs/26.2 (gnu/linux) MIME-Version: 1.0 Content-Type: text/plain; charset=utf-8 Content-Transfer-Encoding: quoted-printable X-detected-operating-system: by eggs.gnu.org: GNU/Linux 2.2.x-3.x [generic] X-Spam-Score: -2.3 (--) X-Debbugs-Envelope-To: 35790 Cc: 35790@debbugs.gnu.org X-BeenThere: debbugs-submit@debbugs.gnu.org X-Mailman-Version: 2.1.18 Precedence: list List-Id: List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: debbugs-submit-bounces@debbugs.gnu.org Sender: "Debbugs-submit" X-Spam-Score: -3.3 (---) Hi! :-) Christopher Baines skribis: > - Is it OK to break some of the translations, or should I fix some of > those as well? > > - I'm thinking of the "proposed synopsis" related check specifically, > as I've changed what goes in to the translated string. It=E2=80=99s OK to change strings sometimes, but this has to be done thoughtfully as it entails more translation work and a time window during which translations aren=E2=80=99t up-to-date and everyone sees the English string. Let me look at the other issues=E2=80=A6 Ludo=E2=80=99. From debbugs-submit-bounces@debbugs.gnu.org Mon Jun 24 04:37:00 2019 Received: (at 35790) by debbugs.gnu.org; 24 Jun 2019 08:37:00 +0000 Received: from localhost ([127.0.0.1]:55543 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1hfKTE-00025g-HY for submit@debbugs.gnu.org; Mon, 24 Jun 2019 04:37:00 -0400 Received: from eggs.gnu.org ([209.51.188.92]:35175) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1hfKTC-00025L-9O for 35790@debbugs.gnu.org; Mon, 24 Jun 2019 04:36:58 -0400 Received: from fencepost.gnu.org ([2001:470:142:3::e]:33383) by eggs.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1hfKT0-00033p-RR; Mon, 24 Jun 2019 04:36:47 -0400 Received: from [2001:660:6102:320:e120:2c8f:8909:cdfe] (port=38822 helo=ribbon) by fencepost.gnu.org with esmtpsa (TLS1.2:RSA_AES_256_CBC_SHA1:256) (Exim 4.82) (envelope-from ) id 1hfKSz-0006sx-LC; Mon, 24 Jun 2019 04:36:45 -0400 From: =?utf-8?Q?Ludovic_Court=C3=A8s?= To: Christopher Baines Subject: Re: [bug#35790] [PATCH] scripts: lint: Separate the message warning text and data. References: <87pnnpj15u.fsf@gnu.org> <20190616125608.15690-1-mail@cbaines.net> Date: Mon, 24 Jun 2019 10:36:43 +0200 In-Reply-To: <20190616125608.15690-1-mail@cbaines.net> (Christopher Baines's message of "Sun, 16 Jun 2019 13:56:08 +0100") Message-ID: <87y31rcrc4.fsf@gnu.org> User-Agent: Gnus/5.13 (Gnus v5.13) Emacs/26.2 (gnu/linux) MIME-Version: 1.0 Content-Type: text/plain; charset=utf-8 Content-Transfer-Encoding: quoted-printable X-detected-operating-system: by eggs.gnu.org: GNU/Linux 2.2.x-3.x [generic] X-Spam-Score: -2.3 (--) X-Debbugs-Envelope-To: 35790 Cc: 35790@debbugs.gnu.org X-BeenThere: debbugs-submit@debbugs.gnu.org X-Mailman-Version: 2.1.18 Precedence: list List-Id: List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: debbugs-submit-bounces@debbugs.gnu.org Sender: "Debbugs-submit" X-Spam-Score: -3.3 (---) Hello, Christopher Baines skribis: > +(define-syntax make-warning > + (syntax-rules (G_) > + ((_ package (G_ message) rest ...) > + (%make-warning package message rest ...)) > + ((_ package message rest ...) > + (%make-warning package message rest ...)))) I think you can remove the second clause: that will ensure we never forget to add a G_ around messages. Otherwise LGTM! Ludo=E2=80=99. From debbugs-submit-bounces@debbugs.gnu.org Mon Jun 24 04:39:42 2019 Received: (at 35790) by debbugs.gnu.org; 24 Jun 2019 08:39:42 +0000 Received: from localhost ([127.0.0.1]:55549 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1hfKVq-0002Ak-3N for submit@debbugs.gnu.org; Mon, 24 Jun 2019 04:39:42 -0400 Received: from eggs.gnu.org ([209.51.188.92]:37012) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1hfKVo-0002AT-Hy for 35790@debbugs.gnu.org; Mon, 24 Jun 2019 04:39:40 -0400 Received: from fencepost.gnu.org ([2001:470:142:3::e]:33425) by eggs.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1hfKVj-00089s-0U; Mon, 24 Jun 2019 04:39:35 -0400 Received: from [2001:660:6102:320:e120:2c8f:8909:cdfe] (port=38824 helo=ribbon) by fencepost.gnu.org with esmtpsa (TLS1.2:RSA_AES_256_CBC_SHA1:256) (Exim 4.82) (envelope-from ) id 1hfKVi-0000dy-Fv; Mon, 24 Jun 2019 04:39:34 -0400 From: =?utf-8?Q?Ludovic_Court=C3=A8s?= To: Christopher Baines Subject: Re: [bug#35790] [PATCH] scripts: lint: Handle warnings with a record type. References: <20190518093206.22069-1-mail@cbaines.net> <878suz27ke.fsf@gnu.org> <87ef4dxgvl.fsf@cbaines.net> <87pnnpj15u.fsf@gnu.org> <87h88pu1cc.fsf@cbaines.net> <875zp0lbmx.fsf@gnu.org> <875zovmqey.fsf@cbaines.net> Date: Mon, 24 Jun 2019 10:39:32 +0200 In-Reply-To: <875zovmqey.fsf@cbaines.net> (Christopher Baines's message of "Mon, 24 Jun 2019 07:46:29 +0100") Message-ID: <87pnn3cr7f.fsf@gnu.org> User-Agent: Gnus/5.13 (Gnus v5.13) Emacs/26.2 (gnu/linux) MIME-Version: 1.0 Content-Type: text/plain; charset=utf-8 Content-Transfer-Encoding: quoted-printable X-detected-operating-system: by eggs.gnu.org: GNU/Linux 2.2.x-3.x [generic] X-Spam-Score: -2.3 (--) X-Debbugs-Envelope-To: 35790 Cc: 35790@debbugs.gnu.org X-BeenThere: debbugs-submit@debbugs.gnu.org X-Mailman-Version: 2.1.18 Precedence: list List-Id: List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: debbugs-submit-bounces@debbugs.gnu.org Sender: "Debbugs-submit" X-Spam-Score: -3.3 (---) Hi Chris, Christopher Baines skribis: > Thanks, so if I set the bindtextdomain, things do indeed work > better. So, regarding these two patches, I've got the following things > on my mind... > > - As they change so many things, I'm not sure what to add for the GNU > changelog at the end of the commit message? I think you should try to write the commit log the usual way, by listing every changed entity. It=E2=80=99s a bit tedious, but it=E2=80=99s= also a good way to review everything (and Magit makes it relatively easy.) Now, don=E2=80=99t lose your hair on it, it=E2=80=99s not the most importan= t part of the patch. :-) > - Is it OK to break some of the translations, or should I fix some of > those as well? > > - I'm thinking of the "proposed synopsis" related check specifically, > as I've changed what goes in to the translated string. Actually I didn=E2=80=99t see the change you=E2=80=99re referring to, but m= aybe it doesn=E2=80=99t matter much. > - How ready are these patches to merge? I don't know of any problems > with them, but I am making lots of changes. I think it=E2=80=99s ready. Thanks, and sorry for the delays! Ludo=E2=80=99. From debbugs-submit-bounces@debbugs.gnu.org Sat Jun 29 04:46:57 2019 Received: (at 35790) by debbugs.gnu.org; 29 Jun 2019 08:46:57 +0000 Received: from localhost ([127.0.0.1]:43437 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1hh90Z-0004Wx-Ty for submit@debbugs.gnu.org; Sat, 29 Jun 2019 04:46:56 -0400 Received: from mira.cbaines.net ([212.71.252.8]:34124) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1hh90V-0004TB-PZ for 35790@debbugs.gnu.org; Sat, 29 Jun 2019 04:46:54 -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 03CA41715E; Sat, 29 Jun 2019 09:46:47 +0100 (BST) Received: from capella (localhost [127.0.0.1]) by localhost (OpenSMTPD) with ESMTP id 9f133cc9; Sat, 29 Jun 2019 08:46:47 +0000 (UTC) References: <87pnnpj15u.fsf@gnu.org> <20190616125608.15690-1-mail@cbaines.net> <87y31rcrc4.fsf@gnu.org> User-agent: mu4e 1.2.0; emacs 26.2 From: Christopher Baines To: Ludovic =?utf-8?Q?Court=C3=A8s?= Subject: Re: [bug#35790] [PATCH] scripts: lint: Separate the message warning text and data. In-reply-to: <87y31rcrc4.fsf@gnu.org> Date: Sat, 29 Jun 2019 09:46:44 +0100 Message-ID: <87zhm0lqx7.fsf@cbaines.net> MIME-Version: 1.0 Content-Type: multipart/signed; boundary="=-=-="; micalg=pgp-sha512; protocol="application/pgp-signature" X-Spam-Score: -0.0 (/) X-Debbugs-Envelope-To: 35790 Cc: 35790@debbugs.gnu.org X-BeenThere: debbugs-submit@debbugs.gnu.org X-Mailman-Version: 2.1.18 Precedence: list List-Id: List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: debbugs-submit-bounces@debbugs.gnu.org Sender: "Debbugs-submit" X-Spam-Score: -1.0 (-) --=-=-= Content-Type: text/plain; charset=utf-8 Content-Transfer-Encoding: quoted-printable Ludovic Court=C3=A8s writes: > Hello, > > Christopher Baines skribis: > >> +(define-syntax make-warning >> + (syntax-rules (G_) >> + ((_ package (G_ message) rest ...) >> + (%make-warning package message rest ...)) >> + ((_ package message rest ...) >> + (%make-warning package message rest ...)))) > > I think you can remove the second clause: that will ensure we never > forget to add a G_ around messages. Sure, there was one case where this clause was used, but I've switched that to call %make-warning directly, and added a comment: (define (check-patch-file-names package) "Emit a warning if the patches requires by PACKAGE are badly named or i= f the patch could not be found." (guard (c ((message-condition? c) ;raised by 'search-patch' (list ;; Use %make-warning, as condition-mesasge is already ;; translated. (%make-warning package (condition-message c) #:field 'patch-file-names)))) --=-=-= Content-Type: application/pgp-signature; name="signature.asc" -----BEGIN PGP SIGNATURE----- iQKTBAEBCgB9FiEEPonu50WOcg2XVOCyXiijOwuE9XcFAl0XJXRfFIAAAAAALgAo aXNzdWVyLWZwckBub3RhdGlvbnMub3BlbnBncC5maWZ0aGhvcnNlbWFuLm5ldDNF ODlFRUU3NDU4RTcyMEQ5NzU0RTBCMjVFMjhBMzNCMEI4NEY1NzcACgkQXiijOwuE 9XcoChAApuf5+XXBmKcei2GU/0tBeOfXG65WBSCaqptVHYcBk9684JuP1c+6BnGd IvYnOC7q4gRmeF9mdzqcFxQpKtI5STb5qLrMePiQtHYKLi73kuLo62R06f9yOD4D nVriXywOSfQ2GDwaIRYH+J6fPgiGQYKSz0MrBPmorcEKYO/B2kASV246p7mXPBLI tZz5HwTX7RTziX5cH8mgs6VaAOR12YombJneZUuWzbBKeUT0HYWcYp0xqOPpMaqc wU6t7X+Jvnp7aFNdjxGoRely+pLM59uH5xfPO+QKBKawoR97HL8AHUZR7c0JFkD2 bhKR64TGEWAGBTiyaXpXdUH/YEBY9tDEOXmCtksER+cZ3g24N9/UoHPh8KIGrE8x ZLAoCRoZp6ItXyqpmAg6hMiEDzGc1Dv2TXIy0VQXJo6a+VgUvR+bb1o9B9c5Krv9 BUxiTCxHNlQo3P0f7vbIWgS6H7iRG4oGMMsO0NVGZOQoHGsTy4WIjO9YOm/VRKww 59EHMxMh9WanaXkNxeJmxvrj5/SIZ87n/naAJj78TDqSeGmZd2Unh0YOcy9MnQg3 ONs0Xl6k47Jvo2G86z/GAfFHrPnC53t1ZvFUhhQDQ9/iMQHa28BmoEU2RjN54mVt mxuZ+pl/aWpXj4bke162wW3Tk3lR31LpKEQZyHvvTOGfQxQrOJc= =VSre -----END PGP SIGNATURE----- --=-=-=-- From debbugs-submit-bounces@debbugs.gnu.org Sat Jun 29 07:26:01 2019 Received: (at 35790) by debbugs.gnu.org; 29 Jun 2019 11:26:01 +0000 Received: from localhost ([127.0.0.1]:43529 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1hhBUV-0002fQ-S1 for submit@debbugs.gnu.org; Sat, 29 Jun 2019 07:26:01 -0400 Received: from mira.cbaines.net ([212.71.252.8]:34158) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1hhBUT-0002fB-5F for 35790@debbugs.gnu.org; Sat, 29 Jun 2019 07:25:57 -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 4B3A31715E for <35790@debbugs.gnu.org>; Sat, 29 Jun 2019 12:25:52 +0100 (BST) Received: from localhost (localhost [local]) by localhost (OpenSMTPD) with ESMTPA id 612371b6 for <35790@debbugs.gnu.org>; Sat, 29 Jun 2019 11:25:52 +0000 (UTC) From: Christopher Baines To: 35790@debbugs.gnu.org Subject: [PATCH 1/2] scripts: lint: Handle warnings with a record type. Date: Sat, 29 Jun 2019 12:25:51 +0100 Message-Id: <20190629112552.8261-1-mail@cbaines.net> X-Mailer: git-send-email 2.22.0 In-Reply-To: <87pnn3cr7f.fsf@gnu.org> References: <87pnn3cr7f.fsf@gnu.org> MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit X-Debbugs-Envelope-To: 35790 X-BeenThere: debbugs-submit@debbugs.gnu.org X-Mailman-Version: 2.1.18 Precedence: list List-Id: List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: debbugs-submit-bounces@debbugs.gnu.org Sender: "Debbugs-submit" 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 (): New record type. (lint-warning): New macro. (lint-warning?, lint-warning-package, lint-warning-message, lint-warning-location, package-file, make-warning): New procedures. (call-with-accumulated-warnings, with-accumulated-warnings): Remove. (emit-warning): Rename to emit-warnings, and switch to displaying multiple warnings. (check-description-style)[check-not-empty-description, check-texinfo-markup, check-trademarks, check-quotes, check-proper-start, check-end-of-sentence-space]: Switch to generating a list of warnings, and using make-warning, rather than emit-warning. (check-inputs-should-be-native, check-inputs-should-not-be-an-input-at-all): Switch to generating a list of warnings, and using make-warning, rather than emit-warning. (check-synopsis): Switch to generating a list of warnings, and using make-warning, rather than emit-warning. [check-not-empty]: Remove, this is handled in the match clause to avoid other warnings being emitted. [check-final-period, check-start-article, check-synopsis-length, check-proper-start, check-start-with-package-name, check-texinfo-markup]: Switch to generating a list of warnings, and using make-warning, rather than emit-warning. [checks]: Remove check-not-empty. (validate-uri, check-home-page, check-patch-file-names, check-gnu-synopsis+description): Switch to generating a list of warnings, and using make-warning, rather than emit-warning. (check-source): Switch to generating a list of warnings, and using make-warning, rather than emit-warning. [try-uris]: Remove. [warnings-for-uris]: New procedure, replacing try-uris. (check-source-file-name, check-source-unstable-tarball, check-mirror-url, check-github-url, check-derivation, check-vulnerabilities, check-for-updates, report-tabulations, report-trailing-white-space, report-long-line, report-lone-parentheses, report-formatting-issues, check-formatting): Switch to generating a list of warnings, and using make-warning, rather than emit-warning. (run-checkers): Call emit-warnings on the warnings returned from the checker. * tests/lint.scm (string-match-or-error, single-lint-warning-message): New procedures. (call-with-warnings, with-warnings): Remove. ("description: not a string", "description: not empty", "description: invalid Texinfo markup", "description: does not start with an upper-case letter", "description: may start with a digit", "description: may start with lower-case package name", "description: two spaces after end of sentence", "description: end-of-sentence detection with abbreviations", "description: may not contain trademark signs: ™", "description: may not contain trademark signs: ®", "description: suggest ornament instead of quotes", "synopsis: not a string", "synopsis: not empty", "synopsis: valid Texinfo markup", "synopsis: does not start with an upper-case letter", "synopsis: may start with a digit", "synopsis: ends with a period", "synopsis: ends with 'etc.'", "synopsis: starts with 'A'", "synopsis: starts with 'a'", "synopsis: starts with 'an'", "synopsis: too long", "synopsis: start with package name", "synopsis: start with package name prefix", "synopsis: start with abbreviation", "inputs: pkg-config is probably a native input", "inputs: glib:bin is probably a native input", "inputs: python-setuptools should not be an input at all (input)", "inputs: python-setuptools should not be an input at all (native-input)", "inputs: python-setuptools should not be an input at all (propagated-input)", "patches: file names", "patches: file name too long", "patches: not found", "derivation: invalid arguments", "license: invalid license", "home-page: wrong home-page", "home-page: invalid URI", "home-page: host not found", "home-page: Connection refused", "home-page: 200", "home-page: 200 but short length", "home-page: 404", "home-page: 301, invalid", "home-page: 301 -> 200", "home-page: 301 -> 404", "source-file-name", "source-file-name: v prefix", "source-file-name: bad checkout", "source-file-name: good checkout", "source-file-name: valid", "source-unstable-tarball", "source-unstable-tarball: source #f", "source-unstable-tarball: valid", "source-unstable-tarball: package named archive", "source-unstable-tarball: not-github", "source-unstable-tarball: git-fetch", "source: 200", "source: 200 but short length", "source: 404", "source: 301 -> 200", "source: 301 -> 404", "mirror-url", "mirror-url: one suggestion", "github-url", "github-url: one suggestion", "github-url: already the correct github url", "cve", "cve: one vulnerability", "cve: one patched vulnerability", "cve: known safe from vulnerability", "cve: vulnerability fixed in replacement version", "cve: patched vulnerability in replacement", "formatting: lonely parentheses", "formatting: alright"): Change test-assert to test-equal, and adjust to work with the changes above. ("formatting: tabulation", "formatting: trailing white space", "formatting: long line"): Use string-match-or-error rather than string-contains. --- guix/scripts/lint.scm | 757 +++++++++++---------- tests/lint.scm | 1453 +++++++++++++++++++---------------------- 2 files changed, 1102 insertions(+), 1108 deletions(-) diff --git a/guix/scripts/lint.scm b/guix/scripts/lint.scm index dc338a1d7b..1b08068669 100644 --- a/guix/scripts/lint.scm +++ b/guix/scripts/lint.scm @@ -84,6 +84,12 @@ check-formatting run-checkers + lint-warning + lint-warning? + lint-warning-package + lint-warning-message + lint-warning-location + %checkers lint-checker lint-checker? @@ -93,42 +99,48 @@ ;;; -;;; 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))) + warnings)) ;;; ;;; Checkers ;;; + (define-record-type* 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 ;; . (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 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 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))) + stringbool - (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) ) 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) ) 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) ) 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) ) 0 "CVE-2015-1234" (list (cons (package-name package) (package-version package))))))) - (string-null? - (with-warnings - (check-vulnerabilities - (dummy-package - "pi" (version "3.14") (source (dummy-origin)) - (replacement (dummy-package - "pi" (version "3.14") - (source - (dummy-origin - (patches - (list "/a/b/pi-CVE-2015-1234.patch")))))))))))) - -(test-assert "formatting: lonely parentheses" - (string-contains - (with-warnings - (check-formatting - ( - dummy-package "ugly as hell!" - ) - )) - "lonely")) + (check-vulnerabilities + (dummy-package + "pi" (version "3.14") (source (dummy-origin)) + (replacement (dummy-package + "pi" (version "3.14") + (source + (dummy-origin + (patches + (list "/a/b/pi-CVE-2015-1234.patch")))))))))) + +(test-equal "formatting: lonely parentheses" + "parentheses feel lonely, move to the previous or next line" + (single-lint-warning-message + (check-formatting + (dummy-package "ugly as hell!" + ) + ))) (test-assert "formatting: tabulation" - (string-contains - (with-warnings - (check-formatting (dummy-package "leave the tab here: "))) - "tabulation")) + (string-match-or-error + "tabulation on line [0-9]+, column [0-9]+" + (single-lint-warning-message + (check-formatting (dummy-package "leave the tab here: "))))) (test-assert "formatting: trailing white space" - (string-contains - (with-warnings - ;; Leave the trailing white space on the next line! - (check-formatting (dummy-package "x"))) - "trailing white space")) + (string-match-or-error + "trailing white space .*" + ;; Leave the trailing white space on the next line! + (single-lint-warning-message + (check-formatting (dummy-package "x"))))) (test-assert "formatting: long line" - (string-contains - (with-warnings - (check-formatting - (dummy-package "x" ;here is a stupid comment just to make a long line - ))) - "too long")) - -(test-assert "formatting: alright" - (string-null? - (with-warnings - (check-formatting (dummy-package "x"))))) + (string-match-or-error + "line [0-9]+ is way too long \\([0-9]+ characters\\)" + (single-lint-warning-message (check-formatting + (dummy-package "x")) ;here is a stupid comment just to make a long line + ))) + +(test-equal "formatting: alright" + '() + (check-formatting (dummy-package "x"))) (test-end "lint") -- 2.22.0 From debbugs-submit-bounces@debbugs.gnu.org Sat Jun 29 07:26:03 2019 Received: (at 35790) by debbugs.gnu.org; 29 Jun 2019 11:26:03 +0000 Received: from localhost ([127.0.0.1]:43530 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1hhBUX-0002fV-E0 for submit@debbugs.gnu.org; Sat, 29 Jun 2019 07:26:02 -0400 Received: from mira.cbaines.net ([212.71.252.8]:34160) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1hhBUT-0002fD-M3 for 35790@debbugs.gnu.org; Sat, 29 Jun 2019 07:25:58 -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 7E7DA17163 for <35790@debbugs.gnu.org>; Sat, 29 Jun 2019 12:25:52 +0100 (BST) Received: from localhost (localhost [local]) by localhost (OpenSMTPD) with ESMTPA id 53f32da9 for <35790@debbugs.gnu.org>; Sat, 29 Jun 2019 11:25:52 +0000 (UTC) From: Christopher Baines To: 35790@debbugs.gnu.org Subject: [PATCH 2/2] scripts: lint: Separate the message warning text and data. Date: Sat, 29 Jun 2019 12:25:52 +0100 Message-Id: <20190629112552.8261-2-mail@cbaines.net> X-Mailer: git-send-email 2.22.0 In-Reply-To: <20190629112552.8261-1-mail@cbaines.net> References: <87pnn3cr7f.fsf@gnu.org> <20190629112552.8261-1-mail@cbaines.net> MIME-Version: 1.0 Content-Transfer-Encoding: 8bit X-Spam-Score: 0.0 (/) X-Debbugs-Envelope-To: 35790 X-BeenThere: debbugs-submit@debbugs.gnu.org X-Mailman-Version: 2.1.18 Precedence: list List-Id: List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: debbugs-submit-bounces@debbugs.gnu.org Sender: "Debbugs-submit" X-Spam-Score: -1.0 (-) So that translations can be handled more flexibly, rather than having to translate the message text within the checker. * guix/scripts/lint.scm (lint-warning-message-text, lint-warning-message-data): New procedures. (lint-warning-message): Remove record field accessor, replace with procedure that handles the lint warning data and translating the message. (make-warning): Rename to %make-warning. (make-warning): New macro. (emit-warnings): Handle the message-text and message-data fields. (check-description-style): Adjust for changes to make-warning. [check-trademarks, check-end-of-sentence-space): Adjust for changes to make-warning. (check-inputs-should-be-native, check-inputs-should-not-be-an-input-at-all, check-synopsis-style, validate-uri, check-home-page, check-patch-file-names, check-gnu-synopsis+description, check-mirror-url, check-github-url, check-derivation, check-vulnerabilities, check-for-updates, report-tabulations, report-trailing-white-space, report-long-line, report-lone-parentheses): Adjust for changes to make-warning. --- guix/scripts/lint.scm | 198 ++++++++++++++++++++++-------------------- 1 file changed, 106 insertions(+), 92 deletions(-) diff --git a/guix/scripts/lint.scm b/guix/scripts/lint.scm index 1b08068669..4eb7e0e200 100644 --- a/guix/scripts/lint.scm +++ b/guix/scripts/lint.scm @@ -88,6 +88,8 @@ lint-warning? lint-warning-package lint-warning-message + lint-warning-message-text + lint-warning-message-data lint-warning-location %checkers @@ -105,35 +107,49 @@ (define-record-type* lint-warning make-lint-warning lint-warning? - (package lint-warning-package) - (message lint-warning-message) - (location lint-warning-location - (default #f))) + (package lint-warning-package) + (message-text lint-warning-message-text) + (message-data lint-warning-message-data + (default '())) + (location lint-warning-location + (default #f))) + +(define (lint-warning-message warning) + (apply format #f + (G_ (lint-warning-message-text warning)) + (lint-warning-message-data warning))) (define (package-file package) (location-file (package-location package))) -(define* (make-warning package message - #:key field location) +(define* (%make-warning package message-text + #:optional (message-data '()) + #:key field location) (make-lint-warning package - message + message-text + message-data (or location (package-field-location package field) (package-location package)))) +(define-syntax make-warning + (syntax-rules (G_) + ((_ package (G_ message) rest ...) + (%make-warning package message rest ...)))) + (define (emit-warnings warnings) ;; Emit a warning about PACKAGE, printing the location of FIELD if it is ;; given, the location of PACKAGE otherwise, the full name of PACKAGE and the ;; provided MESSAGE. (for-each (match-lambda - (($ package message loc) + (($ package message-text message-data loc) (format (guix-warning-port) "~a: ~a@~a: ~a~%" (location->string loc) (package-name package) (package-version package) - message))) + (apply format #f (G_ message-text) message-data)))) warnings)) @@ -199,9 +215,9 @@ http://www.gnu.org/prep/standards/html_node/Trademarks.html." ((and (? number?) index) (list (make-warning package - (format #f (G_ "description should not contain ~ + (G_ "description should not contain ~ trademark sign '~a' at ~d") - (string-ref description index) index) + (list (string-ref description index) index) #:field 'description))) (else '()))) @@ -242,10 +258,10 @@ trademark sign '~a' at ~d") '() (list (make-warning package - (format #f (G_ "sentences in description should be followed ~ + (G_ "sentences in description should be followed ~ by two spaces; possible infraction~p at ~{~a~^, ~}") - (length infractions) - infractions) + (list (length infractions) + infractions) #:field 'description))))) (let ((description (package-description package))) @@ -263,7 +279,8 @@ by two spaces; possible infraction~p at ~{~a~^, ~}") (check-proper-start plain-description)))) (list (make-warning package - (format #f (G_ "invalid description: ~s") description) + (G_ "invalid description: ~s") + (list description) #:field 'description))))) (define (package-input-intersection inputs-to-check input-names) @@ -308,8 +325,8 @@ of a package, and INPUT-NAMES, a list of package specifications such as (map (lambda (input) (make-warning package - (format #f (G_ "'~a' should probably be a native input") - input) + (G_ "'~a' should probably be a native input") + (list input) #:field 'inputs)) (package-input-intersection inputs input-names)))) @@ -323,9 +340,8 @@ of a package, and INPUT-NAMES, a list of package specifications such as (map (lambda (input) (make-warning package - (format #f - (G_ "'~a' should probably not be an input at all") - input) + (G_ "'~a' should probably not be an input at all") + (list input) #:field 'inputs)) (package-input-intersection (package-direct-inputs package) input-names)))) @@ -423,7 +439,9 @@ markup is valid return a plain-text version of SYNOPSIS, otherwise #f." checks)) (invalid (list - (make-warning package (format #f (G_ "invalid synopsis: ~s") invalid) + (make-warning package + (G_ "invalid synopsis: ~s") + (list invalid) #:field 'synopsis))))) (define* (probe-uri uri #:key timeout) @@ -540,64 +558,59 @@ PACKAGE mentionning the FIELD." ;; such malicious behavior. (or (> length 1000) (make-warning package - (format #f - (G_ "URI ~a returned \ + (G_ "URI ~a returned \ suspiciously small file (~a bytes)") - (uri->string uri) - length) + (list (uri->string uri) + length) #:field field))) (_ #t))) ((= 301 (response-code argument)) (if (response-location argument) (make-warning package - (format #f (G_ "permanent redirect from ~a to ~a") - (uri->string uri) - (uri->string - (response-location argument))) + (G_ "permanent redirect from ~a to ~a") + (list (uri->string uri) + (uri->string + (response-location argument))) #:field field) (make-warning package - (format #f (G_ "invalid permanent redirect \ + (G_ "invalid permanent redirect \ from ~a") - (uri->string uri)) + (list (uri->string uri)) #:field field))) (else (make-warning package - (format #f - (G_ "URI ~a not reachable: ~a (~s)") - (uri->string uri) - (response-code argument) - (response-reason-phrase argument)) + (G_ "URI ~a not reachable: ~a (~s)") + (list (uri->string uri) + (response-code argument) + (response-reason-phrase argument)) #:field field)))) ((ftp-response) (match argument (('ok) #t) (('error port command code message) (make-warning package - (format #f - (G_ "URI ~a not reachable: ~a (~s)") - (uri->string uri) - code (string-trim-both message)) + (G_ "URI ~a not reachable: ~a (~s)") + (list (uri->string uri) + code (string-trim-both message)) #:field field)))) ((getaddrinfo-error) (make-warning package - (format #f - (G_ "URI ~a domain not found: ~a") - (uri->string uri) - (gai-strerror (car argument))) + (G_ "URI ~a domain not found: ~a") + (list (uri->string uri) + (gai-strerror (car argument))) #:field field)) ((system-error) (make-warning package - (format #f - (G_ "URI ~a unreachable: ~a") - (uri->string uri) - (strerror - (system-error-errno - (cons status argument)))) + (G_ "URI ~a unreachable: ~a") + (list (uri->string uri) + (strerror + (system-error-errno + (cons status argument)))) #:field field)) ((tls-certificate-error) (make-warning package - (format #f (G_ "TLS certificate error: ~a") - (tls-certificate-error-string argument)) + (G_ "TLS certificate error: ~a") + (list (tls-certificate-error-string argument)) #:field field)) ((invalid-http-response gnutls-error) ;; Probably a misbehaving server; ignore. @@ -627,8 +640,9 @@ from ~a") #:field 'home-page)))) (else (list - (make-warning package (format #f (G_ "invalid home page URL: ~s") - (package-home-page package)) + (make-warning package + (G_ "invalid home page URL: ~s") + (list (package-home-page package)) #:field 'home-page)))))) (define %distro-directory @@ -640,8 +654,10 @@ from ~a") patch could not be found." (guard (c ((message-condition? c) ;raised by 'search-patch' (list - (make-warning package (condition-message c) - #:field 'patch-file-names)))) + ;; Use %make-warning, as condition-mesasge is already + ;; translated. + (%make-warning package (condition-message c) + #:field 'patch-file-names)))) (define patches (or (and=> (package-source package) origin-patches) '())) @@ -674,8 +690,8 @@ patch could not be found." max) (make-warning package - (format #f (G_ "~a: file name is too long") - (basename patch)) + (G_ "~a: file name is too long") + (list (basename patch)) #:field 'patch-file-names) #f)) (_ #f)) @@ -716,8 +732,8 @@ descriptions maintained upstream." (not (string=? upstream downstream)))) (list (make-warning package - (format #f (G_ "proposed synopsis: ~s~%") - upstream) + (G_ "proposed synopsis: ~s~%") + (list upstream) #:field 'synopsis)) '())) @@ -730,9 +746,8 @@ descriptions maintained upstream." (list (make-warning package - (format #f - (G_ "proposed description:~% \"~a\"~%") - (fill-paragraph (escape-quotes upstream) 77 7)) + (G_ "proposed description:~% \"~a\"~%") + (list (fill-paragraph (escape-quotes upstream) 77 7)) #:field 'description)) '())))))) @@ -831,10 +846,10 @@ descriptions maintained upstream." (loop rest)) (prefix (make-warning package - (format #f (G_ "URL should be \ + (G_ "URL should be \ 'mirror://~a/~a'") - mirror-id - (string-drop uri (string-length prefix))) + (list mirror-id + (string-drop uri (string-length prefix))) #:field 'source))))))) (let ((origin (package-source package))) @@ -876,7 +891,8 @@ descriptions maintained upstream." #f (make-warning package - (format #f (G_ "URL should be '~a'") github-uri) + (G_ "URL should be '~a'") + (list github-uri) #:field 'source))))) (origin-uris origin)) '()))) @@ -888,14 +904,14 @@ descriptions maintained upstream." (lambda () (guard (c ((store-protocol-error? c) (make-warning package - (format #f (G_ "failed to create ~a derivation: ~a") - system - (store-protocol-error-message c)))) + (G_ "failed to create ~a derivation: ~a") + (list system + (store-protocol-error-message c)))) ((message-condition? c) (make-warning package - (format #f (G_ "failed to create ~a derivation: ~a") - system - (condition-message c))))) + (G_ "failed to create ~a derivation: ~a") + (list system + (condition-message c))))) (with-store store ;; Disable grafts since it can entail rebuilds. (parameterize ((%graft? #f)) @@ -910,8 +926,8 @@ descriptions maintained upstream." #:graft? #f))))))) (lambda args (make-warning package - (format #f (G_ "failed to create ~a derivation: ~s") - system args))))) + (G_ "failed to create ~a derivation: ~s") + (list system args))))) (filter lint-warning? (map try (package-supported-systems package)))) @@ -1001,15 +1017,15 @@ the NIST server non-fatal." (list (make-warning package - (format #f (G_ "probably vulnerable to ~a") - (string-join (map vulnerability-id unpatched) - ", ")))))))))) + (G_ "probably vulnerable to ~a") + (list (string-join (map vulnerability-id unpatched) + ", ")))))))))) (define (check-for-updates package) "Check if there is an update available for PACKAGE." (match (with-networking-fail-safe - (format #f (G_ "while retrieving upstream info for '~a'") - (package-name package)) + (G_ "while retrieving upstream info for '~a'") + (list (package-name package)) #f (package-latest-release* package (force %updaters))) ((? upstream-source? source) @@ -1017,8 +1033,8 @@ the NIST server non-fatal." (package-version package)) (list (make-warning package - (format #f (G_ "can be upgraded to ~a") - (upstream-source-version source)) + (G_ "can be upgraded to ~a") + (list (upstream-source-version source)) #:field 'version)) '())) (#f '()))) ; cannot find newer upstream release @@ -1034,8 +1050,8 @@ the NIST server non-fatal." (#f #t) (index (make-warning package - (format #f (G_ "tabulation on line ~a, column ~a") - line-number index) + (G_ "tabulation on line ~a, column ~a") + (list line-number index) #:location (location (package-file package) line-number @@ -1046,9 +1062,8 @@ the NIST server non-fatal." (unless (or (string=? line (string-trim-right line)) (string=? line (string #\page))) (make-warning package - (format #f - (G_ "trailing white space on line ~a") - line-number) + (G_ "trailing white space on line ~a") + (list line-number) #:location (location (package-file package) line-number @@ -1061,8 +1076,8 @@ the NIST server non-fatal." ;; much noise. (when (> (string-length line) 90) (make-warning package - (format #f (G_ "line ~a is way too long (~a characters)") - line-number (string-length line)) + (G_ "line ~a is way too long (~a characters)") + (list line-number (string-length line)) #:location (location (package-file package) line-number @@ -1075,10 +1090,9 @@ the NIST server non-fatal." "Emit a warning if LINE contains hanging parentheses." (when (regexp-exec %hanging-paren-rx line) (make-warning package - (format #f - (G_ "parentheses feel lonely, \ + (G_ "parentheses feel lonely, \ move to the previous or next line") - line-number) + (list line-number) #:location (location (package-file package) line-number -- 2.22.0 From debbugs-submit-bounces@debbugs.gnu.org Sat Jun 29 07:56:44 2019 Received: (at 35790) by debbugs.gnu.org; 29 Jun 2019 11:56:44 +0000 Received: from localhost ([127.0.0.1]:43540 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1hhByG-0005UK-K7 for submit@debbugs.gnu.org; Sat, 29 Jun 2019 07:56:44 -0400 Received: from mira.cbaines.net ([212.71.252.8]:34178) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1hhByE-0005UC-Ah for 35790@debbugs.gnu.org; Sat, 29 Jun 2019 07:56:42 -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 441BA17130; Sat, 29 Jun 2019 12:56:38 +0100 (BST) Received: from capella (localhost [127.0.0.1]) by localhost (OpenSMTPD) with ESMTP id 3cc91cd6; Sat, 29 Jun 2019 11:56:37 +0000 (UTC) References: <20190518093206.22069-1-mail@cbaines.net> <878suz27ke.fsf@gnu.org> <87ef4dxgvl.fsf@cbaines.net> <87pnnpj15u.fsf@gnu.org> <87h88pu1cc.fsf@cbaines.net> <875zp0lbmx.fsf@gnu.org> <875zovmqey.fsf@cbaines.net> <87pnn3cr7f.fsf@gnu.org> User-agent: mu4e 1.2.0; emacs 26.2 From: Christopher Baines To: Ludovic =?utf-8?Q?Court=C3=A8s?= Subject: Re: [bug#35790] [PATCH] scripts: lint: Handle warnings with a record type. In-reply-to: <87pnn3cr7f.fsf@gnu.org> Date: Sat, 29 Jun 2019 12:56:37 +0100 Message-ID: <87y31kli4q.fsf@cbaines.net> MIME-Version: 1.0 Content-Type: multipart/signed; boundary="=-=-="; micalg=pgp-sha512; protocol="application/pgp-signature" X-Spam-Score: -0.0 (/) X-Debbugs-Envelope-To: 35790 Cc: 35790@debbugs.gnu.org X-BeenThere: debbugs-submit@debbugs.gnu.org X-Mailman-Version: 2.1.18 Precedence: list List-Id: List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: debbugs-submit-bounces@debbugs.gnu.org Sender: "Debbugs-submit" X-Spam-Score: -1.0 (-) --=-=-= Content-Type: text/plain; charset=utf-8 Content-Transfer-Encoding: quoted-printable Ludovic Court=C3=A8s writes: > Hi Chris, > > Christopher Baines skribis: > >> Thanks, so if I set the bindtextdomain, things do indeed work >> better. So, regarding these two patches, I've got the following things >> on my mind... >> >> - As they change so many things, I'm not sure what to add for the GNU >> changelog at the end of the commit message? > > I think you should try to write the commit log the usual way, by > listing every changed entity. It=E2=80=99s a bit tedious, but it=E2=80= =99s also a good > way to review everything (and Magit makes it relatively easy.) Ok, I've now made an initial attempt at this, and sent some updated patches. --=-=-= Content-Type: application/pgp-signature; name="signature.asc" -----BEGIN PGP SIGNATURE----- iQKTBAEBCgB9FiEEPonu50WOcg2XVOCyXiijOwuE9XcFAl0XUfVfFIAAAAAALgAo aXNzdWVyLWZwckBub3RhdGlvbnMub3BlbnBncC5maWZ0aGhvcnNlbWFuLm5ldDNF ODlFRUU3NDU4RTcyMEQ5NzU0RTBCMjVFMjhBMzNCMEI4NEY1NzcACgkQXiijOwuE 9Xc88Q//UL8IyGSje241shndq9UNY1fVHSGXMepA3kUZuZ+Dkep43HDevhDzelis xdKWngXcQPZFp9GtyHlL5dle+q+laJdZhnWN2VehpIyz8RnGMxMQXKH4kIQkikp8 TciWhGehctQdP1g71EMk8LwxPgFw48JRFjiH5/BO34pspbBKANh3+PCv7OPuObid M5JyeNvhZAXT0b8TgCnztTVGgYS9Wvt7tJSCzej+v/JN5hR9+fgtqO7163V/h//S 5cu77CS67xXEp35a6VKDsYDt5q6XxUyMf5pimCsaUr1AxZgH47wDws1gXKiUqsmy BIJxhF/fRpU8mA1Rb1Hu7DkMdECTBJ2IbXjBn+lUZWHxeBgU5aNA3viAxkUDedQP PVhOgGwBJAohzIN3m3qP8j4zS7sGVhOab66nar4tQokr2lt4rb6dfLZHYL2ZSHD5 wq7RyeUdqUOheRvEFLZuu6i3IILSU6cPigD78LrFg9/i3DzdZzc6Smbn4E+0nDWE nLEeJt8aUSH9HyPEtDt3lBcf9rSuUceCpfql8lQQT+bUyegdduCZy0O6pnTyL/Sc 0TC7o1TBqq57V4pNWxX9Omircu3Asr9ysCD+bu1I1dKTckxhizTHY8avzprQbDDv cXW7M82IqKEtq4UTQlRrtg2OouVNG3mSnqTC/8EfrxN/qMWezho= =1FV9 -----END PGP SIGNATURE----- --=-=-=-- From debbugs-submit-bounces@debbugs.gnu.org Mon Jul 01 08:33:06 2019 Received: (at 35790) by debbugs.gnu.org; 1 Jul 2019 12:33:06 +0000 Received: from localhost ([127.0.0.1]:47740 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1hhvUY-0002wE-FO for submit@debbugs.gnu.org; Mon, 01 Jul 2019 08:33:06 -0400 Received: from eggs.gnu.org ([209.51.188.92]:52130) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1hhvUW-0002vi-8I for 35790@debbugs.gnu.org; Mon, 01 Jul 2019 08:33:05 -0400 Received: from fencepost.gnu.org ([2001:470:142:3::e]:48922) by eggs.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1hhvUQ-00046e-29; Mon, 01 Jul 2019 08:32:58 -0400 Received: from [2001:660:6102:320:e120:2c8f:8909:cdfe] (port=51664 helo=ribbon) by fencepost.gnu.org with esmtpsa (TLS1.2:RSA_AES_256_CBC_SHA1:256) (Exim 4.82) (envelope-from ) id 1hhvUO-0003pS-9N; Mon, 01 Jul 2019 08:32:57 -0400 From: =?utf-8?Q?Ludovic_Court=C3=A8s?= To: Christopher Baines Subject: Re: [bug#35790] [PATCH] scripts: lint: Handle warnings with a record type. References: <20190518093206.22069-1-mail@cbaines.net> <878suz27ke.fsf@gnu.org> <87ef4dxgvl.fsf@cbaines.net> <87pnnpj15u.fsf@gnu.org> <87h88pu1cc.fsf@cbaines.net> <875zp0lbmx.fsf@gnu.org> <875zovmqey.fsf@cbaines.net> <87pnn3cr7f.fsf@gnu.org> <87y31kli4q.fsf@cbaines.net> Date: Mon, 01 Jul 2019 14:32:54 +0200 In-Reply-To: <87y31kli4q.fsf@cbaines.net> (Christopher Baines's message of "Sat, 29 Jun 2019 12:56:37 +0100") Message-ID: <87a7dyoryh.fsf@gnu.org> User-Agent: Gnus/5.13 (Gnus v5.13) Emacs/26.2 (gnu/linux) MIME-Version: 1.0 Content-Type: text/plain; charset=utf-8 Content-Transfer-Encoding: quoted-printable X-detected-operating-system: by eggs.gnu.org: GNU/Linux 2.2.x-3.x [generic] X-Spam-Score: -2.3 (--) X-Debbugs-Envelope-To: 35790 Cc: 35790@debbugs.gnu.org X-BeenThere: debbugs-submit@debbugs.gnu.org X-Mailman-Version: 2.1.18 Precedence: list List-Id: List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: debbugs-submit-bounces@debbugs.gnu.org Sender: "Debbugs-submit" X-Spam-Score: -3.3 (---) Hi! Christopher Baines skribis: > Ludovic Court=C3=A8s writes: > >> Hi Chris, >> >> Christopher Baines skribis: >> >>> Thanks, so if I set the bindtextdomain, things do indeed work >>> better. So, regarding these two patches, I've got the following things >>> on my mind... >>> >>> - As they change so many things, I'm not sure what to add for the GNU >>> changelog at the end of the commit message? >> >> I think you should try to write the commit log the usual way, by >> listing every changed entity. It=E2=80=99s a bit tedious, but it=E2=80= =99s also a good >> way to review everything (and Magit makes it relatively easy.) > > Ok, I've now made an initial attempt at this, and sent some updated > patches. Perfect, thanks for taking the time to do it. Time to push! :-) Thanks, Ludo=E2=80=99. From debbugs-submit-bounces@debbugs.gnu.org Tue Jul 02 15:25:48 2019 Received: (at 35790) by debbugs.gnu.org; 2 Jul 2019 19:25:49 +0000 Received: from localhost ([127.0.0.1]:47975 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1hiOPU-0006WB-5K for submit@debbugs.gnu.org; Tue, 02 Jul 2019 15:25:48 -0400 Received: from mira.cbaines.net ([212.71.252.8]:36496) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1hiOPS-0006W3-An for 35790@debbugs.gnu.org; Tue, 02 Jul 2019 15:25:47 -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 B239617196 for <35790@debbugs.gnu.org>; Tue, 2 Jul 2019 20:25:42 +0100 (BST) Received: from localhost (localhost [local]) by localhost (OpenSMTPD) with ESMTPA id 2d09956e for <35790@debbugs.gnu.org>; Tue, 2 Jul 2019 19:25:42 +0000 (UTC) From: Christopher Baines To: 35790@debbugs.gnu.org Subject: [PATCH 2/2] lint: Separate checkers by dependence on the internet. Date: Tue, 2 Jul 2019 20:25:42 +0100 Message-Id: <20190702192542.16179-2-mail@cbaines.net> X-Mailer: git-send-email 2.22.0 In-Reply-To: <20190702192542.16179-1-mail@cbaines.net> References: <87a7dyoryh.fsf@gnu.org> <20190702192542.16179-1-mail@cbaines.net> MIME-Version: 1.0 Content-Transfer-Encoding: 8bit X-Spam-Score: -0.0 (/) X-Debbugs-Envelope-To: 35790 X-BeenThere: debbugs-submit@debbugs.gnu.org X-Mailman-Version: 2.1.18 Precedence: list List-Id: List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: debbugs-submit-bounces@debbugs.gnu.org Sender: "Debbugs-submit" X-Spam-Score: -1.0 (-) I think there are a couple of potential uses for this. It's somewhat a separation in to what checkers are just checking the contents of the repository (line length for example), and other checkers which are bringing in external information which could change. I'm thinking particularly, about treating network dependant checkers differently when automatically running them, but this commit also adds a --no-network flag to guix lint, which selects the checkers that don't access the network, which could be useful if no network access is available. * guix/lint.scm (%checkers): Rename to %all-checkers. (%local-checkers, %network-dependant-checkers): New variables. * guix/scripts/lint.scm (run-checkers): Make the checkers argument mandatory. (list-checkers-and-exit): Handle the checkers as an argument. (%options): Adjust for changes to %checkers, add a --no-network option, and change how the --list-checkers option is handled. (guix-lint): Adjust indentation, and update how the checkers are handled. --- guix/lint.scm | 64 +++++++++++++++++++++++++------------------ guix/scripts/lint.scm | 49 ++++++++++++++++++++------------- 2 files changed, 67 insertions(+), 46 deletions(-) diff --git a/guix/lint.scm b/guix/lint.scm index f86e494be5..2cc0d34440 100644 --- a/guix/lint.scm +++ b/guix/lint.scm @@ -91,7 +91,10 @@ emit-warnings - %checkers + %local-checkers + %network-dependant-checkers + %all-checkers + lint-checker lint-checker? lint-checker-name @@ -1158,16 +1161,12 @@ them for PACKAGE." ;;; List of checkers. ;;; -(define %checkers +(define %local-checkers (list (lint-checker (name 'description) (description "Validate package descriptions") (check check-description-style)) - (lint-checker - (name 'gnu-description) - (description "Validate synopsis & description of GNU packages") - (check check-gnu-synopsis+description)) (lint-checker (name 'inputs-should-be-native) (description "Identify inputs that should be native inputs") @@ -1176,14 +1175,6 @@ them for PACKAGE." (name 'inputs-should-not-be-input) (description "Identify inputs that shouldn't be inputs at all") (check check-inputs-should-not-be-an-input-at-all)) - (lint-checker - (name 'patch-file-names) - (description "Validate file names and availability of patches") - (check check-patch-file-names)) - (lint-checker - (name 'home-page) - (description "Validate home-page URLs") - (check check-home-page)) (lint-checker (name 'license) ;; TRANSLATORS: is the name of a data type and must not be @@ -1191,18 +1182,10 @@ them for PACKAGE." (description "Make sure the 'license' field is a \ or a list thereof") (check check-license)) - (lint-checker - (name 'source) - (description "Validate source URLs") - (check check-source)) (lint-checker (name 'mirror-url) (description "Suggest 'mirror://' URLs") (check check-mirror-url)) - (lint-checker - (name 'github-url) - (description "Suggest GitHub URLs") - (check check-github-url)) (lint-checker (name 'source-file-name) (description "Validate file names of sources") @@ -1215,10 +1198,37 @@ or a list thereof") (name 'derivation) (description "Report failure to compile a package to a derivation") (check check-derivation)) + (lint-checker + (name 'patch-file-names) + (description "Validate file names and availability of patches") + (check check-patch-file-names)) + (lint-checker + (name 'formatting) + (description "Look for formatting issues in the source") + (check check-formatting)))) + +(define %network-dependant-checkers + (list (lint-checker (name 'synopsis) (description "Validate package synopses") (check check-synopsis-style)) + (lint-checker + (name 'gnu-description) + (description "Validate synopsis & description of GNU packages") + (check check-gnu-synopsis+description)) + (lint-checker + (name 'home-page) + (description "Validate home-page URLs") + (check check-home-page)) + (lint-checker + (name 'source) + (description "Validate source URLs") + (check check-source)) + (lint-checker + (name 'github-url) + (description "Suggest GitHub URLs") + (check check-github-url)) (lint-checker (name 'cve) (description "Check the Common Vulnerabilities and Exposures\ @@ -1227,8 +1237,8 @@ or a list thereof") (lint-checker (name 'refresh) (description "Check the package for new upstream releases") - (check check-for-updates)) - (lint-checker - (name 'formatting) - (description "Look for formatting issues in the source") - (check check-formatting)))) + (check check-for-updates)))) + +(define %all-checkers + (append %local-checkers + %network-dependant-checkers)) diff --git a/guix/scripts/lint.scm b/guix/scripts/lint.scm index 8a8ffc8f28..c2e022cf94 100644 --- a/guix/scripts/lint.scm +++ b/guix/scripts/lint.scm @@ -38,7 +38,7 @@ #:export (guix-lint run-checkers)) -(define* (run-checkers package #:optional (checkers %checkers)) +(define (run-checkers package checkers) "Run the given CHECKERS on PACKAGE." (let ((tty? (isatty? (current-error-port)))) (for-each (lambda (checker) @@ -54,14 +54,14 @@ (format (current-error-port) "\x1b[K") (force-output (current-error-port))))) -(define (list-checkers-and-exit) +(define (list-checkers-and-exit checkers) ;; Print information about all available checkers and exit. (format #t (G_ "Available checkers:~%")) (for-each (lambda (checker) (format #t "- ~a: ~a~%" (lint-checker-name checker) (G_ (lint-checker-description checker)))) - %checkers) + checkers) (exit 0)) @@ -97,26 +97,33 @@ run the checkers on all packages.\n")) ;; 'certainty'. (list (option '(#\c "checkers") #t #f (lambda (opt name arg result) - (let ((names (map string->symbol (string-split arg #\,)))) + (let ((names (map string->symbol (string-split arg #\,))) + (checker-names (map lint-checker-name %all-checkers))) (for-each (lambda (c) - (unless (memq c - (map lint-checker-name - %checkers)) + (unless (memq c checker-names) (leave (G_ "~a: invalid checker~%") c))) names) (alist-cons 'checkers (filter (lambda (checker) (member (lint-checker-name checker) names)) - %checkers) + %all-checkers) result)))) + (option '(#\n "no-network") #f #f + (lambda (opt name arg result) + (alist-cons 'checkers + %local-checkers + (alist-delete 'checkers + result)))) (option '(#\h "help") #f #f (lambda args (show-help) (exit 0))) (option '(#\l "list-checkers") #f #f - (lambda args - (list-checkers-and-exit))) + (lambda (opt name arg result) + (alist-cons 'list? + #t + result))) (option '(#\V "version") #f #f (lambda args (show-version-and-exit "guix lint"))))) @@ -134,13 +141,17 @@ run the checkers on all packages.\n")) (let* ((opts (parse-options)) (args (filter-map (match-lambda - (('argument . value) - value) - (_ #f)) + (('argument . value) + value) + (_ #f)) (reverse opts))) - (checkers (or (assoc-ref opts 'checkers) %checkers))) - (if (null? args) - (fold-packages (lambda (p r) (run-checkers p checkers)) '()) - (for-each (lambda (spec) - (run-checkers (specification->package spec) checkers)) - args)))) + (checkers (or (assoc-ref opts 'checkers) %all-checkers))) + (cond + ((assoc-ref opts 'list?) + (list-checkers-and-exit checkers)) + ((null? args) + (fold-packages (lambda (p r) (run-checkers p checkers)) '())) + (else + (for-each (lambda (spec) + (run-checkers (specification->package spec) checkers)) + args))))) -- 2.22.0 From debbugs-submit-bounces@debbugs.gnu.org Tue Jul 02 15:25:58 2019 Received: (at 35790) by debbugs.gnu.org; 2 Jul 2019 19:25:59 +0000 Received: from localhost ([127.0.0.1]:47977 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1hiOPW-0006WQ-Te for submit@debbugs.gnu.org; Tue, 02 Jul 2019 15:25:58 -0400 Received: from mira.cbaines.net ([212.71.252.8]:36494) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1hiOPQ-0006W0-M8 for 35790@debbugs.gnu.org; Tue, 02 Jul 2019 15:25:49 -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 7AA251718A for <35790@debbugs.gnu.org>; Tue, 2 Jul 2019 20:25:42 +0100 (BST) Received: from localhost (localhost [local]) by localhost (OpenSMTPD) with ESMTPA id fb178ab0 for <35790@debbugs.gnu.org>; Tue, 2 Jul 2019 19:25:42 +0000 (UTC) From: Christopher Baines To: 35790@debbugs.gnu.org Subject: [PATCH 1/2] lint: Move the linting code to a different module. Date: Tue, 2 Jul 2019 20:25:41 +0100 Message-Id: <20190702192542.16179-1-mail@cbaines.net> X-Mailer: git-send-email 2.22.0 In-Reply-To: <87a7dyoryh.fsf@gnu.org> References: <87a7dyoryh.fsf@gnu.org> MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit X-Spam-Score: 0.0 (/) X-Debbugs-Envelope-To: 35790 X-BeenThere: debbugs-submit@debbugs.gnu.org X-Mailman-Version: 2.1.18 Precedence: list List-Id: List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: debbugs-submit-bounces@debbugs.gnu.org Sender: "Debbugs-submit" X-Spam-Score: -1.0 (-) To try and move towards making programatic access to the linting code easier, this commit separates out the linting script, from the linting functionality that it uses. --- Makefile.am | 1 + guix/lint.scm | 1234 +++++++++++++++++++++++++++++++++++++++++ guix/scripts/lint.scm | 1220 +--------------------------------------- tests/lint.scm | 2 +- 4 files changed, 1248 insertions(+), 1209 deletions(-) create mode 100644 guix/lint.scm diff --git a/Makefile.am b/Makefile.am index 80be73e4bf..0baadcde9c 100644 --- a/Makefile.am +++ b/Makefile.am @@ -97,6 +97,7 @@ MODULES = \ guix/self.scm \ guix/upstream.scm \ guix/licenses.scm \ + guix/lint.scm \ guix/glob.scm \ guix/git.scm \ guix/graph.scm \ diff --git a/guix/lint.scm b/guix/lint.scm new file mode 100644 index 0000000000..f86e494be5 --- /dev/null +++ b/guix/lint.scm @@ -0,0 +1,1234 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2014 Cyril Roelandt +;;; Copyright © 2014, 2015 Eric Bavier +;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018, 2019 Ludovic Courtès +;;; Copyright © 2015, 2016 Mathieu Lirzin +;;; Copyright © 2016 Danny Milosavljevic +;;; Copyright © 2016 Hartmut Goebel +;;; Copyright © 2017 Alex Kost +;;; Copyright © 2017 Tobias Geerinckx-Rice +;;; Copyright © 2017, 2018 Efraim Flashner +;;; Copyright © 2018, 2019 Arun Isaac +;;; +;;; This file is part of GNU Guix. +;;; +;;; GNU Guix is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; GNU Guix is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with GNU Guix. If not, see . + +(define-module (guix lint) + #:use-module ((guix store) #:hide (close-connection)) + #:use-module (guix base32) + #:use-module (guix download) + #:use-module (guix ftp-client) + #:use-module (guix http-client) + #:use-module (guix packages) + #:use-module (guix licenses) + #:use-module (guix records) + #:use-module (guix grafts) + #:use-module (guix ui) + #:use-module (guix upstream) + #:use-module (guix utils) + #:use-module (guix memoization) + #:use-module (guix scripts) + #:use-module (guix gnu-maintenance) + #:use-module (guix monads) + #:use-module (guix cve) + #:use-module (gnu packages) + #:use-module (ice-9 match) + #:use-module (ice-9 regex) + #:use-module (ice-9 format) + #:use-module (web client) + #:use-module (web uri) + #:use-module ((guix build download) + #:select (maybe-expand-mirrors + (open-connection-for-uri + . guix:open-connection-for-uri) + close-connection)) + #:use-module (web request) + #:use-module (web response) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-6) ;Unicode string ports + #:use-module (srfi srfi-9) + #:use-module (srfi srfi-11) + #:use-module (srfi srfi-26) + #:use-module (srfi srfi-34) + #:use-module (srfi srfi-35) + #:use-module (ice-9 rdelim) + #:export (check-description-style + check-inputs-should-be-native + check-inputs-should-not-be-an-input-at-all + check-patch-file-names + check-synopsis-style + check-derivation + check-home-page + check-source + check-source-file-name + check-source-unstable-tarball + check-mirror-url + check-github-url + check-license + check-vulnerabilities + check-for-updates + check-formatting + + lint-warning + lint-warning? + lint-warning-package + lint-warning-message + lint-warning-message-text + lint-warning-message-data + lint-warning-location + + emit-warnings + + %checkers + lint-checker + lint-checker? + lint-checker-name + lint-checker-description + lint-checker-check)) + + +;;; +;;; Warnings +;;; + +(define-record-type* + lint-warning make-lint-warning + lint-warning? + (package lint-warning-package) + (message-text lint-warning-message-text) + (message-data lint-warning-message-data + (default '())) + (location lint-warning-location + (default #f))) + +(define (lint-warning-message warning) + (apply format #f + (G_ (lint-warning-message-text warning)) + (lint-warning-message-data warning))) + +(define (package-file package) + (location-file + (package-location package))) + +(define* (%make-warning package message-text + #:optional (message-data '()) + #:key field location) + (make-lint-warning + package + message-text + message-data + (or location + (package-field-location package field) + (package-location package)))) + +(define-syntax make-warning + (syntax-rules (G_) + ((_ package (G_ message) rest ...) + (%make-warning package message rest ...)))) + +(define (emit-warnings warnings) + ;; Emit a warning about PACKAGE, printing the location of FIELD if it is + ;; given, the location of PACKAGE otherwise, the full name of PACKAGE and the + ;; provided MESSAGE. + (for-each + (match-lambda + (($ package message-text message-data loc) + (format (guix-warning-port) "~a: ~a@~a: ~a~%" + (location->string loc) + (package-name package) (package-version package) + (apply format #f (G_ message-text) message-data)))) + warnings)) + + +;;; +;;; Checkers +;;; + +(define-record-type* + lint-checker make-lint-checker + lint-checker? + ;; TODO: add a 'certainty' field that shows how confident we are in the + ;; checker. Then allow users to only run checkers that have a certain + ;; 'certainty' level. + (name lint-checker-name) + (description lint-checker-description) + (check lint-checker-check)) + +(define (properly-starts-sentence? s) + (string-match "^[(\"'`[:upper:][:digit:]]" s)) + +(define (starts-with-abbreviation? s) + "Return #t if S starts with what looks like an abbreviation or acronym." + (string-match "^[A-Z][A-Z0-9]+\\>" s)) + +(define %quoted-identifier-rx + ;; A quoted identifier, like 'this'. + (make-regexp "['`][[:graph:]]+'")) + +(define (check-description-style package) + ;; Emit a warning if stylistic issues are found in the description of PACKAGE. + (define (check-not-empty description) + (if (string-null? description) + (list + (make-warning package + (G_ "description should not be empty") + #:field 'description)) + '())) + + (define (check-texinfo-markup description) + "Check that DESCRIPTION can be parsed as a Texinfo fragment. If the +markup is valid return a plain-text version of DESCRIPTION, otherwise #f." + (catch #t + (lambda () (texi->plain-text description)) + (lambda (keys . args) + (make-warning package + (G_ "Texinfo markup in description is invalid") + #:field 'description)))) + + (define (check-trademarks description) + "Check that DESCRIPTION does not contain '™' or '®' characters. See +http://www.gnu.org/prep/standards/html_node/Trademarks.html." + (match (string-index description (char-set #\™ #\®)) + ((and (? number?) index) + (list + (make-warning package + (G_ "description should not contain ~ +trademark sign '~a' at ~d") + (list (string-ref description index) index) + #:field 'description))) + (else '()))) + + (define (check-quotes description) + "Check whether DESCRIPTION contains single quotes and suggest @code." + (if (regexp-exec %quoted-identifier-rx description) + (list + (make-warning package + ;; TRANSLATORS: '@code' is Texinfo markup and must be kept + ;; as is. + (G_ "use @code or similar ornament instead of quotes") + #:field 'description)) + '())) + + (define (check-proper-start description) + (if (or (string-null? description) + (properly-starts-sentence? description) + (string-prefix-ci? (package-name package) description)) + '() + (list + (make-warning + package + (G_ "description should start with an upper-case letter or digit") + #:field 'description)))) + + (define (check-end-of-sentence-space description) + "Check that an end-of-sentence period is followed by two spaces." + (let ((infractions + (reverse (fold-matches + "\\. [A-Z]" description '() + (lambda (m r) + ;; Filter out matches of common abbreviations. + (if (find (lambda (s) + (string-suffix-ci? s (match:prefix m))) + '("i.e" "e.g" "a.k.a" "resp")) + r (cons (match:start m) r))))))) + (if (null? infractions) + '() + (list + (make-warning package + (G_ "sentences in description should be followed ~ +by two spaces; possible infraction~p at ~{~a~^, ~}") + (list (length infractions) + infractions) + #:field 'description))))) + + (let ((description (package-description package))) + (if (string? description) + (append + (check-not-empty description) + (check-quotes description) + (check-trademarks description) + ;; Use raw description for this because Texinfo rendering + ;; automatically fixes end of sentence space. + (check-end-of-sentence-space description) + (match (check-texinfo-markup description) + ((and warning (? lint-warning?)) (list warning)) + (plain-description + (check-proper-start plain-description)))) + (list + (make-warning package + (G_ "invalid description: ~s") + (list description) + #:field 'description))))) + +(define (package-input-intersection inputs-to-check input-names) + "Return the intersection between INPUTS-TO-CHECK, the list of input tuples +of a package, and INPUT-NAMES, a list of package specifications such as +\"glib:bin\"." + (match inputs-to-check + (((labels packages . outputs) ...) + (filter-map (lambda (package output) + (and (package? package) + (let ((input (string-append + (package-name package) + (if (> (length output) 0) + (string-append ":" (car output)) + "")))) + (and (member input input-names) + input)))) + packages outputs)))) + +(define (check-inputs-should-be-native package) + ;; Emit a warning if some inputs of PACKAGE are likely to belong to its + ;; native inputs. + (let ((inputs (package-inputs package)) + (input-names + '("pkg-config" + "cmake" + "extra-cmake-modules" + "glib:bin" + "intltool" + "itstool" + "qttools" + "python-coverage" "python2-coverage" + "python-cython" "python2-cython" + "python-docutils" "python2-docutils" + "python-mock" "python2-mock" + "python-nose" "python2-nose" + "python-pbr" "python2-pbr" + "python-pytest" "python2-pytest" + "python-pytest-cov" "python2-pytest-cov" + "python-setuptools-scm" "python2-setuptools-scm" + "python-sphinx" "python2-sphinx"))) + (map (lambda (input) + (make-warning + package + (G_ "'~a' should probably be a native input") + (list input) + #:field 'inputs)) + (package-input-intersection inputs input-names)))) + +(define (check-inputs-should-not-be-an-input-at-all package) + ;; Emit a warning if some inputs of PACKAGE are likely to should not be + ;; an input at all. + (let ((input-names '("python-setuptools" + "python2-setuptools" + "python-pip" + "python2-pip"))) + (map (lambda (input) + (make-warning + package + (G_ "'~a' should probably not be an input at all") + (list input) + #:field 'inputs)) + (package-input-intersection (package-direct-inputs package) + input-names)))) + +(define (package-name-regexp package) + "Return a regexp that matches PACKAGE's name as a word at the beginning of a +line." + (make-regexp (string-append "^" (regexp-quote (package-name package)) + "\\>") + regexp/icase)) + +(define (check-synopsis-style package) + ;; Emit a warning if stylistic issues are found in the synopsis of PACKAGE. + (define (check-final-period synopsis) + ;; Synopsis should not end with a period, except for some special cases. + (if (and (string-suffix? "." synopsis) + (not (string-suffix? "etc." synopsis))) + (list + (make-warning package + (G_ "no period allowed at the end of the synopsis") + #:field 'synopsis)) + '())) + + (define check-start-article + ;; Skip this check for GNU packages, as suggested by Karl Berry's reply to + ;; . + (if (false-if-exception (gnu-package? package)) + (const '()) + (lambda (synopsis) + (if (or (string-prefix-ci? "A " synopsis) + (string-prefix-ci? "An " synopsis)) + (list + (make-warning package + (G_ "no article allowed at the beginning of \ +the synopsis") + #:field 'synopsis)) + '())))) + + (define (check-synopsis-length synopsis) + (if (>= (string-length synopsis) 80) + (list + (make-warning package + (G_ "synopsis should be less than 80 characters long") + #:field 'synopsis)) + '())) + + (define (check-proper-start synopsis) + (if (properly-starts-sentence? synopsis) + '() + (list + (make-warning package + (G_ "synopsis should start with an upper-case letter or digit") + #:field 'synopsis)))) + + (define (check-start-with-package-name synopsis) + (if (and (regexp-exec (package-name-regexp package) synopsis) + (not (starts-with-abbreviation? synopsis))) + (list + (make-warning package + (G_ "synopsis should not start with the package name") + #:field 'synopsis)) + '())) + + (define (check-texinfo-markup synopsis) + "Check that SYNOPSIS can be parsed as a Texinfo fragment. If the +markup is valid return a plain-text version of SYNOPSIS, otherwise #f." + (catch #t + (lambda () + (texi->plain-text synopsis) + '()) + (lambda (keys . args) + (list + (make-warning package + (G_ "Texinfo markup in synopsis is invalid") + #:field 'synopsis))))) + + (define checks + (list check-proper-start + check-final-period + check-start-article + check-start-with-package-name + check-synopsis-length + check-texinfo-markup)) + + (match (package-synopsis package) + ("" + (list + (make-warning package + (G_ "synopsis should not be empty") + #:field 'synopsis))) + ((? string? synopsis) + (append-map + (lambda (proc) + (proc synopsis)) + checks)) + (invalid + (list + (make-warning package + (G_ "invalid synopsis: ~s") + (list invalid) + #:field 'synopsis))))) + +(define* (probe-uri uri #:key timeout) + "Probe URI, a URI object, and return two values: a symbol denoting the +probing status, such as 'http-response' when we managed to get an HTTP +response from URI, and additional details, such as the actual HTTP response. + +TIMEOUT is the maximum number of seconds (possibly an inexact number) to wait +for connections to complete; when TIMEOUT is #f, wait as long as needed." + (define headers + '((User-Agent . "GNU Guile") + (Accept . "*/*"))) + + (let loop ((uri uri) + (visited '())) + (match (uri-scheme uri) + ((or 'http 'https) + (catch #t + (lambda () + (let ((port (guix:open-connection-for-uri + uri #:timeout timeout)) + (request (build-request uri #:headers headers))) + (define response + (dynamic-wind + (const #f) + (lambda () + (write-request request port) + (force-output port) + (read-response port)) + (lambda () + (close-connection port)))) + + (case (response-code response) + ((302 ; found (redirection) + 303 ; see other + 307 ; temporary redirection + 308) ; permanent redirection + (let ((location (response-location response))) + (if (or (not location) (member location visited)) + (values 'http-response response) + (loop location (cons location visited))))) ;follow the redirect + ((301) ; moved permanently + (let ((location (response-location response))) + ;; Return RESPONSE, unless the final response as we follow + ;; redirects is not 200. + (if location + (let-values (((status response2) + (loop location (cons location visited)))) + (case status + ((http-response) + (values 'http-response + (if (= 200 (response-code response2)) + response + response2))) + (else + (values status response2)))) + (values 'http-response response)))) ;invalid redirect + (else + (values 'http-response response))))) + (lambda (key . args) + (case key + ((bad-header bad-header-component) + ;; This can happen if the server returns an invalid HTTP header, + ;; as is the case with the 'Date' header at sqlite.org. + (values 'invalid-http-response #f)) + ((getaddrinfo-error system-error + gnutls-error tls-certificate-error) + (values key args)) + (else + (apply throw key args)))))) + ('ftp + (catch #t + (lambda () + (let ((conn (ftp-open (uri-host uri) #:timeout timeout))) + (define response + (dynamic-wind + (const #f) + (lambda () + (ftp-chdir conn (dirname (uri-path uri))) + (ftp-size conn (basename (uri-path uri)))) + (lambda () + (ftp-close conn)))) + (values 'ftp-response '(ok)))) + (lambda (key . args) + (case key + ((ftp-error) + (values 'ftp-response `(error ,@args))) + ((getaddrinfo-error system-error gnutls-error) + (values key args)) + (else + (apply throw key args)))))) + (_ + (values 'unknown-protocol #f))))) + +(define (tls-certificate-error-string args) + "Return a string explaining the 'tls-certificate-error' arguments ARGS." + (call-with-output-string + (lambda (port) + (print-exception port #f + 'tls-certificate-error args)))) + +(define (validate-uri uri package field) + "Return #t if the given URI can be reached, otherwise return a warning for +PACKAGE mentionning the FIELD." + (let-values (((status argument) + (probe-uri uri #:timeout 3))) ;wait at most 3 seconds + (case status + ((http-response) + (cond ((= 200 (response-code argument)) + (match (response-content-length argument) + ((? number? length) + ;; As of July 2016, SourceForge returns 200 (instead of 404) + ;; with a small HTML page upon failure. Attempt to detect + ;; such malicious behavior. + (or (> length 1000) + (make-warning package + (G_ "URI ~a returned \ +suspiciously small file (~a bytes)") + (list (uri->string uri) + length) + #:field field))) + (_ #t))) + ((= 301 (response-code argument)) + (if (response-location argument) + (make-warning package + (G_ "permanent redirect from ~a to ~a") + (list (uri->string uri) + (uri->string + (response-location argument))) + #:field field) + (make-warning package + (G_ "invalid permanent redirect \ +from ~a") + (list (uri->string uri)) + #:field field))) + (else + (make-warning package + (G_ "URI ~a not reachable: ~a (~s)") + (list (uri->string uri) + (response-code argument) + (response-reason-phrase argument)) + #:field field)))) + ((ftp-response) + (match argument + (('ok) #t) + (('error port command code message) + (make-warning package + (G_ "URI ~a not reachable: ~a (~s)") + (list (uri->string uri) + code (string-trim-both message)) + #:field field)))) + ((getaddrinfo-error) + (make-warning package + (G_ "URI ~a domain not found: ~a") + (list (uri->string uri) + (gai-strerror (car argument))) + #:field field)) + ((system-error) + (make-warning package + (G_ "URI ~a unreachable: ~a") + (list (uri->string uri) + (strerror + (system-error-errno + (cons status argument)))) + #:field field)) + ((tls-certificate-error) + (make-warning package + (G_ "TLS certificate error: ~a") + (list (tls-certificate-error-string argument)) + #:field field)) + ((invalid-http-response gnutls-error) + ;; Probably a misbehaving server; ignore. + #f) + ((unknown-protocol) ;nothing we can do + #f) + (else + (error "internal linter error" status))))) + +(define (check-home-page package) + "Emit a warning if PACKAGE has an invalid 'home-page' field, or if that +'home-page' is not reachable." + (let ((uri (and=> (package-home-page package) string->uri))) + (cond + ((uri? uri) + (match (validate-uri uri package 'home-page) + ((and (? lint-warning? warning) warning) + (list warning)) + (_ '()))) + ((not (package-home-page package)) + (if (or (string-contains (package-name package) "bootstrap") + (string=? (package-name package) "ld-wrapper")) + '() + (list + (make-warning package + (G_ "invalid value for home page") + #:field 'home-page)))) + (else + (list + (make-warning package + (G_ "invalid home page URL: ~s") + (list (package-home-page package)) + #:field 'home-page)))))) + +(define %distro-directory + (mlambda () + (dirname (search-path %load-path "gnu.scm")))) + +(define (check-patch-file-names package) + "Emit a warning if the patches requires by PACKAGE are badly named or if the +patch could not be found." + (guard (c ((message-condition? c) ;raised by 'search-patch' + (list + ;; Use %make-warning, as condition-mesasge is already + ;; translated. + (%make-warning package (condition-message c) + #:field 'patch-file-names)))) + (define patches + (or (and=> (package-source package) origin-patches) + '())) + + (append + (if (every (match-lambda ;patch starts with package name? + ((? string? patch) + (and=> (string-contains (basename patch) + (package-name package)) + zero?)) + (_ #f)) ;must be an or something like that. + patches) + '() + (list + (make-warning + package + (G_ "file names of patches should start with the package name") + #:field 'patch-file-names))) + + ;; Check whether we're reaching tar's maximum file name length. + (let ((prefix (string-length (%distro-directory))) + (margin (string-length "guix-0.13.0-10-123456789/")) + (max 99)) + (filter-map (match-lambda + ((? string? patch) + (if (> (+ margin (if (string-prefix? (%distro-directory) + patch) + (- (string-length patch) prefix) + (string-length patch))) + max) + (make-warning + package + (G_ "~a: file name is too long") + (list (basename patch)) + #:field 'patch-file-names) + #f)) + (_ #f)) + patches))))) + +(define (escape-quotes str) + "Replace any quote character in STR by an escaped quote character." + (list->string + (string-fold-right (lambda (chr result) + (match chr + (#\" (cons* #\\ #\"result)) + (_ (cons chr result)))) + '() + str))) + +(define official-gnu-packages* + (mlambda () + "A memoizing version of 'official-gnu-packages' that returns the empty +list when something goes wrong, such as a networking issue." + (let ((gnus (false-if-exception (official-gnu-packages)))) + (or gnus '())))) + +(define (check-gnu-synopsis+description package) + "Make sure that, if PACKAGE is a GNU package, it uses the synopsis and +descriptions maintained upstream." + (match (find (lambda (descriptor) + (string=? (gnu-package-name descriptor) + (package-name package))) + (official-gnu-packages*)) + (#f ;not a GNU package, so nothing to do + '()) + (descriptor ;a genuine GNU package + (append + (let ((upstream (gnu-package-doc-summary descriptor)) + (downstream (package-synopsis package))) + (if (and upstream + (or (not (string? downstream)) + (not (string=? upstream downstream)))) + (list + (make-warning package + (G_ "proposed synopsis: ~s~%") + (list upstream) + #:field 'synopsis)) + '())) + + (let ((upstream (gnu-package-doc-description descriptor)) + (downstream (package-description package))) + (if (and upstream + (or (not (string? downstream)) + (not (string=? (fill-paragraph upstream 100) + (fill-paragraph downstream 100))))) + (list + (make-warning + package + (G_ "proposed description:~% \"~a\"~%") + (list (fill-paragraph (escape-quotes upstream) 77 7)) + #:field 'description)) + '())))))) + +(define (origin-uris origin) + "Return the list of URIs (strings) for ORIGIN." + (match (origin-uri origin) + ((? string? uri) + (list uri)) + ((uris ...) + uris))) + +(define (check-source package) + "Emit a warning if PACKAGE has an invalid 'source' field, or if that +'source' is not reachable." + (define (warnings-for-uris uris) + (filter lint-warning? + (map + (lambda (uri) + (validate-uri uri package 'source)) + (append-map (cut maybe-expand-mirrors <> %mirrors) + uris)))) + + (let ((origin (package-source package))) + (if (and origin + (eqv? (origin-method origin) url-fetch)) + (let* ((uris (map string->uri (origin-uris origin))) + (warnings (warnings-for-uris uris))) + + ;; Just make sure that at least one of the URIs is valid. + (if (eq? (length uris) (length warnings)) + ;; When everything fails, report all of WARNINGS, otherwise don't + ;; report anything. + ;; + ;; XXX: Ideally we'd still allow warnings to be raised if *some* + ;; URIs are unreachable, but distinguish that from the error case + ;; where *all* the URIs are unreachable. + (cons* + (make-warning package + (G_ "all the source URIs are unreachable:") + #:field 'source) + warnings) + '())) + '()))) + +(define (check-source-file-name package) + "Emit a warning if PACKAGE's origin has no meaningful file name." + (define (origin-file-name-valid? origin) + ;; Return #f if the source file name contains only a version or is #f; + ;; indicates that the origin needs a 'file-name' field. + (let ((file-name (origin-actual-file-name origin)) + (version (package-version package))) + (and file-name + ;; Common in many projects is for the filename to start + ;; with a "v" followed by the version, + ;; e.g. "v3.2.0.tar.gz". + (not (string-match (string-append "^v?" version) file-name))))) + + (let ((origin (package-source package))) + (if (or (not origin) (origin-file-name-valid? origin)) + '() + (list + (make-warning package + (G_ "the source file name should contain the package name") + #:field 'source))))) + +(define (check-source-unstable-tarball package) + "Emit a warning if PACKAGE's source is an autogenerated tarball." + (define (check-source-uri uri) + (if (and (string=? (uri-host (string->uri uri)) "github.com") + (match (split-and-decode-uri-path + (uri-path (string->uri uri))) + ((_ _ "archive" _ ...) #t) + (_ #f))) + (make-warning package + (G_ "the source URI should not be an autogenerated tarball") + #:field 'source) + #f)) + + (let ((origin (package-source package))) + (if (and (origin? origin) + (eqv? (origin-method origin) url-fetch)) + (filter-map check-source-uri + (origin-uris origin)) + '()))) + +(define (check-mirror-url package) + "Check whether PACKAGE uses source URLs that should be 'mirror://'." + (define (check-mirror-uri uri) ;XXX: could be optimized + (let loop ((mirrors %mirrors)) + (match mirrors + (() + #f) + (((mirror-id mirror-urls ...) rest ...) + (match (find (cut string-prefix? <> uri) mirror-urls) + (#f + (loop rest)) + (prefix + (make-warning package + (G_ "URL should be \ +'mirror://~a/~a'") + (list mirror-id + (string-drop uri (string-length prefix))) + #:field 'source))))))) + + (let ((origin (package-source package))) + (if (and (origin? origin) + (eqv? (origin-method origin) url-fetch)) + (let ((uris (origin-uris origin))) + (filter-map check-mirror-uri uris)) + '()))) + +(define* (check-github-url package #:key (timeout 3)) + "Check whether PACKAGE uses source URLs that redirect to GitHub." + (define (follow-redirect url) + (let* ((uri (string->uri url)) + (port (guix:open-connection-for-uri uri #:timeout timeout)) + (response (http-head uri #:port port))) + (close-port port) + (case (response-code response) + ((301 302) + (uri->string (assoc-ref (response-headers response) 'location))) + (else #f)))) + + (define (follow-redirects-to-github uri) + (cond + ((string-prefix? "https://github.com/" uri) uri) + ((string-prefix? "http" uri) + (and=> (follow-redirect uri) follow-redirects-to-github)) + ;; Do not attempt to follow redirects on URIs other than http and https + ;; (such as mirror, file) + (else #f))) + + (let ((origin (package-source package))) + (if (and (origin? origin) + (eqv? (origin-method origin) url-fetch)) + (filter-map + (lambda (uri) + (and=> (follow-redirects-to-github uri) + (lambda (github-uri) + (if (string=? github-uri uri) + #f + (make-warning + package + (G_ "URL should be '~a'") + (list github-uri) + #:field 'source))))) + (origin-uris origin)) + '()))) + +(define (check-derivation package) + "Emit a warning if we fail to compile PACKAGE to a derivation." + (define (try system) + (catch #t + (lambda () + (guard (c ((store-protocol-error? c) + (make-warning package + (G_ "failed to create ~a derivation: ~a") + (list system + (store-protocol-error-message c)))) + ((message-condition? c) + (make-warning package + (G_ "failed to create ~a derivation: ~a") + (list system + (condition-message c))))) + (with-store store + ;; Disable grafts since it can entail rebuilds. + (parameterize ((%graft? #f)) + (package-derivation store package system #:graft? #f) + + ;; If there's a replacement, make sure we can compute its + ;; derivation. + (match (package-replacement package) + (#f #t) + (replacement + (package-derivation store replacement system + #:graft? #f))))))) + (lambda args + (make-warning package + (G_ "failed to create ~a derivation: ~s") + (list system args))))) + + (filter lint-warning? + (map try (package-supported-systems package)))) + +(define (check-license package) + "Warn about type errors of the 'license' field of PACKAGE." + (match (package-license package) + ((or (? license?) + ((? license?) ...)) + '()) + (x + (list + (make-warning package (G_ "invalid license field") + #:field 'license))))) + +(define (call-with-networking-fail-safe message error-value proc) + "Call PROC catching any network-related errors. Upon a networking error, +display a message including MESSAGE and return ERROR-VALUE." + (guard (c ((http-get-error? c) + (warning (G_ "~a: HTTP GET error for ~a: ~a (~s)~%") + message + (uri->string (http-get-error-uri c)) + (http-get-error-code c) + (http-get-error-reason c)) + error-value)) + (catch #t + proc + (match-lambda* + (('getaddrinfo-error errcode) + (warning (G_ "~a: host lookup failure: ~a~%") + message + (gai-strerror errcode)) + error-value) + (('tls-certificate-error args ...) + (warning (G_ "~a: TLS certificate error: ~a") + message + (tls-certificate-error-string args)) + error-value) + (args + (apply throw args)))))) + +(define-syntax-rule (with-networking-fail-safe message error-value exp ...) + (call-with-networking-fail-safe message error-value + (lambda () exp ...))) + +(define (current-vulnerabilities*) + "Like 'current-vulnerabilities', but return the empty list upon networking +or HTTP errors. This allows network-less operation and makes problems with +the NIST server non-fatal." + (with-networking-fail-safe (G_ "while retrieving CVE vulnerabilities") + '() + (current-vulnerabilities))) + +(define package-vulnerabilities + (let ((lookup (delay (vulnerabilities->lookup-proc + (current-vulnerabilities*))))) + (lambda (package) + "Return a list of vulnerabilities affecting PACKAGE." + ;; First we retrieve the Common Platform Enumeration (CPE) name and + ;; version for PACKAGE, then we can pass them to LOOKUP. + (let ((name (or (assoc-ref (package-properties package) + 'cpe-name) + (package-name package))) + (version (or (assoc-ref (package-properties package) + 'cpe-version) + (package-version package)))) + ((force lookup) name version))))) + +(define (check-vulnerabilities package) + "Check for known vulnerabilities for PACKAGE." + (let ((package (or (package-replacement package) package))) + (match (package-vulnerabilities package) + (() + '()) + ((vulnerabilities ...) + (let* ((patched (package-patched-vulnerabilities package)) + (known-safe (or (assq-ref (package-properties package) + 'lint-hidden-cve) + '())) + (unpatched (remove (lambda (vuln) + (let ((id (vulnerability-id vuln))) + (or (member id patched) + (member id known-safe)))) + vulnerabilities))) + (if (null? unpatched) + '() + (list + (make-warning + package + (G_ "probably vulnerable to ~a") + (list (string-join (map vulnerability-id unpatched) + ", ")))))))))) + +(define (check-for-updates package) + "Check if there is an update available for PACKAGE." + (match (with-networking-fail-safe + (G_ "while retrieving upstream info for '~a'") + (list (package-name package)) + #f + (package-latest-release* package (force %updaters))) + ((? upstream-source? source) + (if (version>? (upstream-source-version source) + (package-version package)) + (list + (make-warning package + (G_ "can be upgraded to ~a") + (list (upstream-source-version source)) + #:field 'version)) + '())) + (#f '()))) ; cannot find newer upstream release + + +;;; +;;; Source code formatting. +;;; + +(define (report-tabulations package line line-number) + "Warn about tabulations found in LINE." + (match (string-index line #\tab) + (#f #t) + (index + (make-warning package + (G_ "tabulation on line ~a, column ~a") + (list line-number index) + #:location + (location (package-file package) + line-number + index))))) + +(define (report-trailing-white-space package line line-number) + "Warn about trailing white space in LINE." + (unless (or (string=? line (string-trim-right line)) + (string=? line (string #\page))) + (make-warning package + (G_ "trailing white space on line ~a") + (list line-number) + #:location + (location (package-file package) + line-number + 0)))) + +(define (report-long-line package line line-number) + "Emit a warning if LINE is too long." + ;; Note: We don't warn at 80 characters because sometimes hashes and URLs + ;; make it hard to fit within that limit and we want to avoid making too + ;; much noise. + (when (> (string-length line) 90) + (make-warning package + (G_ "line ~a is way too long (~a characters)") + (list line-number (string-length line)) + #:location + (location (package-file package) + line-number + 0)))) + +(define %hanging-paren-rx + (make-regexp "^[[:blank:]]*[()]+[[:blank:]]*$")) + +(define (report-lone-parentheses package line line-number) + "Emit a warning if LINE contains hanging parentheses." + (when (regexp-exec %hanging-paren-rx line) + (make-warning package + (G_ "parentheses feel lonely, \ +move to the previous or next line") + (list line-number) + #:location + (location (package-file package) + line-number + 0)))) + +(define %formatting-reporters + ;; List of procedures that report formatting issues. These are not separate + ;; checkers because they would need to re-read the file. + (list report-tabulations + report-trailing-white-space + report-long-line + report-lone-parentheses)) + +(define* (report-formatting-issues package file starting-line + #:key (reporters %formatting-reporters)) + "Report white-space issues in FILE starting from STARTING-LINE, and report +them for PACKAGE." + (define (sexp-last-line port) + ;; Return the last line of the sexp read from PORT or an estimate thereof. + (define &failure (list 'failure)) + + (let ((start (ftell port)) + (start-line (port-line port)) + (sexp (catch 'read-error + (lambda () (read port)) + (const &failure)))) + (let ((line (port-line port))) + (seek port start SEEK_SET) + (set-port-line! port start-line) + (if (eq? sexp &failure) + (+ start-line 60) ;conservative estimate + line)))) + + (call-with-input-file file + (lambda (port) + (let loop ((line-number 1) + (last-line #f) + (warnings '())) + (let ((line (read-line port))) + (if (or (eof-object? line) + (and last-line (> line-number last-line))) + warnings + (if (and (= line-number starting-line) + (not last-line)) + (loop (+ 1 line-number) + (+ 1 (sexp-last-line port)) + warnings) + (loop (+ 1 line-number) + last-line + (append + warnings + (if (< line-number starting-line) + '() + (filter + lint-warning? + (map (lambda (report) + (report package line line-number)) + reporters)))))))))))) + +(define (check-formatting package) + "Check the formatting of the source code of PACKAGE." + (let ((location (package-location package))) + (if location + (and=> (search-path %load-path (location-file location)) + (lambda (file) + ;; Report issues starting from the line before the 'package' + ;; form, which usually contains the 'define' form. + (report-formatting-issues package file + (- (location-line location) 1)))) + '()))) + + +;;; +;;; List of checkers. +;;; + +(define %checkers + (list + (lint-checker + (name 'description) + (description "Validate package descriptions") + (check check-description-style)) + (lint-checker + (name 'gnu-description) + (description "Validate synopsis & description of GNU packages") + (check check-gnu-synopsis+description)) + (lint-checker + (name 'inputs-should-be-native) + (description "Identify inputs that should be native inputs") + (check check-inputs-should-be-native)) + (lint-checker + (name 'inputs-should-not-be-input) + (description "Identify inputs that shouldn't be inputs at all") + (check check-inputs-should-not-be-an-input-at-all)) + (lint-checker + (name 'patch-file-names) + (description "Validate file names and availability of patches") + (check check-patch-file-names)) + (lint-checker + (name 'home-page) + (description "Validate home-page URLs") + (check check-home-page)) + (lint-checker + (name 'license) + ;; TRANSLATORS: is the name of a data type and must not be + ;; translated. + (description "Make sure the 'license' field is a \ +or a list thereof") + (check check-license)) + (lint-checker + (name 'source) + (description "Validate source URLs") + (check check-source)) + (lint-checker + (name 'mirror-url) + (description "Suggest 'mirror://' URLs") + (check check-mirror-url)) + (lint-checker + (name 'github-url) + (description "Suggest GitHub URLs") + (check check-github-url)) + (lint-checker + (name 'source-file-name) + (description "Validate file names of sources") + (check check-source-file-name)) + (lint-checker + (name 'source-unstable-tarball) + (description "Check for autogenerated tarballs") + (check check-source-unstable-tarball)) + (lint-checker + (name 'derivation) + (description "Report failure to compile a package to a derivation") + (check check-derivation)) + (lint-checker + (name 'synopsis) + (description "Validate package synopses") + (check check-synopsis-style)) + (lint-checker + (name 'cve) + (description "Check the Common Vulnerabilities and Exposures\ + (CVE) database") + (check check-vulnerabilities)) + (lint-checker + (name 'refresh) + (description "Check the package for new upstream releases") + (check check-for-updates)) + (lint-checker + (name 'formatting) + (description "Look for formatting issues in the source") + (check check-formatting)))) diff --git a/guix/scripts/lint.scm b/guix/scripts/lint.scm index 4eb7e0e200..8a8ffc8f28 100644 --- a/guix/scripts/lint.scm +++ b/guix/scripts/lint.scm @@ -26,1223 +26,17 @@ ;;; along with GNU Guix. If not, see . (define-module (guix scripts lint) - #:use-module ((guix store) #:hide (close-connection)) - #:use-module (guix base32) - #:use-module (guix download) - #:use-module (guix ftp-client) - #:use-module (guix http-client) #:use-module (guix packages) - #:use-module (guix licenses) - #:use-module (guix records) - #:use-module (guix grafts) + #:use-module (guix lint) #:use-module (guix ui) - #:use-module (guix upstream) - #:use-module (guix utils) - #:use-module (guix memoization) #:use-module (guix scripts) - #:use-module (guix gnu-maintenance) - #:use-module (guix monads) - #:use-module (guix cve) #:use-module (gnu packages) #:use-module (ice-9 match) - #:use-module (ice-9 regex) #:use-module (ice-9 format) - #:use-module (web client) - #:use-module (web uri) - #:use-module ((guix build download) - #:select (maybe-expand-mirrors - (open-connection-for-uri - . guix:open-connection-for-uri) - close-connection)) - #:use-module (web request) - #:use-module (web response) #:use-module (srfi srfi-1) - #:use-module (srfi srfi-6) ;Unicode string ports - #:use-module (srfi srfi-9) - #:use-module (srfi srfi-11) - #:use-module (srfi srfi-26) - #:use-module (srfi srfi-34) - #:use-module (srfi srfi-35) #:use-module (srfi srfi-37) - #:use-module (ice-9 rdelim) #:export (guix-lint - check-description-style - check-inputs-should-be-native - check-inputs-should-not-be-an-input-at-all - check-patch-file-names - check-synopsis-style - check-derivation - check-home-page - check-source - check-source-file-name - check-source-unstable-tarball - check-mirror-url - check-github-url - check-license - check-vulnerabilities - check-for-updates - check-formatting - run-checkers - - lint-warning - lint-warning? - lint-warning-package - lint-warning-message - lint-warning-message-text - lint-warning-message-data - lint-warning-location - - %checkers - lint-checker - lint-checker? - lint-checker-name - lint-checker-description - lint-checker-check)) - - -;;; -;;; Warnings -;;; - -(define-record-type* - lint-warning make-lint-warning - lint-warning? - (package lint-warning-package) - (message-text lint-warning-message-text) - (message-data lint-warning-message-data - (default '())) - (location lint-warning-location - (default #f))) - -(define (lint-warning-message warning) - (apply format #f - (G_ (lint-warning-message-text warning)) - (lint-warning-message-data warning))) - -(define (package-file package) - (location-file - (package-location package))) - -(define* (%make-warning package message-text - #:optional (message-data '()) - #:key field location) - (make-lint-warning - package - message-text - message-data - (or location - (package-field-location package field) - (package-location package)))) - -(define-syntax make-warning - (syntax-rules (G_) - ((_ package (G_ message) rest ...) - (%make-warning package message rest ...)))) - -(define (emit-warnings warnings) - ;; Emit a warning about PACKAGE, printing the location of FIELD if it is - ;; given, the location of PACKAGE otherwise, the full name of PACKAGE and the - ;; provided MESSAGE. - (for-each - (match-lambda - (($ package message-text message-data loc) - (format (guix-warning-port) "~a: ~a@~a: ~a~%" - (location->string loc) - (package-name package) (package-version package) - (apply format #f (G_ message-text) message-data)))) - warnings)) - - -;;; -;;; Checkers -;;; - -(define-record-type* - lint-checker make-lint-checker - lint-checker? - ;; TODO: add a 'certainty' field that shows how confident we are in the - ;; checker. Then allow users to only run checkers that have a certain - ;; 'certainty' level. - (name lint-checker-name) - (description lint-checker-description) - (check lint-checker-check)) - -(define (list-checkers-and-exit) - ;; Print information about all available checkers and exit. - (format #t (G_ "Available checkers:~%")) - (for-each (lambda (checker) - (format #t "- ~a: ~a~%" - (lint-checker-name checker) - (G_ (lint-checker-description checker)))) - %checkers) - (exit 0)) - -(define (properly-starts-sentence? s) - (string-match "^[(\"'`[:upper:][:digit:]]" s)) - -(define (starts-with-abbreviation? s) - "Return #t if S starts with what looks like an abbreviation or acronym." - (string-match "^[A-Z][A-Z0-9]+\\>" s)) - -(define %quoted-identifier-rx - ;; A quoted identifier, like 'this'. - (make-regexp "['`][[:graph:]]+'")) - -(define (check-description-style package) - ;; Emit a warning if stylistic issues are found in the description of PACKAGE. - (define (check-not-empty description) - (if (string-null? description) - (list - (make-warning package - (G_ "description should not be empty") - #:field 'description)) - '())) - - (define (check-texinfo-markup description) - "Check that DESCRIPTION can be parsed as a Texinfo fragment. If the -markup is valid return a plain-text version of DESCRIPTION, otherwise #f." - (catch #t - (lambda () (texi->plain-text description)) - (lambda (keys . args) - (make-warning package - (G_ "Texinfo markup in description is invalid") - #:field 'description)))) - - (define (check-trademarks description) - "Check that DESCRIPTION does not contain '™' or '®' characters. See -http://www.gnu.org/prep/standards/html_node/Trademarks.html." - (match (string-index description (char-set #\™ #\®)) - ((and (? number?) index) - (list - (make-warning package - (G_ "description should not contain ~ -trademark sign '~a' at ~d") - (list (string-ref description index) index) - #:field 'description))) - (else '()))) - - (define (check-quotes description) - "Check whether DESCRIPTION contains single quotes and suggest @code." - (if (regexp-exec %quoted-identifier-rx description) - (list - (make-warning package - ;; TRANSLATORS: '@code' is Texinfo markup and must be kept - ;; as is. - (G_ "use @code or similar ornament instead of quotes") - #:field 'description)) - '())) - - (define (check-proper-start description) - (if (or (string-null? description) - (properly-starts-sentence? description) - (string-prefix-ci? (package-name package) description)) - '() - (list - (make-warning - package - (G_ "description should start with an upper-case letter or digit") - #:field 'description)))) - - (define (check-end-of-sentence-space description) - "Check that an end-of-sentence period is followed by two spaces." - (let ((infractions - (reverse (fold-matches - "\\. [A-Z]" description '() - (lambda (m r) - ;; Filter out matches of common abbreviations. - (if (find (lambda (s) - (string-suffix-ci? s (match:prefix m))) - '("i.e" "e.g" "a.k.a" "resp")) - r (cons (match:start m) r))))))) - (if (null? infractions) - '() - (list - (make-warning package - (G_ "sentences in description should be followed ~ -by two spaces; possible infraction~p at ~{~a~^, ~}") - (list (length infractions) - infractions) - #:field 'description))))) - - (let ((description (package-description package))) - (if (string? description) - (append - (check-not-empty description) - (check-quotes description) - (check-trademarks description) - ;; Use raw description for this because Texinfo rendering - ;; automatically fixes end of sentence space. - (check-end-of-sentence-space description) - (match (check-texinfo-markup description) - ((and warning (? lint-warning?)) (list warning)) - (plain-description - (check-proper-start plain-description)))) - (list - (make-warning package - (G_ "invalid description: ~s") - (list description) - #:field 'description))))) - -(define (package-input-intersection inputs-to-check input-names) - "Return the intersection between INPUTS-TO-CHECK, the list of input tuples -of a package, and INPUT-NAMES, a list of package specifications such as -\"glib:bin\"." - (match inputs-to-check - (((labels packages . outputs) ...) - (filter-map (lambda (package output) - (and (package? package) - (let ((input (string-append - (package-name package) - (if (> (length output) 0) - (string-append ":" (car output)) - "")))) - (and (member input input-names) - input)))) - packages outputs)))) - -(define (check-inputs-should-be-native package) - ;; Emit a warning if some inputs of PACKAGE are likely to belong to its - ;; native inputs. - (let ((inputs (package-inputs package)) - (input-names - '("pkg-config" - "cmake" - "extra-cmake-modules" - "glib:bin" - "intltool" - "itstool" - "qttools" - "python-coverage" "python2-coverage" - "python-cython" "python2-cython" - "python-docutils" "python2-docutils" - "python-mock" "python2-mock" - "python-nose" "python2-nose" - "python-pbr" "python2-pbr" - "python-pytest" "python2-pytest" - "python-pytest-cov" "python2-pytest-cov" - "python-setuptools-scm" "python2-setuptools-scm" - "python-sphinx" "python2-sphinx"))) - (map (lambda (input) - (make-warning - package - (G_ "'~a' should probably be a native input") - (list input) - #:field 'inputs)) - (package-input-intersection inputs input-names)))) - -(define (check-inputs-should-not-be-an-input-at-all package) - ;; Emit a warning if some inputs of PACKAGE are likely to should not be - ;; an input at all. - (let ((input-names '("python-setuptools" - "python2-setuptools" - "python-pip" - "python2-pip"))) - (map (lambda (input) - (make-warning - package - (G_ "'~a' should probably not be an input at all") - (list input) - #:field 'inputs)) - (package-input-intersection (package-direct-inputs package) - input-names)))) - -(define (package-name-regexp package) - "Return a regexp that matches PACKAGE's name as a word at the beginning of a -line." - (make-regexp (string-append "^" (regexp-quote (package-name package)) - "\\>") - regexp/icase)) - -(define (check-synopsis-style package) - ;; Emit a warning if stylistic issues are found in the synopsis of PACKAGE. - (define (check-final-period synopsis) - ;; Synopsis should not end with a period, except for some special cases. - (if (and (string-suffix? "." synopsis) - (not (string-suffix? "etc." synopsis))) - (list - (make-warning package - (G_ "no period allowed at the end of the synopsis") - #:field 'synopsis)) - '())) - - (define check-start-article - ;; Skip this check for GNU packages, as suggested by Karl Berry's reply to - ;; . - (if (false-if-exception (gnu-package? package)) - (const '()) - (lambda (synopsis) - (if (or (string-prefix-ci? "A " synopsis) - (string-prefix-ci? "An " synopsis)) - (list - (make-warning package - (G_ "no article allowed at the beginning of \ -the synopsis") - #:field 'synopsis)) - '())))) - - (define (check-synopsis-length synopsis) - (if (>= (string-length synopsis) 80) - (list - (make-warning package - (G_ "synopsis should be less than 80 characters long") - #:field 'synopsis)) - '())) - - (define (check-proper-start synopsis) - (if (properly-starts-sentence? synopsis) - '() - (list - (make-warning package - (G_ "synopsis should start with an upper-case letter or digit") - #:field 'synopsis)))) - - (define (check-start-with-package-name synopsis) - (if (and (regexp-exec (package-name-regexp package) synopsis) - (not (starts-with-abbreviation? synopsis))) - (list - (make-warning package - (G_ "synopsis should not start with the package name") - #:field 'synopsis)) - '())) - - (define (check-texinfo-markup synopsis) - "Check that SYNOPSIS can be parsed as a Texinfo fragment. If the -markup is valid return a plain-text version of SYNOPSIS, otherwise #f." - (catch #t - (lambda () - (texi->plain-text synopsis) - '()) - (lambda (keys . args) - (list - (make-warning package - (G_ "Texinfo markup in synopsis is invalid") - #:field 'synopsis))))) - - (define checks - (list check-proper-start - check-final-period - check-start-article - check-start-with-package-name - check-synopsis-length - check-texinfo-markup)) - - (match (package-synopsis package) - ("" - (list - (make-warning package - (G_ "synopsis should not be empty") - #:field 'synopsis))) - ((? string? synopsis) - (append-map - (lambda (proc) - (proc synopsis)) - checks)) - (invalid - (list - (make-warning package - (G_ "invalid synopsis: ~s") - (list invalid) - #:field 'synopsis))))) - -(define* (probe-uri uri #:key timeout) - "Probe URI, a URI object, and return two values: a symbol denoting the -probing status, such as 'http-response' when we managed to get an HTTP -response from URI, and additional details, such as the actual HTTP response. - -TIMEOUT is the maximum number of seconds (possibly an inexact number) to wait -for connections to complete; when TIMEOUT is #f, wait as long as needed." - (define headers - '((User-Agent . "GNU Guile") - (Accept . "*/*"))) - - (let loop ((uri uri) - (visited '())) - (match (uri-scheme uri) - ((or 'http 'https) - (catch #t - (lambda () - (let ((port (guix:open-connection-for-uri - uri #:timeout timeout)) - (request (build-request uri #:headers headers))) - (define response - (dynamic-wind - (const #f) - (lambda () - (write-request request port) - (force-output port) - (read-response port)) - (lambda () - (close-connection port)))) - - (case (response-code response) - ((302 ; found (redirection) - 303 ; see other - 307 ; temporary redirection - 308) ; permanent redirection - (let ((location (response-location response))) - (if (or (not location) (member location visited)) - (values 'http-response response) - (loop location (cons location visited))))) ;follow the redirect - ((301) ; moved permanently - (let ((location (response-location response))) - ;; Return RESPONSE, unless the final response as we follow - ;; redirects is not 200. - (if location - (let-values (((status response2) - (loop location (cons location visited)))) - (case status - ((http-response) - (values 'http-response - (if (= 200 (response-code response2)) - response - response2))) - (else - (values status response2)))) - (values 'http-response response)))) ;invalid redirect - (else - (values 'http-response response))))) - (lambda (key . args) - (case key - ((bad-header bad-header-component) - ;; This can happen if the server returns an invalid HTTP header, - ;; as is the case with the 'Date' header at sqlite.org. - (values 'invalid-http-response #f)) - ((getaddrinfo-error system-error - gnutls-error tls-certificate-error) - (values key args)) - (else - (apply throw key args)))))) - ('ftp - (catch #t - (lambda () - (let ((conn (ftp-open (uri-host uri) #:timeout timeout))) - (define response - (dynamic-wind - (const #f) - (lambda () - (ftp-chdir conn (dirname (uri-path uri))) - (ftp-size conn (basename (uri-path uri)))) - (lambda () - (ftp-close conn)))) - (values 'ftp-response '(ok)))) - (lambda (key . args) - (case key - ((ftp-error) - (values 'ftp-response `(error ,@args))) - ((getaddrinfo-error system-error gnutls-error) - (values key args)) - (else - (apply throw key args)))))) - (_ - (values 'unknown-protocol #f))))) - -(define (tls-certificate-error-string args) - "Return a string explaining the 'tls-certificate-error' arguments ARGS." - (call-with-output-string - (lambda (port) - (print-exception port #f - 'tls-certificate-error args)))) - -(define (validate-uri uri package field) - "Return #t if the given URI can be reached, otherwise return a warning for -PACKAGE mentionning the FIELD." - (let-values (((status argument) - (probe-uri uri #:timeout 3))) ;wait at most 3 seconds - (case status - ((http-response) - (cond ((= 200 (response-code argument)) - (match (response-content-length argument) - ((? number? length) - ;; As of July 2016, SourceForge returns 200 (instead of 404) - ;; with a small HTML page upon failure. Attempt to detect - ;; such malicious behavior. - (or (> length 1000) - (make-warning package - (G_ "URI ~a returned \ -suspiciously small file (~a bytes)") - (list (uri->string uri) - length) - #:field field))) - (_ #t))) - ((= 301 (response-code argument)) - (if (response-location argument) - (make-warning package - (G_ "permanent redirect from ~a to ~a") - (list (uri->string uri) - (uri->string - (response-location argument))) - #:field field) - (make-warning package - (G_ "invalid permanent redirect \ -from ~a") - (list (uri->string uri)) - #:field field))) - (else - (make-warning package - (G_ "URI ~a not reachable: ~a (~s)") - (list (uri->string uri) - (response-code argument) - (response-reason-phrase argument)) - #:field field)))) - ((ftp-response) - (match argument - (('ok) #t) - (('error port command code message) - (make-warning package - (G_ "URI ~a not reachable: ~a (~s)") - (list (uri->string uri) - code (string-trim-both message)) - #:field field)))) - ((getaddrinfo-error) - (make-warning package - (G_ "URI ~a domain not found: ~a") - (list (uri->string uri) - (gai-strerror (car argument))) - #:field field)) - ((system-error) - (make-warning package - (G_ "URI ~a unreachable: ~a") - (list (uri->string uri) - (strerror - (system-error-errno - (cons status argument)))) - #:field field)) - ((tls-certificate-error) - (make-warning package - (G_ "TLS certificate error: ~a") - (list (tls-certificate-error-string argument)) - #:field field)) - ((invalid-http-response gnutls-error) - ;; Probably a misbehaving server; ignore. - #f) - ((unknown-protocol) ;nothing we can do - #f) - (else - (error "internal linter error" status))))) - -(define (check-home-page package) - "Emit a warning if PACKAGE has an invalid 'home-page' field, or if that -'home-page' is not reachable." - (let ((uri (and=> (package-home-page package) string->uri))) - (cond - ((uri? uri) - (match (validate-uri uri package 'home-page) - ((and (? lint-warning? warning) warning) - (list warning)) - (_ '()))) - ((not (package-home-page package)) - (if (or (string-contains (package-name package) "bootstrap") - (string=? (package-name package) "ld-wrapper")) - '() - (list - (make-warning package - (G_ "invalid value for home page") - #:field 'home-page)))) - (else - (list - (make-warning package - (G_ "invalid home page URL: ~s") - (list (package-home-page package)) - #:field 'home-page)))))) - -(define %distro-directory - (mlambda () - (dirname (search-path %load-path "gnu.scm")))) - -(define (check-patch-file-names package) - "Emit a warning if the patches requires by PACKAGE are badly named or if the -patch could not be found." - (guard (c ((message-condition? c) ;raised by 'search-patch' - (list - ;; Use %make-warning, as condition-mesasge is already - ;; translated. - (%make-warning package (condition-message c) - #:field 'patch-file-names)))) - (define patches - (or (and=> (package-source package) origin-patches) - '())) - - (append - (if (every (match-lambda ;patch starts with package name? - ((? string? patch) - (and=> (string-contains (basename patch) - (package-name package)) - zero?)) - (_ #f)) ;must be an or something like that. - patches) - '() - (list - (make-warning - package - (G_ "file names of patches should start with the package name") - #:field 'patch-file-names))) - - ;; Check whether we're reaching tar's maximum file name length. - (let ((prefix (string-length (%distro-directory))) - (margin (string-length "guix-0.13.0-10-123456789/")) - (max 99)) - (filter-map (match-lambda - ((? string? patch) - (if (> (+ margin (if (string-prefix? (%distro-directory) - patch) - (- (string-length patch) prefix) - (string-length patch))) - max) - (make-warning - package - (G_ "~a: file name is too long") - (list (basename patch)) - #:field 'patch-file-names) - #f)) - (_ #f)) - patches))))) - -(define (escape-quotes str) - "Replace any quote character in STR by an escaped quote character." - (list->string - (string-fold-right (lambda (chr result) - (match chr - (#\" (cons* #\\ #\"result)) - (_ (cons chr result)))) - '() - str))) - -(define official-gnu-packages* - (mlambda () - "A memoizing version of 'official-gnu-packages' that returns the empty -list when something goes wrong, such as a networking issue." - (let ((gnus (false-if-exception (official-gnu-packages)))) - (or gnus '())))) - -(define (check-gnu-synopsis+description package) - "Make sure that, if PACKAGE is a GNU package, it uses the synopsis and -descriptions maintained upstream." - (match (find (lambda (descriptor) - (string=? (gnu-package-name descriptor) - (package-name package))) - (official-gnu-packages*)) - (#f ;not a GNU package, so nothing to do - '()) - (descriptor ;a genuine GNU package - (append - (let ((upstream (gnu-package-doc-summary descriptor)) - (downstream (package-synopsis package))) - (if (and upstream - (or (not (string? downstream)) - (not (string=? upstream downstream)))) - (list - (make-warning package - (G_ "proposed synopsis: ~s~%") - (list upstream) - #:field 'synopsis)) - '())) - - (let ((upstream (gnu-package-doc-description descriptor)) - (downstream (package-description package))) - (if (and upstream - (or (not (string? downstream)) - (not (string=? (fill-paragraph upstream 100) - (fill-paragraph downstream 100))))) - (list - (make-warning - package - (G_ "proposed description:~% \"~a\"~%") - (list (fill-paragraph (escape-quotes upstream) 77 7)) - #:field 'description)) - '())))))) - -(define (origin-uris origin) - "Return the list of URIs (strings) for ORIGIN." - (match (origin-uri origin) - ((? string? uri) - (list uri)) - ((uris ...) - uris))) - -(define (check-source package) - "Emit a warning if PACKAGE has an invalid 'source' field, or if that -'source' is not reachable." - (define (warnings-for-uris uris) - (filter lint-warning? - (map - (lambda (uri) - (validate-uri uri package 'source)) - (append-map (cut maybe-expand-mirrors <> %mirrors) - uris)))) - - (let ((origin (package-source package))) - (if (and origin - (eqv? (origin-method origin) url-fetch)) - (let* ((uris (map string->uri (origin-uris origin))) - (warnings (warnings-for-uris uris))) - - ;; Just make sure that at least one of the URIs is valid. - (if (eq? (length uris) (length warnings)) - ;; When everything fails, report all of WARNINGS, otherwise don't - ;; report anything. - ;; - ;; XXX: Ideally we'd still allow warnings to be raised if *some* - ;; URIs are unreachable, but distinguish that from the error case - ;; where *all* the URIs are unreachable. - (cons* - (make-warning package - (G_ "all the source URIs are unreachable:") - #:field 'source) - warnings) - '())) - '()))) - -(define (check-source-file-name package) - "Emit a warning if PACKAGE's origin has no meaningful file name." - (define (origin-file-name-valid? origin) - ;; Return #f if the source file name contains only a version or is #f; - ;; indicates that the origin needs a 'file-name' field. - (let ((file-name (origin-actual-file-name origin)) - (version (package-version package))) - (and file-name - ;; Common in many projects is for the filename to start - ;; with a "v" followed by the version, - ;; e.g. "v3.2.0.tar.gz". - (not (string-match (string-append "^v?" version) file-name))))) - - (let ((origin (package-source package))) - (if (or (not origin) (origin-file-name-valid? origin)) - '() - (list - (make-warning package - (G_ "the source file name should contain the package name") - #:field 'source))))) - -(define (check-source-unstable-tarball package) - "Emit a warning if PACKAGE's source is an autogenerated tarball." - (define (check-source-uri uri) - (if (and (string=? (uri-host (string->uri uri)) "github.com") - (match (split-and-decode-uri-path - (uri-path (string->uri uri))) - ((_ _ "archive" _ ...) #t) - (_ #f))) - (make-warning package - (G_ "the source URI should not be an autogenerated tarball") - #:field 'source) - #f)) - - (let ((origin (package-source package))) - (if (and (origin? origin) - (eqv? (origin-method origin) url-fetch)) - (filter-map check-source-uri - (origin-uris origin)) - '()))) - -(define (check-mirror-url package) - "Check whether PACKAGE uses source URLs that should be 'mirror://'." - (define (check-mirror-uri uri) ;XXX: could be optimized - (let loop ((mirrors %mirrors)) - (match mirrors - (() - #f) - (((mirror-id mirror-urls ...) rest ...) - (match (find (cut string-prefix? <> uri) mirror-urls) - (#f - (loop rest)) - (prefix - (make-warning package - (G_ "URL should be \ -'mirror://~a/~a'") - (list mirror-id - (string-drop uri (string-length prefix))) - #:field 'source))))))) - - (let ((origin (package-source package))) - (if (and (origin? origin) - (eqv? (origin-method origin) url-fetch)) - (let ((uris (origin-uris origin))) - (filter-map check-mirror-uri uris)) - '()))) - -(define* (check-github-url package #:key (timeout 3)) - "Check whether PACKAGE uses source URLs that redirect to GitHub." - (define (follow-redirect url) - (let* ((uri (string->uri url)) - (port (guix:open-connection-for-uri uri #:timeout timeout)) - (response (http-head uri #:port port))) - (close-port port) - (case (response-code response) - ((301 302) - (uri->string (assoc-ref (response-headers response) 'location))) - (else #f)))) - - (define (follow-redirects-to-github uri) - (cond - ((string-prefix? "https://github.com/" uri) uri) - ((string-prefix? "http" uri) - (and=> (follow-redirect uri) follow-redirects-to-github)) - ;; Do not attempt to follow redirects on URIs other than http and https - ;; (such as mirror, file) - (else #f))) - - (let ((origin (package-source package))) - (if (and (origin? origin) - (eqv? (origin-method origin) url-fetch)) - (filter-map - (lambda (uri) - (and=> (follow-redirects-to-github uri) - (lambda (github-uri) - (if (string=? github-uri uri) - #f - (make-warning - package - (G_ "URL should be '~a'") - (list github-uri) - #:field 'source))))) - (origin-uris origin)) - '()))) - -(define (check-derivation package) - "Emit a warning if we fail to compile PACKAGE to a derivation." - (define (try system) - (catch #t - (lambda () - (guard (c ((store-protocol-error? c) - (make-warning package - (G_ "failed to create ~a derivation: ~a") - (list system - (store-protocol-error-message c)))) - ((message-condition? c) - (make-warning package - (G_ "failed to create ~a derivation: ~a") - (list system - (condition-message c))))) - (with-store store - ;; Disable grafts since it can entail rebuilds. - (parameterize ((%graft? #f)) - (package-derivation store package system #:graft? #f) - - ;; If there's a replacement, make sure we can compute its - ;; derivation. - (match (package-replacement package) - (#f #t) - (replacement - (package-derivation store replacement system - #:graft? #f))))))) - (lambda args - (make-warning package - (G_ "failed to create ~a derivation: ~s") - (list system args))))) - - (filter lint-warning? - (map try (package-supported-systems package)))) - -(define (check-license package) - "Warn about type errors of the 'license' field of PACKAGE." - (match (package-license package) - ((or (? license?) - ((? license?) ...)) - '()) - (x - (list - (make-warning package (G_ "invalid license field") - #:field 'license))))) - -(define (call-with-networking-fail-safe message error-value proc) - "Call PROC catching any network-related errors. Upon a networking error, -display a message including MESSAGE and return ERROR-VALUE." - (guard (c ((http-get-error? c) - (warning (G_ "~a: HTTP GET error for ~a: ~a (~s)~%") - message - (uri->string (http-get-error-uri c)) - (http-get-error-code c) - (http-get-error-reason c)) - error-value)) - (catch #t - proc - (match-lambda* - (('getaddrinfo-error errcode) - (warning (G_ "~a: host lookup failure: ~a~%") - message - (gai-strerror errcode)) - error-value) - (('tls-certificate-error args ...) - (warning (G_ "~a: TLS certificate error: ~a") - message - (tls-certificate-error-string args)) - error-value) - (args - (apply throw args)))))) - -(define-syntax-rule (with-networking-fail-safe message error-value exp ...) - (call-with-networking-fail-safe message error-value - (lambda () exp ...))) - -(define (current-vulnerabilities*) - "Like 'current-vulnerabilities', but return the empty list upon networking -or HTTP errors. This allows network-less operation and makes problems with -the NIST server non-fatal." - (with-networking-fail-safe (G_ "while retrieving CVE vulnerabilities") - '() - (current-vulnerabilities))) - -(define package-vulnerabilities - (let ((lookup (delay (vulnerabilities->lookup-proc - (current-vulnerabilities*))))) - (lambda (package) - "Return a list of vulnerabilities affecting PACKAGE." - ;; First we retrieve the Common Platform Enumeration (CPE) name and - ;; version for PACKAGE, then we can pass them to LOOKUP. - (let ((name (or (assoc-ref (package-properties package) - 'cpe-name) - (package-name package))) - (version (or (assoc-ref (package-properties package) - 'cpe-version) - (package-version package)))) - ((force lookup) name version))))) - -(define (check-vulnerabilities package) - "Check for known vulnerabilities for PACKAGE." - (let ((package (or (package-replacement package) package))) - (match (package-vulnerabilities package) - (() - '()) - ((vulnerabilities ...) - (let* ((patched (package-patched-vulnerabilities package)) - (known-safe (or (assq-ref (package-properties package) - 'lint-hidden-cve) - '())) - (unpatched (remove (lambda (vuln) - (let ((id (vulnerability-id vuln))) - (or (member id patched) - (member id known-safe)))) - vulnerabilities))) - (if (null? unpatched) - '() - (list - (make-warning - package - (G_ "probably vulnerable to ~a") - (list (string-join (map vulnerability-id unpatched) - ", ")))))))))) - -(define (check-for-updates package) - "Check if there is an update available for PACKAGE." - (match (with-networking-fail-safe - (G_ "while retrieving upstream info for '~a'") - (list (package-name package)) - #f - (package-latest-release* package (force %updaters))) - ((? upstream-source? source) - (if (version>? (upstream-source-version source) - (package-version package)) - (list - (make-warning package - (G_ "can be upgraded to ~a") - (list (upstream-source-version source)) - #:field 'version)) - '())) - (#f '()))) ; cannot find newer upstream release - - -;;; -;;; Source code formatting. -;;; - -(define (report-tabulations package line line-number) - "Warn about tabulations found in LINE." - (match (string-index line #\tab) - (#f #t) - (index - (make-warning package - (G_ "tabulation on line ~a, column ~a") - (list line-number index) - #:location - (location (package-file package) - line-number - index))))) - -(define (report-trailing-white-space package line line-number) - "Warn about trailing white space in LINE." - (unless (or (string=? line (string-trim-right line)) - (string=? line (string #\page))) - (make-warning package - (G_ "trailing white space on line ~a") - (list line-number) - #:location - (location (package-file package) - line-number - 0)))) - -(define (report-long-line package line line-number) - "Emit a warning if LINE is too long." - ;; Note: We don't warn at 80 characters because sometimes hashes and URLs - ;; make it hard to fit within that limit and we want to avoid making too - ;; much noise. - (when (> (string-length line) 90) - (make-warning package - (G_ "line ~a is way too long (~a characters)") - (list line-number (string-length line)) - #:location - (location (package-file package) - line-number - 0)))) - -(define %hanging-paren-rx - (make-regexp "^[[:blank:]]*[()]+[[:blank:]]*$")) - -(define (report-lone-parentheses package line line-number) - "Emit a warning if LINE contains hanging parentheses." - (when (regexp-exec %hanging-paren-rx line) - (make-warning package - (G_ "parentheses feel lonely, \ -move to the previous or next line") - (list line-number) - #:location - (location (package-file package) - line-number - 0)))) - -(define %formatting-reporters - ;; List of procedures that report formatting issues. These are not separate - ;; checkers because they would need to re-read the file. - (list report-tabulations - report-trailing-white-space - report-long-line - report-lone-parentheses)) - -(define* (report-formatting-issues package file starting-line - #:key (reporters %formatting-reporters)) - "Report white-space issues in FILE starting from STARTING-LINE, and report -them for PACKAGE." - (define (sexp-last-line port) - ;; Return the last line of the sexp read from PORT or an estimate thereof. - (define &failure (list 'failure)) - - (let ((start (ftell port)) - (start-line (port-line port)) - (sexp (catch 'read-error - (lambda () (read port)) - (const &failure)))) - (let ((line (port-line port))) - (seek port start SEEK_SET) - (set-port-line! port start-line) - (if (eq? sexp &failure) - (+ start-line 60) ;conservative estimate - line)))) - - (call-with-input-file file - (lambda (port) - (let loop ((line-number 1) - (last-line #f) - (warnings '())) - (let ((line (read-line port))) - (if (or (eof-object? line) - (and last-line (> line-number last-line))) - warnings - (if (and (= line-number starting-line) - (not last-line)) - (loop (+ 1 line-number) - (+ 1 (sexp-last-line port)) - warnings) - (loop (+ 1 line-number) - last-line - (append - warnings - (if (< line-number starting-line) - '() - (filter - lint-warning? - (map (lambda (report) - (report package line line-number)) - reporters)))))))))))) - -(define (check-formatting package) - "Check the formatting of the source code of PACKAGE." - (let ((location (package-location package))) - (if location - (and=> (search-path %load-path (location-file location)) - (lambda (file) - ;; Report issues starting from the line before the 'package' - ;; form, which usually contains the 'define' form. - (report-formatting-issues package file - (- (location-line location) 1)))) - '()))) - - -;;; -;;; List of checkers. -;;; - -(define %checkers - (list - (lint-checker - (name 'description) - (description "Validate package descriptions") - (check check-description-style)) - (lint-checker - (name 'gnu-description) - (description "Validate synopsis & description of GNU packages") - (check check-gnu-synopsis+description)) - (lint-checker - (name 'inputs-should-be-native) - (description "Identify inputs that should be native inputs") - (check check-inputs-should-be-native)) - (lint-checker - (name 'inputs-should-not-be-input) - (description "Identify inputs that shouldn't be inputs at all") - (check check-inputs-should-not-be-an-input-at-all)) - (lint-checker - (name 'patch-file-names) - (description "Validate file names and availability of patches") - (check check-patch-file-names)) - (lint-checker - (name 'home-page) - (description "Validate home-page URLs") - (check check-home-page)) - (lint-checker - (name 'license) - ;; TRANSLATORS: is the name of a data type and must not be - ;; translated. - (description "Make sure the 'license' field is a \ -or a list thereof") - (check check-license)) - (lint-checker - (name 'source) - (description "Validate source URLs") - (check check-source)) - (lint-checker - (name 'mirror-url) - (description "Suggest 'mirror://' URLs") - (check check-mirror-url)) - (lint-checker - (name 'github-url) - (description "Suggest GitHub URLs") - (check check-github-url)) - (lint-checker - (name 'source-file-name) - (description "Validate file names of sources") - (check check-source-file-name)) - (lint-checker - (name 'source-unstable-tarball) - (description "Check for autogenerated tarballs") - (check check-source-unstable-tarball)) - (lint-checker - (name 'derivation) - (description "Report failure to compile a package to a derivation") - (check check-derivation)) - (lint-checker - (name 'synopsis) - (description "Validate package synopses") - (check check-synopsis-style)) - (lint-checker - (name 'cve) - (description "Check the Common Vulnerabilities and Exposures\ - (CVE) database") - (check check-vulnerabilities)) - (lint-checker - (name 'refresh) - (description "Check the package for new upstream releases") - (check check-for-updates)) - (lint-checker - (name 'formatting) - (description "Look for formatting issues in the source") - (check check-formatting)))) + run-checkers)) (define* (run-checkers package #:optional (checkers %checkers)) "Run the given CHECKERS on PACKAGE." @@ -1260,6 +54,16 @@ or a list thereof") (format (current-error-port) "\x1b[K") (force-output (current-error-port))))) +(define (list-checkers-and-exit) + ;; Print information about all available checkers and exit. + (format #t (G_ "Available checkers:~%")) + (for-each (lambda (checker) + (format #t "- ~a: ~a~%" + (lint-checker-name checker) + (G_ (lint-checker-description checker)))) + %checkers) + (exit 0)) + ;;; ;;; Command-line options. diff --git a/tests/lint.scm b/tests/lint.scm index d8b2ca54cd..59be061a99 100644 --- a/tests/lint.scm +++ b/tests/lint.scm @@ -33,7 +33,7 @@ #:use-module (guix git-download) #:use-module (guix build-system gnu) #:use-module (guix packages) - #:use-module (guix scripts lint) + #:use-module (guix lint) #:use-module (guix ui) #:use-module (gnu packages) #:use-module (gnu packages glib) -- 2.22.0 From debbugs-submit-bounces@debbugs.gnu.org Tue Jul 02 16:15:28 2019 Received: (at 35790) by debbugs.gnu.org; 2 Jul 2019 20:15:28 +0000 Received: from localhost ([127.0.0.1]:48016 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1hiPBW-0007ib-Lc for submit@debbugs.gnu.org; Tue, 02 Jul 2019 16:15:26 -0400 Received: from mira.cbaines.net ([212.71.252.8]:36566) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1hiPBU-0007iS-11 for 35790@debbugs.gnu.org; Tue, 02 Jul 2019 16:15:24 -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 E9D1017128; Tue, 2 Jul 2019 21:15:18 +0100 (BST) Received: from capella (localhost [127.0.0.1]) by localhost (OpenSMTPD) with ESMTP id 9ea58050; Tue, 2 Jul 2019 20:15:18 +0000 (UTC) References: <20190518093206.22069-1-mail@cbaines.net> <878suz27ke.fsf@gnu.org> <87ef4dxgvl.fsf@cbaines.net> <87pnnpj15u.fsf@gnu.org> <87h88pu1cc.fsf@cbaines.net> <875zp0lbmx.fsf@gnu.org> <875zovmqey.fsf@cbaines.net> <87pnn3cr7f.fsf@gnu.org> <87y31kli4q.fsf@cbaines.net> <87a7dyoryh.fsf@gnu.org> User-agent: mu4e 1.2.0; emacs 26.2 From: Christopher Baines To: Ludovic =?utf-8?Q?Court=C3=A8s?= Subject: Re: [bug#35790] [PATCH] scripts: lint: Handle warnings with a record type. In-reply-to: <87a7dyoryh.fsf@gnu.org> Date: Tue, 02 Jul 2019 21:15:16 +0100 Message-ID: <87v9wkkxbf.fsf@cbaines.net> MIME-Version: 1.0 Content-Type: multipart/signed; boundary="=-=-="; micalg=pgp-sha512; protocol="application/pgp-signature" X-Spam-Score: -0.0 (/) X-Debbugs-Envelope-To: 35790 Cc: 35790@debbugs.gnu.org X-BeenThere: debbugs-submit@debbugs.gnu.org X-Mailman-Version: 2.1.18 Precedence: list List-Id: List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: debbugs-submit-bounces@debbugs.gnu.org Sender: "Debbugs-submit" X-Spam-Score: -1.0 (-) --=-=-= Content-Type: text/plain; charset=utf-8 Content-Transfer-Encoding: quoted-printable Ludovic Court=C3=A8s writes: > Hi! > > Christopher Baines skribis: > >> Ludovic Court=C3=A8s writes: >> >>> Hi Chris, >>> >>> Christopher Baines skribis: >>> >>>> Thanks, so if I set the bindtextdomain, things do indeed work >>>> better. So, regarding these two patches, I've got the following things >>>> on my mind... >>>> >>>> - As they change so many things, I'm not sure what to add for the GNU >>>> changelog at the end of the commit message? >>> >>> I think you should try to write the commit log the usual way, by >>> listing every changed entity. It=E2=80=99s a bit tedious, but it=E2=80= =99s also a good >>> way to review everything (and Magit makes it relatively easy.) >> >> Ok, I've now made an initial attempt at this, and sent some updated >> patches. > > Perfect, thanks for taking the time to do it. Great :) > Time to push! :-) Well... I'm happy to push these patches to master, but I've got some more related changes in mind. It might be good to merge these all together, to avoid churning up the codebase more than necessary. I've sent another couple of patches, the first to move most of the functionality from (guix scripts lint) to a new (guix lint) module. The second patch then splits the checkers in to two groups, based on whether they attempt to access the network. This is still moving towards being able to easily lint all the packages and store this information in the Guix Data Serivce. --=-=-= Content-Type: application/pgp-signature; name="signature.asc" -----BEGIN PGP SIGNATURE----- iQKTBAEBCgB9FiEEPonu50WOcg2XVOCyXiijOwuE9XcFAl0bu1RfFIAAAAAALgAo aXNzdWVyLWZwckBub3RhdGlvbnMub3BlbnBncC5maWZ0aGhvcnNlbWFuLm5ldDNF ODlFRUU3NDU4RTcyMEQ5NzU0RTBCMjVFMjhBMzNCMEI4NEY1NzcACgkQXiijOwuE 9XeqyRAAk/eqbAMa9gZviwrL7niIvHV8BrTSIIMNr0z0fPZTFXPHCso45DTZ5GPx FJ3uGS1l73QmYT76LbKszCE5q1BRLuUeQKVIK4wAUQuykq5pEP38OHMwFC4YDrcB 36J+kkD0UoPLq67QyK99QYj+WJxDZv0AV5UueIOFQGylMbpM+2uaK6lNcxeTA7Pu cS0ql6l5k9/QQokfkqIGFK//OA4oZvZhjTwFfa6CNixvFjYLK2R7Ey1DvOCY00Rm fp9M87MrNv1l9AV9++9A2cGMKrrczUqku98N/MOwtI+LtRUuAdLjwDfZvz9WaKp2 FW9lFAewoM80M7HVgFs/YYoJS28kSOFHyzfK4B+PyPEHznlwwN6usN6vqWYo9yLj 516Fqnh9u+91Irq3DjANKYAfS2lJ92sI3/Heix9BsLbQBWuzZbqrIGl7/bLcckdJ Yh+3+fkJlja2aQUA2SohHHsZq4vtGIwKlVL2kcYOSWUecTNCFtl4AzPXZpvEFBh1 HziabV/nfkIblbuIhifHJh983XhVf7Jor5KzP8rc4/x7qtbmVXq2BmUx6SAPJa+G H9A9b63PVfU8vP5wC717xaMaAy4hz9IvwA4H/01rMNl8LZWg9hEUO7zbbxVl6Pf1 SemtwEkOysgQKnJ6z11+rGG4YkA6OzIGiFeu8PLI3mOOz5lu8t4= =n67x -----END PGP SIGNATURE----- --=-=-=-- From debbugs-submit-bounces@debbugs.gnu.org Fri Jul 12 10:37:03 2019 Received: (at 35790) by debbugs.gnu.org; 12 Jul 2019 14:37:03 +0000 Received: from localhost ([127.0.0.1]:40483 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1hlwfR-00080P-VM for submit@debbugs.gnu.org; Fri, 12 Jul 2019 10:37:03 -0400 Received: from eggs.gnu.org ([209.51.188.92]:33964) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1hlwfO-000806-8v for 35790@debbugs.gnu.org; Fri, 12 Jul 2019 10:36:55 -0400 Received: from fencepost.gnu.org ([2001:470:142:3::e]:41398) by eggs.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1hlwfH-0004oN-88; Fri, 12 Jul 2019 10:36:47 -0400 Received: from [2a01:e0a:1d:7270:af76:b9b:ca24:c465] (port=51416 helo=ribbon) by fencepost.gnu.org with esmtpsa (TLS1.2:RSA_AES_256_CBC_SHA1:256) (Exim 4.82) (envelope-from ) id 1hlwfG-0007kF-6S; Fri, 12 Jul 2019 10:36:47 -0400 From: =?utf-8?Q?Ludovic_Court=C3=A8s?= To: Christopher Baines Subject: Re: [bug#35790] [PATCH 1/2] lint: Move the linting code to a different module. References: <87a7dyoryh.fsf@gnu.org> <20190702192542.16179-1-mail@cbaines.net> Date: Fri, 12 Jul 2019 16:36:44 +0200 In-Reply-To: <20190702192542.16179-1-mail@cbaines.net> (Christopher Baines's message of "Tue, 2 Jul 2019 20:25:41 +0100") Message-ID: <87pnmfgw03.fsf@gnu.org> User-Agent: Gnus/5.13 (Gnus v5.13) Emacs/26.2 (gnu/linux) MIME-Version: 1.0 Content-Type: text/plain; charset=utf-8 Content-Transfer-Encoding: quoted-printable X-detected-operating-system: by eggs.gnu.org: GNU/Linux 2.2.x-3.x [generic] X-Spam-Score: -2.3 (--) X-Debbugs-Envelope-To: 35790 Cc: 35790@debbugs.gnu.org X-BeenThere: debbugs-submit@debbugs.gnu.org X-Mailman-Version: 2.1.18 Precedence: list List-Id: List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: debbugs-submit-bounces@debbugs.gnu.org Sender: "Debbugs-submit" X-Spam-Score: -3.3 (---) Hi, I think this could have come as a subsequent patch, but regardless, this is a welcome move. Christopher Baines skribis: > To try and move towards making programatic access to the linting code eas= ier, > this commit separates out the linting script, from the linting functional= ity > that it uses. For the final version, please write a change log. > +(define-module (guix lint) > + #:use-module ((guix store) #:hide (close-connection)) > + #:use-module (guix base32) > + #:use-module (guix download) > + #:use-module (guix ftp-client) > + #:use-module (guix http-client) > + #:use-module (guix packages) > + #:use-module (guix licenses) > + #:use-module (guix records) > + #:use-module (guix grafts) > + #:use-module (guix ui) The principle that=E2=80=99s mostly followed for Guix modules is that they = are UI-independent: they might throw =E2=80=98&message=E2=80=99 error condition= s, they might even use (guix i18n), but they usually don=E2=80=99t depend on (guix ui). The idea is separation of concerns: the actual UI implementation details (TUI, GUI, etc.) remain separate from the API. At first sight (guix ui) is not necessary here, and it=E2=80=99s enough to = use (guix i18n), isn=E2=80=99t it? Last thing: please add this new file to po/guix/POTFILES.in. Thanks for working on it! Ludo=E2=80=99. From debbugs-submit-bounces@debbugs.gnu.org Fri Jul 12 10:38:29 2019 Received: (at 35790) by debbugs.gnu.org; 12 Jul 2019 14:38:29 +0000 Received: from localhost ([127.0.0.1]:40498 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1hlwgv-00084i-7F for submit@debbugs.gnu.org; Fri, 12 Jul 2019 10:38:29 -0400 Received: from eggs.gnu.org ([209.51.188.92]:34634) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1hlwgt-00084W-Gp for 35790@debbugs.gnu.org; Fri, 12 Jul 2019 10:38:27 -0400 Received: from fencepost.gnu.org ([2001:470:142:3::e]:41436) by eggs.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1hlwgo-0006T1-Bg; Fri, 12 Jul 2019 10:38:22 -0400 Received: from [2a01:e0a:1d:7270:af76:b9b:ca24:c465] (port=51420 helo=ribbon) by fencepost.gnu.org with esmtpsa (TLS1.2:RSA_AES_256_CBC_SHA1:256) (Exim 4.82) (envelope-from ) id 1hlwgn-0007vV-S1; Fri, 12 Jul 2019 10:38:22 -0400 From: =?utf-8?Q?Ludovic_Court=C3=A8s?= To: Christopher Baines Subject: Re: [bug#35790] [PATCH 2/2] lint: Separate checkers by dependence on the internet. References: <87a7dyoryh.fsf@gnu.org> <20190702192542.16179-1-mail@cbaines.net> <20190702192542.16179-2-mail@cbaines.net> Date: Fri, 12 Jul 2019 16:38:20 +0200 In-Reply-To: <20190702192542.16179-2-mail@cbaines.net> (Christopher Baines's message of "Tue, 2 Jul 2019 20:25:42 +0100") Message-ID: <87lfx3gvxf.fsf@gnu.org> User-Agent: Gnus/5.13 (Gnus v5.13) Emacs/26.2 (gnu/linux) MIME-Version: 1.0 Content-Type: text/plain; charset=utf-8 Content-Transfer-Encoding: quoted-printable X-detected-operating-system: by eggs.gnu.org: GNU/Linux 2.2.x-3.x [generic] X-Spam-Score: -2.3 (--) X-Debbugs-Envelope-To: 35790 Cc: 35790@debbugs.gnu.org X-BeenThere: debbugs-submit@debbugs.gnu.org X-Mailman-Version: 2.1.18 Precedence: list List-Id: List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: debbugs-submit-bounces@debbugs.gnu.org Sender: "Debbugs-submit" X-Spam-Score: -3.3 (---) Hi, Christopher Baines skribis: > I think there are a couple of potential uses for this. It's somewhat a > separation in to what checkers are just checking the contents of the > repository (line length for example), and other checkers which are bringi= ng in > external information which could change. > > I'm thinking particularly, about treating network dependant checkers > differently when automatically running them, but this commit also adds a > --no-network flag to guix lint, which selects the checkers that don't acc= ess > the network, which could be useful if no network access is available. > > * guix/lint.scm (%checkers): Rename to %all-checkers. > (%local-checkers, %network-dependant-checkers): New variables. > * guix/scripts/lint.scm (run-checkers): Make the checkers argument mandat= ory. > (list-checkers-and-exit): Handle the checkers as an argument. > (%options): Adjust for changes to %checkers, add a --no-network option, a= nd > change how the --list-checkers option is handled. > (guix-lint): Adjust indentation, and update how the checkers are handled. Nice. > +(define %network-dependant-checkers ^ Shouldn=E2=80=99t it be =E2=80=9Cdependent=E2=80=9D with an =E2=80=98e=E2= =80=99? Otherwise LGTM, thanks! Ludo=E2=80=99. From debbugs-submit-bounces@debbugs.gnu.org Sun Jul 14 14:04:06 2019 Received: (at 35790) by debbugs.gnu.org; 14 Jul 2019 18:04:06 +0000 Received: from localhost ([127.0.0.1]:45887 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1hmiqz-0006sP-WD for submit@debbugs.gnu.org; Sun, 14 Jul 2019 14:04:06 -0400 Received: from mira.cbaines.net ([212.71.252.8]:44522) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1hmiqw-0006rf-4x for 35790@debbugs.gnu.org; Sun, 14 Jul 2019 14:04:03 -0400 Received: from localhost (148.185.93.209.dyn.plus.net [209.93.185.148]) by mira.cbaines.net (Postfix) with ESMTPSA id 3AFB617203; Sun, 14 Jul 2019 19:04:00 +0100 (BST) Received: from phact (localhost [127.0.0.1]) by localhost (OpenSMTPD) with ESMTP id 39e07c27; Sun, 14 Jul 2019 18:04:00 +0000 (UTC) References: <87a7dyoryh.fsf@gnu.org> <20190702192542.16179-1-mail@cbaines.net> <87pnmfgw03.fsf@gnu.org> User-agent: mu4e 1.2.0; emacs 26.2 From: Christopher Baines To: Ludovic =?utf-8?Q?Court=C3=A8s?= Subject: Re: [bug#35790] [PATCH 1/2] lint: Move the linting code to a different module. In-reply-to: <87pnmfgw03.fsf@gnu.org> Date: Sun, 14 Jul 2019 19:03:59 +0100 Message-ID: <87wogkh4s0.fsf@cbaines.net> MIME-Version: 1.0 Content-Type: multipart/signed; boundary="=-=-="; micalg=pgp-sha512; protocol="application/pgp-signature" X-Spam-Score: -0.0 (/) X-Debbugs-Envelope-To: 35790 Cc: 35790@debbugs.gnu.org X-BeenThere: debbugs-submit@debbugs.gnu.org X-Mailman-Version: 2.1.18 Precedence: list List-Id: List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: debbugs-submit-bounces@debbugs.gnu.org Sender: "Debbugs-submit" X-Spam-Score: -1.0 (-) --=-=-= Content-Type: text/plain; charset=utf-8 Content-Transfer-Encoding: quoted-printable Ludovic Court=C3=A8s writes: > Christopher Baines skribis: > >> To try and move towards making programatic access to the linting code ea= sier, >> this commit separates out the linting script, from the linting functiona= lity >> that it uses. > > For the final version, please write a change log. Sure, any suggestions about how to write it? I wasn't sure whether to list everything that had been moved from (guix scripts lint) to (guix lint), or say that the file has moved, and list the things that have been moved back. >> +(define-module (guix lint) >> + #:use-module ((guix store) #:hide (close-connection)) >> + #:use-module (guix base32) >> + #:use-module (guix download) >> + #:use-module (guix ftp-client) >> + #:use-module (guix http-client) >> + #:use-module (guix packages) >> + #:use-module (guix licenses) >> + #:use-module (guix records) >> + #:use-module (guix grafts) >> + #:use-module (guix ui) > > The principle that=E2=80=99s mostly followed for Guix modules is that the= y are > UI-independent: they might throw =E2=80=98&message=E2=80=99 error conditi= ons, they might > even use (guix i18n), but they usually don=E2=80=99t depend on (guix ui). > > The idea is separation of concerns: the actual UI implementation details > (TUI, GUI, etc.) remain separate from the API. > > At first sight (guix ui) is not necessary here, and it=E2=80=99s enough t= o use > (guix i18n), isn=E2=80=99t it? I do remember looking at this, but I think I got stuck. I've just had another look though, and I think if I import (guix diagnostics) and (guix i18n) modules, then (guix ui) isn't required. > Last thing: please add this new file to po/guix/POTFILES.in. > > Thanks for working on it! No problem, thanks for taking a look :) --=-=-= Content-Type: application/pgp-signature; name="signature.asc" -----BEGIN PGP SIGNATURE----- iQKTBAEBCgB9FiEEPonu50WOcg2XVOCyXiijOwuE9XcFAl0rbo9fFIAAAAAALgAo aXNzdWVyLWZwckBub3RhdGlvbnMub3BlbnBncC5maWZ0aGhvcnNlbWFuLm5ldDNF ODlFRUU3NDU4RTcyMEQ5NzU0RTBCMjVFMjhBMzNCMEI4NEY1NzcACgkQXiijOwuE 9XdhORAAluYMBY+/GzHOVk3F3AUPzEQbkzAE3qXXAgVL7nZq3AZpRqcI4dgIlkXZ vycXTblVLIN2y5kRNu1ADQFs93cn93l1ap8fcr2jeUbaO9srpeN7J9OJvNvvR9RD vX3DlB7OJ/4BDiRZA9fDYoyafF8QBHNwfAyTUWRfS1lQZsvxmpJxqUCMKcOEvpLS /LiyxCmTfDezMufLoBtD7WHGmXxN+WINlQyq8qKcXHGngifcL9WBXTWNjFwueKbV pCtuQX2mNDTiRuSmDURS6ke0zM+EC5qfMgZ0du+Eb8SRmq/yqmD7OIQt+Y3q5kXp 6LMxdnw7QCmTAt3ubDY8yar076sR50J4+XVD1vKJLVPRcYG6MA8SGKaTC/mhZYMS mF4GX81D/qubU9px/32foeggH5s5tmYIqxiSTKN+jdO/ap/fQrUDBHzG8BFJNm19 FEAQxDwQZA1k8jkMJYzPhVsKb7q1rujpSocya5Zx+xzlA0RAin1vvVfZY/DUV4gJ jlY49zG3BZNncRFuAJu/+Vryj7bg1H4XlPGECm8LBk6iQX4utQI/LVoJfg5JWP26 tA/LL5TBOLaXNMdc2b1zkJLOALIOdUx4KxQlLc8uufMzEUdtPT+kcR26KqeCASUh hEUTW9tDLd9EP3rr7afG+dl2+9tVD7/gnLOW+ZDT2sPHj/oCFp0= =j6e4 -----END PGP SIGNATURE----- --=-=-=-- From debbugs-submit-bounces@debbugs.gnu.org Sun Jul 14 14:18:06 2019 Received: (at 35790) by debbugs.gnu.org; 14 Jul 2019 18:18:06 +0000 Received: from localhost ([127.0.0.1]:45921 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1hmj4X-0000zV-Tr for submit@debbugs.gnu.org; Sun, 14 Jul 2019 14:18:06 -0400 Received: from mira.cbaines.net ([212.71.252.8]:44544) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1hmj4U-0000zH-IU for 35790@debbugs.gnu.org; Sun, 14 Jul 2019 14:18:02 -0400 Received: from localhost (148.185.93.209.dyn.plus.net [209.93.185.148]) by mira.cbaines.net (Postfix) with ESMTPSA id 2305917203; Sun, 14 Jul 2019 19:17:58 +0100 (BST) Received: from phact (localhost [127.0.0.1]) by localhost (OpenSMTPD) with ESMTP id 5310e40e; Sun, 14 Jul 2019 18:17:57 +0000 (UTC) References: <87a7dyoryh.fsf@gnu.org> <20190702192542.16179-1-mail@cbaines.net> <20190702192542.16179-2-mail@cbaines.net> <87lfx3gvxf.fsf@gnu.org> User-agent: mu4e 1.2.0; emacs 26.2 From: Christopher Baines To: Ludovic =?utf-8?Q?Court=C3=A8s?= Subject: Re: [bug#35790] [PATCH 2/2] lint: Separate checkers by dependence on the internet. In-reply-to: <87lfx3gvxf.fsf@gnu.org> Date: Sun, 14 Jul 2019 19:17:55 +0100 Message-ID: <87v9w4h44s.fsf@cbaines.net> MIME-Version: 1.0 Content-Type: multipart/signed; boundary="=-=-="; micalg=pgp-sha512; protocol="application/pgp-signature" X-Spam-Score: -0.0 (/) X-Debbugs-Envelope-To: 35790 Cc: 35790@debbugs.gnu.org X-BeenThere: debbugs-submit@debbugs.gnu.org X-Mailman-Version: 2.1.18 Precedence: list List-Id: List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: debbugs-submit-bounces@debbugs.gnu.org Sender: "Debbugs-submit" X-Spam-Score: -1.0 (-) --=-=-= Content-Type: text/plain; charset=utf-8 Content-Transfer-Encoding: quoted-printable Ludovic Court=C3=A8s writes: > Hi, > > Christopher Baines skribis: > >> I think there are a couple of potential uses for this. It's somewhat a >> separation in to what checkers are just checking the contents of the >> repository (line length for example), and other checkers which are bring= ing in >> external information which could change. >> >> I'm thinking particularly, about treating network dependant checkers >> differently when automatically running them, but this commit also adds a >> --no-network flag to guix lint, which selects the checkers that don't ac= cess >> the network, which could be useful if no network access is available. >> >> * guix/lint.scm (%checkers): Rename to %all-checkers. >> (%local-checkers, %network-dependant-checkers): New variables. >> * guix/scripts/lint.scm (run-checkers): Make the checkers argument manda= tory. >> (list-checkers-and-exit): Handle the checkers as an argument. >> (%options): Adjust for changes to %checkers, add a --no-network option, = and >> change how the --list-checkers option is handled. >> (guix-lint): Adjust indentation, and update how the checkers are handled. > > Nice. > >> +(define %network-dependant-checkers > ^ > Shouldn=E2=80=99t it be =E2=80=9Cdependent=E2=80=9D with an =E2=80=98e=E2= =80=99? I'm definitely not an authority on spelling, but yeah, it seems like dependent is preferred as the adjective, especially in American English. > Otherwise LGTM, thanks! Great :) --=-=-= Content-Type: application/pgp-signature; name="signature.asc" -----BEGIN PGP SIGNATURE----- iQKTBAEBCgB9FiEEPonu50WOcg2XVOCyXiijOwuE9XcFAl0rcdNfFIAAAAAALgAo aXNzdWVyLWZwckBub3RhdGlvbnMub3BlbnBncC5maWZ0aGhvcnNlbWFuLm5ldDNF ODlFRUU3NDU4RTcyMEQ5NzU0RTBCMjVFMjhBMzNCMEI4NEY1NzcACgkQXiijOwuE 9XfvJhAAucGfOBkdvlC8Zrxbhpv+7L2dIowpxNGCdnCVLSGfwFzFQKM7yKsK1MLj LcGPONjYjdk80Cii2+iEwG2gdNemG/e8821FQNlKglWaduvPIAww/q+z9ulWe9ia FGLRVHVOmXgIcxcFohjq9wwL5LKu44VQrl+HHU6BvY8Uo7h7pDHRaPKaqTBWhhf9 S8khh1Yq7wO09O07F0lzRudjUHUlIqAJjAdSLpgGGGhM3vt8xH9yHE+bqywOf+4C rc9qYyh4BkMSvHpJiS6OtmgmgkY6c2M5TR7JlFcPOlXutEtC3h9ycOVnQsQ2SO6f DDVyZNtLPFVY8Ellx3w+cptOf/jjnGqEBD0EZ/MkpfnIBQZ5FIBq7m0If48gAJbC xltZgxgripyovUeQQ3C3TEVxZQhSzxw/ZRBvVQx2ysDNntfRURKsiORV3js+Utc9 4HRYr+d8OliOp3KvxmCRO4FiLgTve8TsRVGoK7VAzAfnVxyngR8yrGeAjAHLoE3a HBDVW68Zgffwn4aVeItagJw4+L5cJ9ytTzJCC+HlRnfzYib3p4yBsO+amAqNjz8w d0KzeAQg1qS/F+XAK/xgJLrS7uW1V3a1KOPgY45imgT1xA1QxpycTIT/qMZzphhi hRPe5jG/n5vyrP/D582lbLYAPcqTIhyEhLLZnBwmSnFaJyYGWNg= =sKPD -----END PGP SIGNATURE----- --=-=-=-- From debbugs-submit-bounces@debbugs.gnu.org Sun Jul 14 14:23:35 2019 Received: (at 35790) by debbugs.gnu.org; 14 Jul 2019 18:23:35 +0000 Received: from localhost ([127.0.0.1]:45936 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1hmj9p-00019e-V0 for submit@debbugs.gnu.org; Sun, 14 Jul 2019 14:23:35 -0400 Received: from mira.cbaines.net ([212.71.252.8]:44562) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1hmj9n-00019R-Qz for 35790@debbugs.gnu.org; Sun, 14 Jul 2019 14:23:32 -0400 Received: from localhost (148.185.93.209.dyn.plus.net [209.93.185.148]) by mira.cbaines.net (Postfix) with ESMTPSA id 9C2CC1722F; Sun, 14 Jul 2019 19:23:29 +0100 (BST) Received: from phact (localhost [127.0.0.1]) by localhost (OpenSMTPD) with ESMTP id 5cfb0d34; Sun, 14 Jul 2019 18:23:29 +0000 (UTC) References: <87a7dyoryh.fsf@gnu.org> <20190702192542.16179-1-mail@cbaines.net> <87pnmfgw03.fsf@gnu.org> <87wogkh4s0.fsf@cbaines.net> User-agent: mu4e 1.2.0; emacs 26.2 From: Christopher Baines To: Ludovic =?utf-8?Q?Court=C3=A8s?= Subject: Re: [bug#35790] [PATCH 1/2] lint: Move the linting code to a different module. In-reply-to: <87wogkh4s0.fsf@cbaines.net> Date: Sun, 14 Jul 2019 19:23:29 +0100 Message-ID: <87tvboh3vi.fsf@cbaines.net> MIME-Version: 1.0 Content-Type: multipart/signed; boundary="=-=-="; micalg=pgp-sha512; protocol="application/pgp-signature" X-Spam-Score: -0.0 (/) X-Debbugs-Envelope-To: 35790 Cc: 35790@debbugs.gnu.org X-BeenThere: debbugs-submit@debbugs.gnu.org X-Mailman-Version: 2.1.18 Precedence: list List-Id: List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: debbugs-submit-bounces@debbugs.gnu.org Sender: "Debbugs-submit" X-Spam-Score: -1.0 (-) --=-=-= Content-Type: text/plain; charset=utf-8 Content-Transfer-Encoding: quoted-printable Christopher Baines writes: > Ludovic Court=C3=A8s writes: > >> Christopher Baines skribis: >> >>> To try and move towards making programatic access to the linting code e= asier, >>> this commit separates out the linting script, from the linting function= ality >>> that it uses. >> >> For the final version, please write a change log. > > Sure, any suggestions about how to write it? I wasn't sure whether to > list everything that had been moved from (guix scripts lint) to (guix > lint), or say that the file has moved, and list the things that have > been moved back. Actually, now that I've run make, that's spotted some problems in some checks. guix/lint.scm:198:17: warning: possibly unbound variable `texi->plain-text' guix/lint.scm:406:8: warning: possibly unbound variable `texi->plain-text' guix/lint.scm:737:36: warning: possibly unbound variable `fill-paragraph' guix/lint.scm:738:36: warning: possibly unbound variable `fill-paragraph' guix/lint.scm:743:20: warning: possibly unbound variable `fill-paragraph' I don't think these are as easy to solve, as these functions come from (guix ui). --=-=-= Content-Type: application/pgp-signature; name="signature.asc" -----BEGIN PGP SIGNATURE----- iQKTBAEBCgB9FiEEPonu50WOcg2XVOCyXiijOwuE9XcFAl0rcyFfFIAAAAAALgAo aXNzdWVyLWZwckBub3RhdGlvbnMub3BlbnBncC5maWZ0aGhvcnNlbWFuLm5ldDNF ODlFRUU3NDU4RTcyMEQ5NzU0RTBCMjVFMjhBMzNCMEI4NEY1NzcACgkQXiijOwuE 9Xfdew//WiTScSUFcgIhLiSbLJGI0aMcXq65NB/naDNfy/bl9nhRTX/shzj4gwCL HG2QnEZEsXmk0tK0XW62BWIT1GSiR/2+f/U7Z2p+aa6sjU1xdsZrWv8GiEb3PbZt FLR48M7AXrJ+MV6YKWOBM8ruMNv3z+eybRYbqh1SLkTyPfvuhtg9rcPRKZJB3k9i /3F50xl/gT9JPNQv3beb895x7dRkVMVofvPFMN5BOfXFp4BZz8Gi8VJaMI0i4bmV nFsS+k9xBC+gBCHU6av2n1/0xIuVft86c7QOV5TcRkQS7zSywfpN5nlYlk7Oshoq opo+sabRa3d5/rwK3D2pLZ1fjyY0Yo1mMNaGuBpqeY+jZYgjMJpK6o++Vzo9Zh/t Ygk+vz+LQbteprTc6f4ay8Q8cTIzVNN5oTDxyeYaktjiAyJEMxSWCxCATsivlny0 UKfBMneQUFSgmiDQUxEDx8vJS+IMXwmu3SAfcH1SNfK++UDNulZTGQ4yZURoU9OS hjgfSOBIcwUGtetXNK/qIS8JHioHwHL5RutDHmsAL89bMSjeJoy3UuO3IQGN7fOs vICJ0FTwCht/CfbtsKLax/ZJtKS1cXHz0uJZyT0YLvlHZYkEytHPbJK7ATFk5cw6 cC1KsJVUZX0yfu9ThX+9G1oouqkl83S3xd9eK+P1NE7zSgjFQWM= =yfsP -----END PGP SIGNATURE----- --=-=-=-- From debbugs-submit-bounces@debbugs.gnu.org Mon Jul 15 05:20:47 2019 Received: (at 35790) by debbugs.gnu.org; 15 Jul 2019 09:20:47 +0000 Received: from localhost ([127.0.0.1]:46373 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1hmxA7-00067n-71 for submit@debbugs.gnu.org; Mon, 15 Jul 2019 05:20:47 -0400 Received: from eggs.gnu.org ([209.51.188.92]:37158) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1hmxA5-00067P-Eo for 35790@debbugs.gnu.org; Mon, 15 Jul 2019 05:20:46 -0400 Received: from fencepost.gnu.org ([2001:470:142:3::e]:43784) by eggs.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1hmx9y-0004BB-Oo; Mon, 15 Jul 2019 05:20:38 -0400 Received: from [2001:660:6102:320:e120:2c8f:8909:cdfe] (port=38882 helo=ribbon) by fencepost.gnu.org with esmtpsa (TLS1.2:RSA_AES_256_CBC_SHA1:256) (Exim 4.82) (envelope-from ) id 1hmx9y-0008Dv-AE; Mon, 15 Jul 2019 05:20:38 -0400 From: =?utf-8?Q?Ludovic_Court=C3=A8s?= To: Christopher Baines Subject: Re: [bug#35790] [PATCH 1/2] lint: Move the linting code to a different module. References: <87a7dyoryh.fsf@gnu.org> <20190702192542.16179-1-mail@cbaines.net> <87pnmfgw03.fsf@gnu.org> <87wogkh4s0.fsf@cbaines.net> X-URL: http://www.fdn.fr/~lcourtes/ X-Revolutionary-Date: 27 Messidor an 227 de la =?utf-8?Q?R=C3=A9volution?= X-PGP-Key-ID: 0x090B11993D9AEBB5 X-PGP-Key: http://www.fdn.fr/~lcourtes/ludovic.asc X-PGP-Fingerprint: 3CE4 6455 8A84 FDC6 9DB4 0CFB 090B 1199 3D9A EBB5 X-OS: x86_64-pc-linux-gnu Date: Mon, 15 Jul 2019 11:20:36 +0200 In-Reply-To: <87wogkh4s0.fsf@cbaines.net> (Christopher Baines's message of "Sun, 14 Jul 2019 19:03:59 +0100") Message-ID: <87k1cjr6vv.fsf@gnu.org> User-Agent: Gnus/5.13 (Gnus v5.13) Emacs/26.2 (gnu/linux) MIME-Version: 1.0 Content-Type: text/plain; charset=utf-8 Content-Transfer-Encoding: quoted-printable X-detected-operating-system: by eggs.gnu.org: GNU/Linux 2.2.x-3.x [generic] X-Spam-Score: -2.3 (--) X-Debbugs-Envelope-To: 35790 Cc: 35790@debbugs.gnu.org X-BeenThere: debbugs-submit@debbugs.gnu.org X-Mailman-Version: 2.1.18 Precedence: list List-Id: List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: debbugs-submit-bounces@debbugs.gnu.org Sender: "Debbugs-submit" X-Spam-Score: -3.3 (---) Hi Chris! Christopher Baines skribis: > Ludovic Court=C3=A8s writes: > >> Christopher Baines skribis: >> >>> To try and move towards making programatic access to the linting code e= asier, >>> this commit separates out the linting script, from the linting function= ality >>> that it uses. >> >> For the final version, please write a change log. > > Sure, any suggestions about how to write it? I wasn't sure whether to > list everything that had been moved from (guix scripts lint) to (guix > lint), or say that the file has moved, and list the things that have > been moved back. Maybe something like: * guix/scripts/lint.scm (check-foo, check-bar): Move to=E2=80=A6 * guix/lint.scm: =E2=80=A6 here. and also mention things that go beyond simply moving things around (if applicable). But again, don=E2=80=99t spend a whole day on this, it=E2=80=99s mostly so = the future us have an easily searchable log. > Actually, now that I've run make, that's spotted some problems in some > checks. > > guix/lint.scm:198:17: warning: possibly unbound variable `texi->plain-tex= t' > guix/lint.scm:406:8: warning: possibly unbound variable `texi->plain-text' > guix/lint.scm:737:36: warning: possibly unbound variable `fill-paragraph' > guix/lint.scm:738:36: warning: possibly unbound variable `fill-paragraph' > guix/lint.scm:743:20: warning: possibly unbound variable `fill-paragraph' > > I don't think these are as easy to solve, as these functions come from > (guix ui). Ah yes, indeed.=20=20 In that case it=E2=80=99s OK because (guix ui) is used as part of the linte= r=E2=80=99s job. Perhaps for clarity we should write: #:use-module ((guix ui) #:select (texi->plain-text fill-paragraph)) Uses of the =E2=80=98warning=E2=80=99 procedure or similar UI functionality= should be left to (guix scripts lint), though. Thanks, Ludo=E2=80=99. From debbugs-submit-bounces@debbugs.gnu.org Mon Jul 15 15:46:04 2019 Received: (at 35790) by debbugs.gnu.org; 15 Jul 2019 19:46:04 +0000 Received: from localhost ([127.0.0.1]:49188 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1hn6vB-0000Cm-7z for submit@debbugs.gnu.org; Mon, 15 Jul 2019 15:46:03 -0400 Received: from mira.cbaines.net ([212.71.252.8]:45780) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1hn6vA-0000Cd-8A for 35790@debbugs.gnu.org; Mon, 15 Jul 2019 15:46:00 -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 5D2D5171BA for <35790@debbugs.gnu.org>; Mon, 15 Jul 2019 20:45:58 +0100 (BST) Received: from localhost (localhost [local]) by localhost (OpenSMTPD) with ESMTPA id a80b8613 for <35790@debbugs.gnu.org>; Mon, 15 Jul 2019 19:45:58 +0000 (UTC) From: Christopher Baines To: 35790@debbugs.gnu.org Subject: [PATCH 1/4] scripts: lint: Handle warnings with a record type. Date: Mon, 15 Jul 2019 20:45:55 +0100 Message-Id: <20190715194558.13804-1-mail@cbaines.net> X-Mailer: git-send-email 2.22.0 In-Reply-To: <87k1cjr6vv.fsf@gnu.org> References: <87k1cjr6vv.fsf@gnu.org> MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit X-Debbugs-Envelope-To: 35790 X-BeenThere: debbugs-submit@debbugs.gnu.org X-Mailman-Version: 2.1.18 Precedence: list List-Id: List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: debbugs-submit-bounces@debbugs.gnu.org Sender: "Debbugs-submit" 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 (): New record type. (lint-warning): New macro. (lint-warning?, lint-warning-package, lint-warning-message, lint-warning-location, package-file, make-warning): New procedures. (call-with-accumulated-warnings, with-accumulated-warnings): Remove. (emit-warning): Rename to emit-warnings, and switch to displaying multiple warnings. (check-description-style)[check-not-empty-description, check-texinfo-markup, check-trademarks, check-quotes, check-proper-start, check-end-of-sentence-space]: Switch to generating a list of warnings, and using make-warning, rather than emit-warning. (check-inputs-should-be-native, check-inputs-should-not-be-an-input-at-all): Switch to generating a list of warnings, and using make-warning, rather than emit-warning. (check-synopsis): Switch to generating a list of warnings, and using make-warning, rather than emit-warning. [check-not-empty]: Remove, this is handled in the match clause to avoid other warnings being emitted. [check-final-period, check-start-article, check-synopsis-length, check-proper-start, check-start-with-package-name, check-texinfo-markup]: Switch to generating a list of warnings, and using make-warning, rather than emit-warning. [checks]: Remove check-not-empty. (validate-uri, check-home-page, check-patch-file-names, check-gnu-synopsis+description): Switch to generating a list of warnings, and using make-warning, rather than emit-warning. (check-source): Switch to generating a list of warnings, and using make-warning, rather than emit-warning. [try-uris]: Remove. [warnings-for-uris]: New procedure, replacing try-uris. (check-source-file-name, check-source-unstable-tarball, check-mirror-url, check-github-url, check-derivation, check-vulnerabilities, check-for-updates, report-tabulations, report-trailing-white-space, report-long-line, report-lone-parentheses, report-formatting-issues, check-formatting): Switch to generating a list of warnings, and using make-warning, rather than emit-warning. (run-checkers): Call emit-warnings on the warnings returned from the checker. * tests/lint.scm (string-match-or-error, single-lint-warning-message): New procedures. (call-with-warnings, with-warnings): Remove. ("description: not a string", "description: not empty", "description: invalid Texinfo markup", "description: does not start with an upper-case letter", "description: may start with a digit", "description: may start with lower-case package name", "description: two spaces after end of sentence", "description: end-of-sentence detection with abbreviations", "description: may not contain trademark signs: ™", "description: may not contain trademark signs: ®", "description: suggest ornament instead of quotes", "synopsis: not a string", "synopsis: not empty", "synopsis: valid Texinfo markup", "synopsis: does not start with an upper-case letter", "synopsis: may start with a digit", "synopsis: ends with a period", "synopsis: ends with 'etc.'", "synopsis: starts with 'A'", "synopsis: starts with 'a'", "synopsis: starts with 'an'", "synopsis: too long", "synopsis: start with package name", "synopsis: start with package name prefix", "synopsis: start with abbreviation", "inputs: pkg-config is probably a native input", "inputs: glib:bin is probably a native input", "inputs: python-setuptools should not be an input at all (input)", "inputs: python-setuptools should not be an input at all (native-input)", "inputs: python-setuptools should not be an input at all (propagated-input)", "patches: file names", "patches: file name too long", "patches: not found", "derivation: invalid arguments", "license: invalid license", "home-page: wrong home-page", "home-page: invalid URI", "home-page: host not found", "home-page: Connection refused", "home-page: 200", "home-page: 200 but short length", "home-page: 404", "home-page: 301, invalid", "home-page: 301 -> 200", "home-page: 301 -> 404", "source-file-name", "source-file-name: v prefix", "source-file-name: bad checkout", "source-file-name: good checkout", "source-file-name: valid", "source-unstable-tarball", "source-unstable-tarball: source #f", "source-unstable-tarball: valid", "source-unstable-tarball: package named archive", "source-unstable-tarball: not-github", "source-unstable-tarball: git-fetch", "source: 200", "source: 200 but short length", "source: 404", "source: 301 -> 200", "source: 301 -> 404", "mirror-url", "mirror-url: one suggestion", "github-url", "github-url: one suggestion", "github-url: already the correct github url", "cve", "cve: one vulnerability", "cve: one patched vulnerability", "cve: known safe from vulnerability", "cve: vulnerability fixed in replacement version", "cve: patched vulnerability in replacement", "formatting: lonely parentheses", "formatting: alright"): Change test-assert to test-equal, and adjust to work with the changes above. ("formatting: tabulation", "formatting: trailing white space", "formatting: long line"): Use string-match-or-error rather than string-contains. --- guix/scripts/lint.scm | 757 +++++++++++---------- tests/lint.scm | 1453 +++++++++++++++++++---------------------- 2 files changed, 1102 insertions(+), 1108 deletions(-) diff --git a/guix/scripts/lint.scm b/guix/scripts/lint.scm index dc338a1d7b..1b08068669 100644 --- a/guix/scripts/lint.scm +++ b/guix/scripts/lint.scm @@ -84,6 +84,12 @@ check-formatting run-checkers + lint-warning + lint-warning? + lint-warning-package + lint-warning-message + lint-warning-location + %checkers lint-checker lint-checker? @@ -93,42 +99,48 @@ ;;; -;;; 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))) + warnings)) ;;; ;;; Checkers ;;; + (define-record-type* 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 ;; . (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 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 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))) + stringbool - (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) ) 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) ) 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) ) 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) ) 0 "CVE-2015-1234" (list (cons (package-name package) (package-version package))))))) - (string-null? - (with-warnings - (check-vulnerabilities - (dummy-package - "pi" (version "3.14") (source (dummy-origin)) - (replacement (dummy-package - "pi" (version "3.14") - (source - (dummy-origin - (patches - (list "/a/b/pi-CVE-2015-1234.patch")))))))))))) - -(test-assert "formatting: lonely parentheses" - (string-contains - (with-warnings - (check-formatting - ( - dummy-package "ugly as hell!" - ) - )) - "lonely")) + (check-vulnerabilities + (dummy-package + "pi" (version "3.14") (source (dummy-origin)) + (replacement (dummy-package + "pi" (version "3.14") + (source + (dummy-origin + (patches + (list "/a/b/pi-CVE-2015-1234.patch")))))))))) + +(test-equal "formatting: lonely parentheses" + "parentheses feel lonely, move to the previous or next line" + (single-lint-warning-message + (check-formatting + (dummy-package "ugly as hell!" + ) + ))) (test-assert "formatting: tabulation" - (string-contains - (with-warnings - (check-formatting (dummy-package "leave the tab here: "))) - "tabulation")) + (string-match-or-error + "tabulation on line [0-9]+, column [0-9]+" + (single-lint-warning-message + (check-formatting (dummy-package "leave the tab here: "))))) (test-assert "formatting: trailing white space" - (string-contains - (with-warnings - ;; Leave the trailing white space on the next line! - (check-formatting (dummy-package "x"))) - "trailing white space")) + (string-match-or-error + "trailing white space .*" + ;; Leave the trailing white space on the next line! + (single-lint-warning-message + (check-formatting (dummy-package "x"))))) (test-assert "formatting: long line" - (string-contains - (with-warnings - (check-formatting - (dummy-package "x" ;here is a stupid comment just to make a long line - ))) - "too long")) - -(test-assert "formatting: alright" - (string-null? - (with-warnings - (check-formatting (dummy-package "x"))))) + (string-match-or-error + "line [0-9]+ is way too long \\([0-9]+ characters\\)" + (single-lint-warning-message (check-formatting + (dummy-package "x")) ;here is a stupid comment just to make a long line + ))) + +(test-equal "formatting: alright" + '() + (check-formatting (dummy-package "x"))) (test-end "lint") -- 2.22.0 From debbugs-submit-bounces@debbugs.gnu.org Mon Jul 15 15:46:07 2019 Received: (at 35790) by debbugs.gnu.org; 15 Jul 2019 19:46:07 +0000 Received: from localhost ([127.0.0.1]:49189 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1hn6vG-0000DY-Fp for submit@debbugs.gnu.org; Mon, 15 Jul 2019 15:46:07 -0400 Received: from mira.cbaines.net ([212.71.252.8]:45778) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1hn6vA-0000Cb-86 for 35790@debbugs.gnu.org; Mon, 15 Jul 2019 15:46:01 -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 9B1ED171BB for <35790@debbugs.gnu.org>; Mon, 15 Jul 2019 20:45:58 +0100 (BST) Received: from localhost (localhost [local]) by localhost (OpenSMTPD) with ESMTPA id 083a277c for <35790@debbugs.gnu.org>; Mon, 15 Jul 2019 19:45:58 +0000 (UTC) From: Christopher Baines To: 35790@debbugs.gnu.org Subject: [PATCH 2/4] scripts: lint: Separate the message warning text and data. Date: Mon, 15 Jul 2019 20:45:56 +0100 Message-Id: <20190715194558.13804-2-mail@cbaines.net> X-Mailer: git-send-email 2.22.0 In-Reply-To: <20190715194558.13804-1-mail@cbaines.net> References: <87k1cjr6vv.fsf@gnu.org> <20190715194558.13804-1-mail@cbaines.net> MIME-Version: 1.0 Content-Transfer-Encoding: 8bit X-Spam-Score: 0.0 (/) X-Debbugs-Envelope-To: 35790 X-BeenThere: debbugs-submit@debbugs.gnu.org X-Mailman-Version: 2.1.18 Precedence: list List-Id: List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: debbugs-submit-bounces@debbugs.gnu.org Sender: "Debbugs-submit" X-Spam-Score: -1.0 (-) So that translations can be handled more flexibly, rather than having to translate the message text within the checker. * guix/scripts/lint.scm (lint-warning-message-text, lint-warning-message-data): New procedures. (lint-warning-message): Remove record field accessor, replace with procedure that handles the lint warning data and translating the message. (make-warning): Rename to %make-warning. (make-warning): New macro. (emit-warnings): Handle the message-text and message-data fields. (check-description-style): Adjust for changes to make-warning. [check-trademarks, check-end-of-sentence-space): Adjust for changes to make-warning. (check-inputs-should-be-native, check-inputs-should-not-be-an-input-at-all, check-synopsis-style, validate-uri, check-home-page, check-patch-file-names, check-gnu-synopsis+description, check-mirror-url, check-github-url, check-derivation, check-vulnerabilities, check-for-updates, report-tabulations, report-trailing-white-space, report-long-line, report-lone-parentheses): Adjust for changes to make-warning. --- guix/scripts/lint.scm | 198 ++++++++++++++++++++++-------------------- 1 file changed, 106 insertions(+), 92 deletions(-) diff --git a/guix/scripts/lint.scm b/guix/scripts/lint.scm index 1b08068669..4eb7e0e200 100644 --- a/guix/scripts/lint.scm +++ b/guix/scripts/lint.scm @@ -88,6 +88,8 @@ lint-warning? lint-warning-package lint-warning-message + lint-warning-message-text + lint-warning-message-data lint-warning-location %checkers @@ -105,35 +107,49 @@ (define-record-type* lint-warning make-lint-warning lint-warning? - (package lint-warning-package) - (message lint-warning-message) - (location lint-warning-location - (default #f))) + (package lint-warning-package) + (message-text lint-warning-message-text) + (message-data lint-warning-message-data + (default '())) + (location lint-warning-location + (default #f))) + +(define (lint-warning-message warning) + (apply format #f + (G_ (lint-warning-message-text warning)) + (lint-warning-message-data warning))) (define (package-file package) (location-file (package-location package))) -(define* (make-warning package message - #:key field location) +(define* (%make-warning package message-text + #:optional (message-data '()) + #:key field location) (make-lint-warning package - message + message-text + message-data (or location (package-field-location package field) (package-location package)))) +(define-syntax make-warning + (syntax-rules (G_) + ((_ package (G_ message) rest ...) + (%make-warning package message rest ...)))) + (define (emit-warnings warnings) ;; Emit a warning about PACKAGE, printing the location of FIELD if it is ;; given, the location of PACKAGE otherwise, the full name of PACKAGE and the ;; provided MESSAGE. (for-each (match-lambda - (($ package message loc) + (($ package message-text message-data loc) (format (guix-warning-port) "~a: ~a@~a: ~a~%" (location->string loc) (package-name package) (package-version package) - message))) + (apply format #f (G_ message-text) message-data)))) warnings)) @@ -199,9 +215,9 @@ http://www.gnu.org/prep/standards/html_node/Trademarks.html." ((and (? number?) index) (list (make-warning package - (format #f (G_ "description should not contain ~ + (G_ "description should not contain ~ trademark sign '~a' at ~d") - (string-ref description index) index) + (list (string-ref description index) index) #:field 'description))) (else '()))) @@ -242,10 +258,10 @@ trademark sign '~a' at ~d") '() (list (make-warning package - (format #f (G_ "sentences in description should be followed ~ + (G_ "sentences in description should be followed ~ by two spaces; possible infraction~p at ~{~a~^, ~}") - (length infractions) - infractions) + (list (length infractions) + infractions) #:field 'description))))) (let ((description (package-description package))) @@ -263,7 +279,8 @@ by two spaces; possible infraction~p at ~{~a~^, ~}") (check-proper-start plain-description)))) (list (make-warning package - (format #f (G_ "invalid description: ~s") description) + (G_ "invalid description: ~s") + (list description) #:field 'description))))) (define (package-input-intersection inputs-to-check input-names) @@ -308,8 +325,8 @@ of a package, and INPUT-NAMES, a list of package specifications such as (map (lambda (input) (make-warning package - (format #f (G_ "'~a' should probably be a native input") - input) + (G_ "'~a' should probably be a native input") + (list input) #:field 'inputs)) (package-input-intersection inputs input-names)))) @@ -323,9 +340,8 @@ of a package, and INPUT-NAMES, a list of package specifications such as (map (lambda (input) (make-warning package - (format #f - (G_ "'~a' should probably not be an input at all") - input) + (G_ "'~a' should probably not be an input at all") + (list input) #:field 'inputs)) (package-input-intersection (package-direct-inputs package) input-names)))) @@ -423,7 +439,9 @@ markup is valid return a plain-text version of SYNOPSIS, otherwise #f." checks)) (invalid (list - (make-warning package (format #f (G_ "invalid synopsis: ~s") invalid) + (make-warning package + (G_ "invalid synopsis: ~s") + (list invalid) #:field 'synopsis))))) (define* (probe-uri uri #:key timeout) @@ -540,64 +558,59 @@ PACKAGE mentionning the FIELD." ;; such malicious behavior. (or (> length 1000) (make-warning package - (format #f - (G_ "URI ~a returned \ + (G_ "URI ~a returned \ suspiciously small file (~a bytes)") - (uri->string uri) - length) + (list (uri->string uri) + length) #:field field))) (_ #t))) ((= 301 (response-code argument)) (if (response-location argument) (make-warning package - (format #f (G_ "permanent redirect from ~a to ~a") - (uri->string uri) - (uri->string - (response-location argument))) + (G_ "permanent redirect from ~a to ~a") + (list (uri->string uri) + (uri->string + (response-location argument))) #:field field) (make-warning package - (format #f (G_ "invalid permanent redirect \ + (G_ "invalid permanent redirect \ from ~a") - (uri->string uri)) + (list (uri->string uri)) #:field field))) (else (make-warning package - (format #f - (G_ "URI ~a not reachable: ~a (~s)") - (uri->string uri) - (response-code argument) - (response-reason-phrase argument)) + (G_ "URI ~a not reachable: ~a (~s)") + (list (uri->string uri) + (response-code argument) + (response-reason-phrase argument)) #:field field)))) ((ftp-response) (match argument (('ok) #t) (('error port command code message) (make-warning package - (format #f - (G_ "URI ~a not reachable: ~a (~s)") - (uri->string uri) - code (string-trim-both message)) + (G_ "URI ~a not reachable: ~a (~s)") + (list (uri->string uri) + code (string-trim-both message)) #:field field)))) ((getaddrinfo-error) (make-warning package - (format #f - (G_ "URI ~a domain not found: ~a") - (uri->string uri) - (gai-strerror (car argument))) + (G_ "URI ~a domain not found: ~a") + (list (uri->string uri) + (gai-strerror (car argument))) #:field field)) ((system-error) (make-warning package - (format #f - (G_ "URI ~a unreachable: ~a") - (uri->string uri) - (strerror - (system-error-errno - (cons status argument)))) + (G_ "URI ~a unreachable: ~a") + (list (uri->string uri) + (strerror + (system-error-errno + (cons status argument)))) #:field field)) ((tls-certificate-error) (make-warning package - (format #f (G_ "TLS certificate error: ~a") - (tls-certificate-error-string argument)) + (G_ "TLS certificate error: ~a") + (list (tls-certificate-error-string argument)) #:field field)) ((invalid-http-response gnutls-error) ;; Probably a misbehaving server; ignore. @@ -627,8 +640,9 @@ from ~a") #:field 'home-page)))) (else (list - (make-warning package (format #f (G_ "invalid home page URL: ~s") - (package-home-page package)) + (make-warning package + (G_ "invalid home page URL: ~s") + (list (package-home-page package)) #:field 'home-page)))))) (define %distro-directory @@ -640,8 +654,10 @@ from ~a") patch could not be found." (guard (c ((message-condition? c) ;raised by 'search-patch' (list - (make-warning package (condition-message c) - #:field 'patch-file-names)))) + ;; Use %make-warning, as condition-mesasge is already + ;; translated. + (%make-warning package (condition-message c) + #:field 'patch-file-names)))) (define patches (or (and=> (package-source package) origin-patches) '())) @@ -674,8 +690,8 @@ patch could not be found." max) (make-warning package - (format #f (G_ "~a: file name is too long") - (basename patch)) + (G_ "~a: file name is too long") + (list (basename patch)) #:field 'patch-file-names) #f)) (_ #f)) @@ -716,8 +732,8 @@ descriptions maintained upstream." (not (string=? upstream downstream)))) (list (make-warning package - (format #f (G_ "proposed synopsis: ~s~%") - upstream) + (G_ "proposed synopsis: ~s~%") + (list upstream) #:field 'synopsis)) '())) @@ -730,9 +746,8 @@ descriptions maintained upstream." (list (make-warning package - (format #f - (G_ "proposed description:~% \"~a\"~%") - (fill-paragraph (escape-quotes upstream) 77 7)) + (G_ "proposed description:~% \"~a\"~%") + (list (fill-paragraph (escape-quotes upstream) 77 7)) #:field 'description)) '())))))) @@ -831,10 +846,10 @@ descriptions maintained upstream." (loop rest)) (prefix (make-warning package - (format #f (G_ "URL should be \ + (G_ "URL should be \ 'mirror://~a/~a'") - mirror-id - (string-drop uri (string-length prefix))) + (list mirror-id + (string-drop uri (string-length prefix))) #:field 'source))))))) (let ((origin (package-source package))) @@ -876,7 +891,8 @@ descriptions maintained upstream." #f (make-warning package - (format #f (G_ "URL should be '~a'") github-uri) + (G_ "URL should be '~a'") + (list github-uri) #:field 'source))))) (origin-uris origin)) '()))) @@ -888,14 +904,14 @@ descriptions maintained upstream." (lambda () (guard (c ((store-protocol-error? c) (make-warning package - (format #f (G_ "failed to create ~a derivation: ~a") - system - (store-protocol-error-message c)))) + (G_ "failed to create ~a derivation: ~a") + (list system + (store-protocol-error-message c)))) ((message-condition? c) (make-warning package - (format #f (G_ "failed to create ~a derivation: ~a") - system - (condition-message c))))) + (G_ "failed to create ~a derivation: ~a") + (list system + (condition-message c))))) (with-store store ;; Disable grafts since it can entail rebuilds. (parameterize ((%graft? #f)) @@ -910,8 +926,8 @@ descriptions maintained upstream." #:graft? #f))))))) (lambda args (make-warning package - (format #f (G_ "failed to create ~a derivation: ~s") - system args))))) + (G_ "failed to create ~a derivation: ~s") + (list system args))))) (filter lint-warning? (map try (package-supported-systems package)))) @@ -1001,15 +1017,15 @@ the NIST server non-fatal." (list (make-warning package - (format #f (G_ "probably vulnerable to ~a") - (string-join (map vulnerability-id unpatched) - ", ")))))))))) + (G_ "probably vulnerable to ~a") + (list (string-join (map vulnerability-id unpatched) + ", ")))))))))) (define (check-for-updates package) "Check if there is an update available for PACKAGE." (match (with-networking-fail-safe - (format #f (G_ "while retrieving upstream info for '~a'") - (package-name package)) + (G_ "while retrieving upstream info for '~a'") + (list (package-name package)) #f (package-latest-release* package (force %updaters))) ((? upstream-source? source) @@ -1017,8 +1033,8 @@ the NIST server non-fatal." (package-version package)) (list (make-warning package - (format #f (G_ "can be upgraded to ~a") - (upstream-source-version source)) + (G_ "can be upgraded to ~a") + (list (upstream-source-version source)) #:field 'version)) '())) (#f '()))) ; cannot find newer upstream release @@ -1034,8 +1050,8 @@ the NIST server non-fatal." (#f #t) (index (make-warning package - (format #f (G_ "tabulation on line ~a, column ~a") - line-number index) + (G_ "tabulation on line ~a, column ~a") + (list line-number index) #:location (location (package-file package) line-number @@ -1046,9 +1062,8 @@ the NIST server non-fatal." (unless (or (string=? line (string-trim-right line)) (string=? line (string #\page))) (make-warning package - (format #f - (G_ "trailing white space on line ~a") - line-number) + (G_ "trailing white space on line ~a") + (list line-number) #:location (location (package-file package) line-number @@ -1061,8 +1076,8 @@ the NIST server non-fatal." ;; much noise. (when (> (string-length line) 90) (make-warning package - (format #f (G_ "line ~a is way too long (~a characters)") - line-number (string-length line)) + (G_ "line ~a is way too long (~a characters)") + (list line-number (string-length line)) #:location (location (package-file package) line-number @@ -1075,10 +1090,9 @@ the NIST server non-fatal." "Emit a warning if LINE contains hanging parentheses." (when (regexp-exec %hanging-paren-rx line) (make-warning package - (format #f - (G_ "parentheses feel lonely, \ + (G_ "parentheses feel lonely, \ move to the previous or next line") - line-number) + (list line-number) #:location (location (package-file package) line-number -- 2.22.0 From debbugs-submit-bounces@debbugs.gnu.org Mon Jul 15 15:46:08 2019 Received: (at 35790) by debbugs.gnu.org; 15 Jul 2019 19:46:08 +0000 Received: from localhost ([127.0.0.1]:49191 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1hn6vH-0000Dl-O7 for submit@debbugs.gnu.org; Mon, 15 Jul 2019 15:46:08 -0400 Received: from mira.cbaines.net ([212.71.252.8]:45782) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1hn6vA-0000Cc-89 for 35790@debbugs.gnu.org; Mon, 15 Jul 2019 15:46:01 -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 E5F30171DC for <35790@debbugs.gnu.org>; Mon, 15 Jul 2019 20:45:58 +0100 (BST) Received: from localhost (localhost [local]) by localhost (OpenSMTPD) with ESMTPA id 856c4faa for <35790@debbugs.gnu.org>; Mon, 15 Jul 2019 19:45:58 +0000 (UTC) From: Christopher Baines To: 35790@debbugs.gnu.org Subject: [PATCH 4/4] lint: Separate checkers by dependence on the internet. Date: Mon, 15 Jul 2019 20:45:58 +0100 Message-Id: <20190715194558.13804-4-mail@cbaines.net> X-Mailer: git-send-email 2.22.0 In-Reply-To: <20190715194558.13804-1-mail@cbaines.net> References: <87k1cjr6vv.fsf@gnu.org> <20190715194558.13804-1-mail@cbaines.net> MIME-Version: 1.0 Content-Transfer-Encoding: 8bit X-Spam-Score: -0.0 (/) X-Debbugs-Envelope-To: 35790 X-BeenThere: debbugs-submit@debbugs.gnu.org X-Mailman-Version: 2.1.18 Precedence: list List-Id: List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: debbugs-submit-bounces@debbugs.gnu.org Sender: "Debbugs-submit" X-Spam-Score: -1.0 (-) I think there are a couple of potential uses for this. It's somewhat a separation in to what checkers are just checking the contents of the repository (line length for example), and other checkers which are bringing in external information which could change. I'm thinking particularly, about treating network dependent checkers differently when automatically running them, but this commit also adds a --no-network flag to guix lint, which selects the checkers that don't access the network, which could be useful if no network access is available. * guix/lint.scm (%checkers): Rename to %all-checkers. (%local-checkers, %network-dependent-checkers): New variables. * guix/scripts/lint.scm (run-checkers): Make the checkers argument mandatory. (list-checkers-and-exit): Handle the checkers as an argument. (%options): Adjust for changes to %checkers, add a --no-network option, and change how the --list-checkers option is handled. (guix-lint): Adjust indentation, and update how the checkers are handled. --- guix/lint.scm | 63 ++++++++++++++++++++++++------------------- guix/scripts/lint.scm | 49 ++++++++++++++++++++------------- 2 files changed, 66 insertions(+), 46 deletions(-) diff --git a/guix/lint.scm b/guix/lint.scm index c2c0914958..2542a81a2d 100644 --- a/guix/lint.scm +++ b/guix/lint.scm @@ -91,7 +91,9 @@ lint-warning-message-data lint-warning-location - %checkers + %local-checkers + %network-dependent-checkers + %all-checkers lint-checker lint-checker? @@ -1146,16 +1148,12 @@ them for PACKAGE." ;;; List of checkers. ;;; -(define %checkers +(define %local-checkers (list (lint-checker (name 'description) (description "Validate package descriptions") (check check-description-style)) - (lint-checker - (name 'gnu-description) - (description "Validate synopsis & description of GNU packages") - (check check-gnu-synopsis+description)) (lint-checker (name 'inputs-should-be-native) (description "Identify inputs that should be native inputs") @@ -1164,14 +1162,6 @@ them for PACKAGE." (name 'inputs-should-not-be-input) (description "Identify inputs that shouldn't be inputs at all") (check check-inputs-should-not-be-an-input-at-all)) - (lint-checker - (name 'patch-file-names) - (description "Validate file names and availability of patches") - (check check-patch-file-names)) - (lint-checker - (name 'home-page) - (description "Validate home-page URLs") - (check check-home-page)) (lint-checker (name 'license) ;; TRANSLATORS: is the name of a data type and must not be @@ -1179,18 +1169,10 @@ them for PACKAGE." (description "Make sure the 'license' field is a \ or a list thereof") (check check-license)) - (lint-checker - (name 'source) - (description "Validate source URLs") - (check check-source)) (lint-checker (name 'mirror-url) (description "Suggest 'mirror://' URLs") (check check-mirror-url)) - (lint-checker - (name 'github-url) - (description "Suggest GitHub URLs") - (check check-github-url)) (lint-checker (name 'source-file-name) (description "Validate file names of sources") @@ -1203,10 +1185,37 @@ or a list thereof") (name 'derivation) (description "Report failure to compile a package to a derivation") (check check-derivation)) + (lint-checker + (name 'patch-file-names) + (description "Validate file names and availability of patches") + (check check-patch-file-names)) + (lint-checker + (name 'formatting) + (description "Look for formatting issues in the source") + (check check-formatting)))) + +(define %network-dependent-checkers + (list (lint-checker (name 'synopsis) (description "Validate package synopses") (check check-synopsis-style)) + (lint-checker + (name 'gnu-description) + (description "Validate synopsis & description of GNU packages") + (check check-gnu-synopsis+description)) + (lint-checker + (name 'home-page) + (description "Validate home-page URLs") + (check check-home-page)) + (lint-checker + (name 'source) + (description "Validate source URLs") + (check check-source)) + (lint-checker + (name 'github-url) + (description "Suggest GitHub URLs") + (check check-github-url)) (lint-checker (name 'cve) (description "Check the Common Vulnerabilities and Exposures\ @@ -1215,8 +1224,8 @@ or a list thereof") (lint-checker (name 'refresh) (description "Check the package for new upstream releases") - (check check-for-updates)) - (lint-checker - (name 'formatting) - (description "Look for formatting issues in the source") - (check check-formatting)))) + (check check-for-updates)))) + +(define %all-checkers + (append %local-checkers + %network-dependent-checkers)) diff --git a/guix/scripts/lint.scm b/guix/scripts/lint.scm index 1c46fba16b..98ee469501 100644 --- a/guix/scripts/lint.scm +++ b/guix/scripts/lint.scm @@ -52,7 +52,7 @@ (lint-warning-message lint-warning)))) warnings)) -(define* (run-checkers package #:optional (checkers %checkers)) +(define (run-checkers package checkers) "Run the given CHECKERS on PACKAGE." (let ((tty? (isatty? (current-error-port)))) (for-each (lambda (checker) @@ -68,14 +68,14 @@ (format (current-error-port) "\x1b[K") (force-output (current-error-port))))) -(define (list-checkers-and-exit) +(define (list-checkers-and-exit checkers) ;; Print information about all available checkers and exit. (format #t (G_ "Available checkers:~%")) (for-each (lambda (checker) (format #t "- ~a: ~a~%" (lint-checker-name checker) (G_ (lint-checker-description checker)))) - %checkers) + checkers) (exit 0)) @@ -111,26 +111,33 @@ run the checkers on all packages.\n")) ;; 'certainty'. (list (option '(#\c "checkers") #t #f (lambda (opt name arg result) - (let ((names (map string->symbol (string-split arg #\,)))) + (let ((names (map string->symbol (string-split arg #\,))) + (checker-names (map lint-checker-name %all-checkers))) (for-each (lambda (c) - (unless (memq c - (map lint-checker-name - %checkers)) + (unless (memq c checker-names) (leave (G_ "~a: invalid checker~%") c))) names) (alist-cons 'checkers (filter (lambda (checker) (member (lint-checker-name checker) names)) - %checkers) + %all-checkers) result)))) + (option '(#\n "no-network") #f #f + (lambda (opt name arg result) + (alist-cons 'checkers + %local-checkers + (alist-delete 'checkers + result)))) (option '(#\h "help") #f #f (lambda args (show-help) (exit 0))) (option '(#\l "list-checkers") #f #f - (lambda args - (list-checkers-and-exit))) + (lambda (opt name arg result) + (alist-cons 'list? + #t + result))) (option '(#\V "version") #f #f (lambda args (show-version-and-exit "guix lint"))))) @@ -148,13 +155,17 @@ run the checkers on all packages.\n")) (let* ((opts (parse-options)) (args (filter-map (match-lambda - (('argument . value) - value) - (_ #f)) + (('argument . value) + value) + (_ #f)) (reverse opts))) - (checkers (or (assoc-ref opts 'checkers) %checkers))) - (if (null? args) - (fold-packages (lambda (p r) (run-checkers p checkers)) '()) - (for-each (lambda (spec) - (run-checkers (specification->package spec) checkers)) - args)))) + (checkers (or (assoc-ref opts 'checkers) %all-checkers))) + (cond + ((assoc-ref opts 'list?) + (list-checkers-and-exit checkers)) + ((null? args) + (fold-packages (lambda (p r) (run-checkers p checkers)) '())) + (else + (for-each (lambda (spec) + (run-checkers (specification->package spec) checkers)) + args))))) -- 2.22.0 From debbugs-submit-bounces@debbugs.gnu.org Mon Jul 15 15:46:32 2019 Received: (at 35790) by debbugs.gnu.org; 15 Jul 2019 19:46:33 +0000 Received: from localhost ([127.0.0.1]:49193 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1hn6vf-0000EV-Dq for submit@debbugs.gnu.org; Mon, 15 Jul 2019 15:46:32 -0400 Received: from mira.cbaines.net ([212.71.252.8]:45784) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1hn6vA-0000Ce-8g for 35790@debbugs.gnu.org; Mon, 15 Jul 2019 15:46:08 -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 B28D6171C8 for <35790@debbugs.gnu.org>; Mon, 15 Jul 2019 20:45:58 +0100 (BST) Received: from localhost (localhost [local]) by localhost (OpenSMTPD) with ESMTPA id bfc53cd4 for <35790@debbugs.gnu.org>; Mon, 15 Jul 2019 19:45:58 +0000 (UTC) From: Christopher Baines To: 35790@debbugs.gnu.org Subject: [PATCH 3/4] lint: Move the linting code to a different module. Date: Mon, 15 Jul 2019 20:45:57 +0100 Message-Id: <20190715194558.13804-3-mail@cbaines.net> X-Mailer: git-send-email 2.22.0 In-Reply-To: <20190715194558.13804-1-mail@cbaines.net> References: <87k1cjr6vv.fsf@gnu.org> <20190715194558.13804-1-mail@cbaines.net> MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit X-Spam-Score: 0.0 (/) X-Debbugs-Envelope-To: 35790 X-BeenThere: debbugs-submit@debbugs.gnu.org X-Mailman-Version: 2.1.18 Precedence: list List-Id: List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: debbugs-submit-bounces@debbugs.gnu.org Sender: "Debbugs-submit" To try and move towards making programatic access to the linting code easier, this commit separates out the linting script, from the linting functionality that it uses. * guix/scripts/lint.scm (emit-warnings): Alter to to not use match-lambda, as isn't accessible. (, lint-warning, make-lint-warning, lint-warning?, lint-warning-message, lint-warning-message-text, lint-warning-message-data, lint-warning-location, package-file, %make-warning make-warning, , lint-checker, make-lint-checker, lint-checker?, lint-checker-name, lint-checker-description, lint-checker-check, properly-starts-sentance?, starts-with-abbreviation?, %quoted-identifier-rx, check-description-style, package-input-intersection, check-inputs-should-be-native, check-inputs-should-not-be-an-input-at-all, package-name-regexp, check-synopsis-style, probe-uri, tls-certificate-error-string, validate-uri, check-home-page, %distro-directory, check-patch-file-names, escape-quotes, official-gnu-packages*, check-gnu-synopsis+description, origin-uris, check-source, check-source-file-name, check-source-unstable-tarball, check-mirror-url, check-github-url, check-derivation, check-license, call-with-networking-fail-safe, with-networking-fail-safe, current-vulnerabilities*, package-vulnerabilities, check-vulnerabilities, check-for-updates, report-tabulations, report-trailing-white-space, report-long-line, %hanging-paren-rx, report-lone-parantheses, %formatting-reporters, report-formatting-issues, check-formatting, %checkers): Move to… * guix/lint.scm: … here * po/guix/POTFILES.in: Add guix/lint.scm. * Makefile.am: Add guix/lint.scm. * tests/lint.scm: Change to import (guix lint), rather than (guix scripts lint). --- Makefile.am | 1 + guix/lint.scm | 1222 +++++++++++++++++++++++++++++++++++++++++ guix/scripts/lint.scm | 1220 +--------------------------------------- po/guix/POTFILES.in | 1 + tests/lint.scm | 2 +- 5 files changed, 1244 insertions(+), 1202 deletions(-) create mode 100644 guix/lint.scm diff --git a/Makefile.am b/Makefile.am index bb7156458c..b63c55d784 100644 --- a/Makefile.am +++ b/Makefile.am @@ -98,6 +98,7 @@ MODULES = \ guix/self.scm \ guix/upstream.scm \ guix/licenses.scm \ + guix/lint.scm \ guix/glob.scm \ guix/git.scm \ guix/graph.scm \ diff --git a/guix/lint.scm b/guix/lint.scm new file mode 100644 index 0000000000..c2c0914958 --- /dev/null +++ b/guix/lint.scm @@ -0,0 +1,1222 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2014 Cyril Roelandt +;;; Copyright © 2014, 2015 Eric Bavier +;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018, 2019 Ludovic Courtès +;;; Copyright © 2015, 2016 Mathieu Lirzin +;;; Copyright © 2016 Danny Milosavljevic +;;; Copyright © 2016 Hartmut Goebel +;;; Copyright © 2017 Alex Kost +;;; Copyright © 2017 Tobias Geerinckx-Rice +;;; Copyright © 2017, 2018 Efraim Flashner +;;; Copyright © 2018, 2019 Arun Isaac +;;; +;;; This file is part of GNU Guix. +;;; +;;; GNU Guix is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; GNU Guix is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with GNU Guix. If not, see . + +(define-module (guix lint) + #:use-module ((guix store) #:hide (close-connection)) + #:use-module (guix base32) + #:use-module (guix diagnostics) + #:use-module (guix download) + #:use-module (guix ftp-client) + #:use-module (guix http-client) + #:use-module (guix packages) + #:use-module (guix i18n) + #:use-module (guix licenses) + #:use-module (guix records) + #:use-module (guix grafts) + #:use-module (guix upstream) + #:use-module (guix utils) + #:use-module (guix memoization) + #:use-module (guix scripts) + #:use-module ((guix ui) #:select (texi->plain-text fill-paragraph)) + #:use-module (guix gnu-maintenance) + #:use-module (guix monads) + #:use-module (guix cve) + #:use-module (gnu packages) + #:use-module (ice-9 match) + #:use-module (ice-9 regex) + #:use-module (ice-9 format) + #:use-module (web client) + #:use-module (web uri) + #:use-module ((guix build download) + #:select (maybe-expand-mirrors + (open-connection-for-uri + . guix:open-connection-for-uri) + close-connection)) + #:use-module (web request) + #:use-module (web response) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-6) ;Unicode string ports + #:use-module (srfi srfi-9) + #:use-module (srfi srfi-11) + #:use-module (srfi srfi-26) + #:use-module (srfi srfi-34) + #:use-module (srfi srfi-35) + #:use-module (ice-9 rdelim) + #:export (check-description-style + check-inputs-should-be-native + check-inputs-should-not-be-an-input-at-all + check-patch-file-names + check-synopsis-style + check-derivation + check-home-page + check-source + check-source-file-name + check-source-unstable-tarball + check-mirror-url + check-github-url + check-license + check-vulnerabilities + check-for-updates + check-formatting + + lint-warning + lint-warning? + lint-warning-package + lint-warning-message + lint-warning-message-text + lint-warning-message-data + lint-warning-location + + %checkers + + lint-checker + lint-checker? + lint-checker-name + lint-checker-description + lint-checker-check)) + + +;;; +;;; Warnings +;;; + +(define-record-type* + lint-warning make-lint-warning + lint-warning? + (package lint-warning-package) + (message-text lint-warning-message-text) + (message-data lint-warning-message-data + (default '())) + (location lint-warning-location + (default #f))) + +(define (lint-warning-message warning) + (apply format #f + (G_ (lint-warning-message-text warning)) + (lint-warning-message-data warning))) + +(define (package-file package) + (location-file + (package-location package))) + +(define* (%make-warning package message-text + #:optional (message-data '()) + #:key field location) + (make-lint-warning + package + message-text + message-data + (or location + (package-field-location package field) + (package-location package)))) + +(define-syntax make-warning + (syntax-rules (G_) + ((_ package (G_ message) rest ...) + (%make-warning package message rest ...)))) + + +;;; +;;; Checkers +;;; + +(define-record-type* + lint-checker make-lint-checker + lint-checker? + ;; TODO: add a 'certainty' field that shows how confident we are in the + ;; checker. Then allow users to only run checkers that have a certain + ;; 'certainty' level. + (name lint-checker-name) + (description lint-checker-description) + (check lint-checker-check)) + +(define (properly-starts-sentence? s) + (string-match "^[(\"'`[:upper:][:digit:]]" s)) + +(define (starts-with-abbreviation? s) + "Return #t if S starts with what looks like an abbreviation or acronym." + (string-match "^[A-Z][A-Z0-9]+\\>" s)) + +(define %quoted-identifier-rx + ;; A quoted identifier, like 'this'. + (make-regexp "['`][[:graph:]]+'")) + +(define (check-description-style package) + ;; Emit a warning if stylistic issues are found in the description of PACKAGE. + (define (check-not-empty description) + (if (string-null? description) + (list + (make-warning package + (G_ "description should not be empty") + #:field 'description)) + '())) + + (define (check-texinfo-markup description) + "Check that DESCRIPTION can be parsed as a Texinfo fragment. If the +markup is valid return a plain-text version of DESCRIPTION, otherwise #f." + (catch #t + (lambda () (texi->plain-text description)) + (lambda (keys . args) + (make-warning package + (G_ "Texinfo markup in description is invalid") + #:field 'description)))) + + (define (check-trademarks description) + "Check that DESCRIPTION does not contain '™' or '®' characters. See +http://www.gnu.org/prep/standards/html_node/Trademarks.html." + (match (string-index description (char-set #\™ #\®)) + ((and (? number?) index) + (list + (make-warning package + (G_ "description should not contain ~ +trademark sign '~a' at ~d") + (list (string-ref description index) index) + #:field 'description))) + (else '()))) + + (define (check-quotes description) + "Check whether DESCRIPTION contains single quotes and suggest @code." + (if (regexp-exec %quoted-identifier-rx description) + (list + (make-warning package + ;; TRANSLATORS: '@code' is Texinfo markup and must be kept + ;; as is. + (G_ "use @code or similar ornament instead of quotes") + #:field 'description)) + '())) + + (define (check-proper-start description) + (if (or (string-null? description) + (properly-starts-sentence? description) + (string-prefix-ci? (package-name package) description)) + '() + (list + (make-warning + package + (G_ "description should start with an upper-case letter or digit") + #:field 'description)))) + + (define (check-end-of-sentence-space description) + "Check that an end-of-sentence period is followed by two spaces." + (let ((infractions + (reverse (fold-matches + "\\. [A-Z]" description '() + (lambda (m r) + ;; Filter out matches of common abbreviations. + (if (find (lambda (s) + (string-suffix-ci? s (match:prefix m))) + '("i.e" "e.g" "a.k.a" "resp")) + r (cons (match:start m) r))))))) + (if (null? infractions) + '() + (list + (make-warning package + (G_ "sentences in description should be followed ~ +by two spaces; possible infraction~p at ~{~a~^, ~}") + (list (length infractions) + infractions) + #:field 'description))))) + + (let ((description (package-description package))) + (if (string? description) + (append + (check-not-empty description) + (check-quotes description) + (check-trademarks description) + ;; Use raw description for this because Texinfo rendering + ;; automatically fixes end of sentence space. + (check-end-of-sentence-space description) + (match (check-texinfo-markup description) + ((and warning (? lint-warning?)) (list warning)) + (plain-description + (check-proper-start plain-description)))) + (list + (make-warning package + (G_ "invalid description: ~s") + (list description) + #:field 'description))))) + +(define (package-input-intersection inputs-to-check input-names) + "Return the intersection between INPUTS-TO-CHECK, the list of input tuples +of a package, and INPUT-NAMES, a list of package specifications such as +\"glib:bin\"." + (match inputs-to-check + (((labels packages . outputs) ...) + (filter-map (lambda (package output) + (and (package? package) + (let ((input (string-append + (package-name package) + (if (> (length output) 0) + (string-append ":" (car output)) + "")))) + (and (member input input-names) + input)))) + packages outputs)))) + +(define (check-inputs-should-be-native package) + ;; Emit a warning if some inputs of PACKAGE are likely to belong to its + ;; native inputs. + (let ((inputs (package-inputs package)) + (input-names + '("pkg-config" + "cmake" + "extra-cmake-modules" + "glib:bin" + "intltool" + "itstool" + "qttools" + "python-coverage" "python2-coverage" + "python-cython" "python2-cython" + "python-docutils" "python2-docutils" + "python-mock" "python2-mock" + "python-nose" "python2-nose" + "python-pbr" "python2-pbr" + "python-pytest" "python2-pytest" + "python-pytest-cov" "python2-pytest-cov" + "python-setuptools-scm" "python2-setuptools-scm" + "python-sphinx" "python2-sphinx"))) + (map (lambda (input) + (make-warning + package + (G_ "'~a' should probably be a native input") + (list input) + #:field 'inputs)) + (package-input-intersection inputs input-names)))) + +(define (check-inputs-should-not-be-an-input-at-all package) + ;; Emit a warning if some inputs of PACKAGE are likely to should not be + ;; an input at all. + (let ((input-names '("python-setuptools" + "python2-setuptools" + "python-pip" + "python2-pip"))) + (map (lambda (input) + (make-warning + package + (G_ "'~a' should probably not be an input at all") + (list input) + #:field 'inputs)) + (package-input-intersection (package-direct-inputs package) + input-names)))) + +(define (package-name-regexp package) + "Return a regexp that matches PACKAGE's name as a word at the beginning of a +line." + (make-regexp (string-append "^" (regexp-quote (package-name package)) + "\\>") + regexp/icase)) + +(define (check-synopsis-style package) + ;; Emit a warning if stylistic issues are found in the synopsis of PACKAGE. + (define (check-final-period synopsis) + ;; Synopsis should not end with a period, except for some special cases. + (if (and (string-suffix? "." synopsis) + (not (string-suffix? "etc." synopsis))) + (list + (make-warning package + (G_ "no period allowed at the end of the synopsis") + #:field 'synopsis)) + '())) + + (define check-start-article + ;; Skip this check for GNU packages, as suggested by Karl Berry's reply to + ;; . + (if (false-if-exception (gnu-package? package)) + (const '()) + (lambda (synopsis) + (if (or (string-prefix-ci? "A " synopsis) + (string-prefix-ci? "An " synopsis)) + (list + (make-warning package + (G_ "no article allowed at the beginning of \ +the synopsis") + #:field 'synopsis)) + '())))) + + (define (check-synopsis-length synopsis) + (if (>= (string-length synopsis) 80) + (list + (make-warning package + (G_ "synopsis should be less than 80 characters long") + #:field 'synopsis)) + '())) + + (define (check-proper-start synopsis) + (if (properly-starts-sentence? synopsis) + '() + (list + (make-warning package + (G_ "synopsis should start with an upper-case letter or digit") + #:field 'synopsis)))) + + (define (check-start-with-package-name synopsis) + (if (and (regexp-exec (package-name-regexp package) synopsis) + (not (starts-with-abbreviation? synopsis))) + (list + (make-warning package + (G_ "synopsis should not start with the package name") + #:field 'synopsis)) + '())) + + (define (check-texinfo-markup synopsis) + "Check that SYNOPSIS can be parsed as a Texinfo fragment. If the +markup is valid return a plain-text version of SYNOPSIS, otherwise #f." + (catch #t + (lambda () + (texi->plain-text synopsis) + '()) + (lambda (keys . args) + (list + (make-warning package + (G_ "Texinfo markup in synopsis is invalid") + #:field 'synopsis))))) + + (define checks + (list check-proper-start + check-final-period + check-start-article + check-start-with-package-name + check-synopsis-length + check-texinfo-markup)) + + (match (package-synopsis package) + ("" + (list + (make-warning package + (G_ "synopsis should not be empty") + #:field 'synopsis))) + ((? string? synopsis) + (append-map + (lambda (proc) + (proc synopsis)) + checks)) + (invalid + (list + (make-warning package + (G_ "invalid synopsis: ~s") + (list invalid) + #:field 'synopsis))))) + +(define* (probe-uri uri #:key timeout) + "Probe URI, a URI object, and return two values: a symbol denoting the +probing status, such as 'http-response' when we managed to get an HTTP +response from URI, and additional details, such as the actual HTTP response. + +TIMEOUT is the maximum number of seconds (possibly an inexact number) to wait +for connections to complete; when TIMEOUT is #f, wait as long as needed." + (define headers + '((User-Agent . "GNU Guile") + (Accept . "*/*"))) + + (let loop ((uri uri) + (visited '())) + (match (uri-scheme uri) + ((or 'http 'https) + (catch #t + (lambda () + (let ((port (guix:open-connection-for-uri + uri #:timeout timeout)) + (request (build-request uri #:headers headers))) + (define response + (dynamic-wind + (const #f) + (lambda () + (write-request request port) + (force-output port) + (read-response port)) + (lambda () + (close-connection port)))) + + (case (response-code response) + ((302 ; found (redirection) + 303 ; see other + 307 ; temporary redirection + 308) ; permanent redirection + (let ((location (response-location response))) + (if (or (not location) (member location visited)) + (values 'http-response response) + (loop location (cons location visited))))) ;follow the redirect + ((301) ; moved permanently + (let ((location (response-location response))) + ;; Return RESPONSE, unless the final response as we follow + ;; redirects is not 200. + (if location + (let-values (((status response2) + (loop location (cons location visited)))) + (case status + ((http-response) + (values 'http-response + (if (= 200 (response-code response2)) + response + response2))) + (else + (values status response2)))) + (values 'http-response response)))) ;invalid redirect + (else + (values 'http-response response))))) + (lambda (key . args) + (case key + ((bad-header bad-header-component) + ;; This can happen if the server returns an invalid HTTP header, + ;; as is the case with the 'Date' header at sqlite.org. + (values 'invalid-http-response #f)) + ((getaddrinfo-error system-error + gnutls-error tls-certificate-error) + (values key args)) + (else + (apply throw key args)))))) + ('ftp + (catch #t + (lambda () + (let ((conn (ftp-open (uri-host uri) #:timeout timeout))) + (define response + (dynamic-wind + (const #f) + (lambda () + (ftp-chdir conn (dirname (uri-path uri))) + (ftp-size conn (basename (uri-path uri)))) + (lambda () + (ftp-close conn)))) + (values 'ftp-response '(ok)))) + (lambda (key . args) + (case key + ((ftp-error) + (values 'ftp-response `(error ,@args))) + ((getaddrinfo-error system-error gnutls-error) + (values key args)) + (else + (apply throw key args)))))) + (_ + (values 'unknown-protocol #f))))) + +(define (tls-certificate-error-string args) + "Return a string explaining the 'tls-certificate-error' arguments ARGS." + (call-with-output-string + (lambda (port) + (print-exception port #f + 'tls-certificate-error args)))) + +(define (validate-uri uri package field) + "Return #t if the given URI can be reached, otherwise return a warning for +PACKAGE mentionning the FIELD." + (let-values (((status argument) + (probe-uri uri #:timeout 3))) ;wait at most 3 seconds + (case status + ((http-response) + (cond ((= 200 (response-code argument)) + (match (response-content-length argument) + ((? number? length) + ;; As of July 2016, SourceForge returns 200 (instead of 404) + ;; with a small HTML page upon failure. Attempt to detect + ;; such malicious behavior. + (or (> length 1000) + (make-warning package + (G_ "URI ~a returned \ +suspiciously small file (~a bytes)") + (list (uri->string uri) + length) + #:field field))) + (_ #t))) + ((= 301 (response-code argument)) + (if (response-location argument) + (make-warning package + (G_ "permanent redirect from ~a to ~a") + (list (uri->string uri) + (uri->string + (response-location argument))) + #:field field) + (make-warning package + (G_ "invalid permanent redirect \ +from ~a") + (list (uri->string uri)) + #:field field))) + (else + (make-warning package + (G_ "URI ~a not reachable: ~a (~s)") + (list (uri->string uri) + (response-code argument) + (response-reason-phrase argument)) + #:field field)))) + ((ftp-response) + (match argument + (('ok) #t) + (('error port command code message) + (make-warning package + (G_ "URI ~a not reachable: ~a (~s)") + (list (uri->string uri) + code (string-trim-both message)) + #:field field)))) + ((getaddrinfo-error) + (make-warning package + (G_ "URI ~a domain not found: ~a") + (list (uri->string uri) + (gai-strerror (car argument))) + #:field field)) + ((system-error) + (make-warning package + (G_ "URI ~a unreachable: ~a") + (list (uri->string uri) + (strerror + (system-error-errno + (cons status argument)))) + #:field field)) + ((tls-certificate-error) + (make-warning package + (G_ "TLS certificate error: ~a") + (list (tls-certificate-error-string argument)) + #:field field)) + ((invalid-http-response gnutls-error) + ;; Probably a misbehaving server; ignore. + #f) + ((unknown-protocol) ;nothing we can do + #f) + (else + (error "internal linter error" status))))) + +(define (check-home-page package) + "Emit a warning if PACKAGE has an invalid 'home-page' field, or if that +'home-page' is not reachable." + (let ((uri (and=> (package-home-page package) string->uri))) + (cond + ((uri? uri) + (match (validate-uri uri package 'home-page) + ((and (? lint-warning? warning) warning) + (list warning)) + (_ '()))) + ((not (package-home-page package)) + (if (or (string-contains (package-name package) "bootstrap") + (string=? (package-name package) "ld-wrapper")) + '() + (list + (make-warning package + (G_ "invalid value for home page") + #:field 'home-page)))) + (else + (list + (make-warning package + (G_ "invalid home page URL: ~s") + (list (package-home-page package)) + #:field 'home-page)))))) + +(define %distro-directory + (mlambda () + (dirname (search-path %load-path "gnu.scm")))) + +(define (check-patch-file-names package) + "Emit a warning if the patches requires by PACKAGE are badly named or if the +patch could not be found." + (guard (c ((message-condition? c) ;raised by 'search-patch' + (list + ;; Use %make-warning, as condition-mesasge is already + ;; translated. + (%make-warning package (condition-message c) + #:field 'patch-file-names)))) + (define patches + (or (and=> (package-source package) origin-patches) + '())) + + (append + (if (every (match-lambda ;patch starts with package name? + ((? string? patch) + (and=> (string-contains (basename patch) + (package-name package)) + zero?)) + (_ #f)) ;must be an or something like that. + patches) + '() + (list + (make-warning + package + (G_ "file names of patches should start with the package name") + #:field 'patch-file-names))) + + ;; Check whether we're reaching tar's maximum file name length. + (let ((prefix (string-length (%distro-directory))) + (margin (string-length "guix-0.13.0-10-123456789/")) + (max 99)) + (filter-map (match-lambda + ((? string? patch) + (if (> (+ margin (if (string-prefix? (%distro-directory) + patch) + (- (string-length patch) prefix) + (string-length patch))) + max) + (make-warning + package + (G_ "~a: file name is too long") + (list (basename patch)) + #:field 'patch-file-names) + #f)) + (_ #f)) + patches))))) + +(define (escape-quotes str) + "Replace any quote character in STR by an escaped quote character." + (list->string + (string-fold-right (lambda (chr result) + (match chr + (#\" (cons* #\\ #\"result)) + (_ (cons chr result)))) + '() + str))) + +(define official-gnu-packages* + (mlambda () + "A memoizing version of 'official-gnu-packages' that returns the empty +list when something goes wrong, such as a networking issue." + (let ((gnus (false-if-exception (official-gnu-packages)))) + (or gnus '())))) + +(define (check-gnu-synopsis+description package) + "Make sure that, if PACKAGE is a GNU package, it uses the synopsis and +descriptions maintained upstream." + (match (find (lambda (descriptor) + (string=? (gnu-package-name descriptor) + (package-name package))) + (official-gnu-packages*)) + (#f ;not a GNU package, so nothing to do + '()) + (descriptor ;a genuine GNU package + (append + (let ((upstream (gnu-package-doc-summary descriptor)) + (downstream (package-synopsis package))) + (if (and upstream + (or (not (string? downstream)) + (not (string=? upstream downstream)))) + (list + (make-warning package + (G_ "proposed synopsis: ~s~%") + (list upstream) + #:field 'synopsis)) + '())) + + (let ((upstream (gnu-package-doc-description descriptor)) + (downstream (package-description package))) + (if (and upstream + (or (not (string? downstream)) + (not (string=? (fill-paragraph upstream 100) + (fill-paragraph downstream 100))))) + (list + (make-warning + package + (G_ "proposed description:~% \"~a\"~%") + (list (fill-paragraph (escape-quotes upstream) 77 7)) + #:field 'description)) + '())))))) + +(define (origin-uris origin) + "Return the list of URIs (strings) for ORIGIN." + (match (origin-uri origin) + ((? string? uri) + (list uri)) + ((uris ...) + uris))) + +(define (check-source package) + "Emit a warning if PACKAGE has an invalid 'source' field, or if that +'source' is not reachable." + (define (warnings-for-uris uris) + (filter lint-warning? + (map + (lambda (uri) + (validate-uri uri package 'source)) + (append-map (cut maybe-expand-mirrors <> %mirrors) + uris)))) + + (let ((origin (package-source package))) + (if (and origin + (eqv? (origin-method origin) url-fetch)) + (let* ((uris (map string->uri (origin-uris origin))) + (warnings (warnings-for-uris uris))) + + ;; Just make sure that at least one of the URIs is valid. + (if (eq? (length uris) (length warnings)) + ;; When everything fails, report all of WARNINGS, otherwise don't + ;; report anything. + ;; + ;; XXX: Ideally we'd still allow warnings to be raised if *some* + ;; URIs are unreachable, but distinguish that from the error case + ;; where *all* the URIs are unreachable. + (cons* + (make-warning package + (G_ "all the source URIs are unreachable:") + #:field 'source) + warnings) + '())) + '()))) + +(define (check-source-file-name package) + "Emit a warning if PACKAGE's origin has no meaningful file name." + (define (origin-file-name-valid? origin) + ;; Return #f if the source file name contains only a version or is #f; + ;; indicates that the origin needs a 'file-name' field. + (let ((file-name (origin-actual-file-name origin)) + (version (package-version package))) + (and file-name + ;; Common in many projects is for the filename to start + ;; with a "v" followed by the version, + ;; e.g. "v3.2.0.tar.gz". + (not (string-match (string-append "^v?" version) file-name))))) + + (let ((origin (package-source package))) + (if (or (not origin) (origin-file-name-valid? origin)) + '() + (list + (make-warning package + (G_ "the source file name should contain the package name") + #:field 'source))))) + +(define (check-source-unstable-tarball package) + "Emit a warning if PACKAGE's source is an autogenerated tarball." + (define (check-source-uri uri) + (if (and (string=? (uri-host (string->uri uri)) "github.com") + (match (split-and-decode-uri-path + (uri-path (string->uri uri))) + ((_ _ "archive" _ ...) #t) + (_ #f))) + (make-warning package + (G_ "the source URI should not be an autogenerated tarball") + #:field 'source) + #f)) + + (let ((origin (package-source package))) + (if (and (origin? origin) + (eqv? (origin-method origin) url-fetch)) + (filter-map check-source-uri + (origin-uris origin)) + '()))) + +(define (check-mirror-url package) + "Check whether PACKAGE uses source URLs that should be 'mirror://'." + (define (check-mirror-uri uri) ;XXX: could be optimized + (let loop ((mirrors %mirrors)) + (match mirrors + (() + #f) + (((mirror-id mirror-urls ...) rest ...) + (match (find (cut string-prefix? <> uri) mirror-urls) + (#f + (loop rest)) + (prefix + (make-warning package + (G_ "URL should be \ +'mirror://~a/~a'") + (list mirror-id + (string-drop uri (string-length prefix))) + #:field 'source))))))) + + (let ((origin (package-source package))) + (if (and (origin? origin) + (eqv? (origin-method origin) url-fetch)) + (let ((uris (origin-uris origin))) + (filter-map check-mirror-uri uris)) + '()))) + +(define* (check-github-url package #:key (timeout 3)) + "Check whether PACKAGE uses source URLs that redirect to GitHub." + (define (follow-redirect url) + (let* ((uri (string->uri url)) + (port (guix:open-connection-for-uri uri #:timeout timeout)) + (response (http-head uri #:port port))) + (close-port port) + (case (response-code response) + ((301 302) + (uri->string (assoc-ref (response-headers response) 'location))) + (else #f)))) + + (define (follow-redirects-to-github uri) + (cond + ((string-prefix? "https://github.com/" uri) uri) + ((string-prefix? "http" uri) + (and=> (follow-redirect uri) follow-redirects-to-github)) + ;; Do not attempt to follow redirects on URIs other than http and https + ;; (such as mirror, file) + (else #f))) + + (let ((origin (package-source package))) + (if (and (origin? origin) + (eqv? (origin-method origin) url-fetch)) + (filter-map + (lambda (uri) + (and=> (follow-redirects-to-github uri) + (lambda (github-uri) + (if (string=? github-uri uri) + #f + (make-warning + package + (G_ "URL should be '~a'") + (list github-uri) + #:field 'source))))) + (origin-uris origin)) + '()))) + +(define (check-derivation package) + "Emit a warning if we fail to compile PACKAGE to a derivation." + (define (try system) + (catch #t + (lambda () + (guard (c ((store-protocol-error? c) + (make-warning package + (G_ "failed to create ~a derivation: ~a") + (list system + (store-protocol-error-message c)))) + ((message-condition? c) + (make-warning package + (G_ "failed to create ~a derivation: ~a") + (list system + (condition-message c))))) + (with-store store + ;; Disable grafts since it can entail rebuilds. + (parameterize ((%graft? #f)) + (package-derivation store package system #:graft? #f) + + ;; If there's a replacement, make sure we can compute its + ;; derivation. + (match (package-replacement package) + (#f #t) + (replacement + (package-derivation store replacement system + #:graft? #f))))))) + (lambda args + (make-warning package + (G_ "failed to create ~a derivation: ~s") + (list system args))))) + + (filter lint-warning? + (map try (package-supported-systems package)))) + +(define (check-license package) + "Warn about type errors of the 'license' field of PACKAGE." + (match (package-license package) + ((or (? license?) + ((? license?) ...)) + '()) + (x + (list + (make-warning package (G_ "invalid license field") + #:field 'license))))) + +(define (call-with-networking-fail-safe message error-value proc) + "Call PROC catching any network-related errors. Upon a networking error, +display a message including MESSAGE and return ERROR-VALUE." + (guard (c ((http-get-error? c) + (warning (G_ "~a: HTTP GET error for ~a: ~a (~s)~%") + message + (uri->string (http-get-error-uri c)) + (http-get-error-code c) + (http-get-error-reason c)) + error-value)) + (catch #t + proc + (match-lambda* + (('getaddrinfo-error errcode) + (warning (G_ "~a: host lookup failure: ~a~%") + message + (gai-strerror errcode)) + error-value) + (('tls-certificate-error args ...) + (warning (G_ "~a: TLS certificate error: ~a") + message + (tls-certificate-error-string args)) + error-value) + (args + (apply throw args)))))) + +(define-syntax-rule (with-networking-fail-safe message error-value exp ...) + (call-with-networking-fail-safe message error-value + (lambda () exp ...))) + +(define (current-vulnerabilities*) + "Like 'current-vulnerabilities', but return the empty list upon networking +or HTTP errors. This allows network-less operation and makes problems with +the NIST server non-fatal." + (with-networking-fail-safe (G_ "while retrieving CVE vulnerabilities") + '() + (current-vulnerabilities))) + +(define package-vulnerabilities + (let ((lookup (delay (vulnerabilities->lookup-proc + (current-vulnerabilities*))))) + (lambda (package) + "Return a list of vulnerabilities affecting PACKAGE." + ;; First we retrieve the Common Platform Enumeration (CPE) name and + ;; version for PACKAGE, then we can pass them to LOOKUP. + (let ((name (or (assoc-ref (package-properties package) + 'cpe-name) + (package-name package))) + (version (or (assoc-ref (package-properties package) + 'cpe-version) + (package-version package)))) + ((force lookup) name version))))) + +(define (check-vulnerabilities package) + "Check for known vulnerabilities for PACKAGE." + (let ((package (or (package-replacement package) package))) + (match (package-vulnerabilities package) + (() + '()) + ((vulnerabilities ...) + (let* ((patched (package-patched-vulnerabilities package)) + (known-safe (or (assq-ref (package-properties package) + 'lint-hidden-cve) + '())) + (unpatched (remove (lambda (vuln) + (let ((id (vulnerability-id vuln))) + (or (member id patched) + (member id known-safe)))) + vulnerabilities))) + (if (null? unpatched) + '() + (list + (make-warning + package + (G_ "probably vulnerable to ~a") + (list (string-join (map vulnerability-id unpatched) + ", ")))))))))) + +(define (check-for-updates package) + "Check if there is an update available for PACKAGE." + (match (with-networking-fail-safe + (G_ "while retrieving upstream info for '~a'") + (list (package-name package)) + #f + (package-latest-release* package (force %updaters))) + ((? upstream-source? source) + (if (version>? (upstream-source-version source) + (package-version package)) + (list + (make-warning package + (G_ "can be upgraded to ~a") + (list (upstream-source-version source)) + #:field 'version)) + '())) + (#f '()))) ; cannot find newer upstream release + + +;;; +;;; Source code formatting. +;;; + +(define (report-tabulations package line line-number) + "Warn about tabulations found in LINE." + (match (string-index line #\tab) + (#f #t) + (index + (make-warning package + (G_ "tabulation on line ~a, column ~a") + (list line-number index) + #:location + (location (package-file package) + line-number + index))))) + +(define (report-trailing-white-space package line line-number) + "Warn about trailing white space in LINE." + (unless (or (string=? line (string-trim-right line)) + (string=? line (string #\page))) + (make-warning package + (G_ "trailing white space on line ~a") + (list line-number) + #:location + (location (package-file package) + line-number + 0)))) + +(define (report-long-line package line line-number) + "Emit a warning if LINE is too long." + ;; Note: We don't warn at 80 characters because sometimes hashes and URLs + ;; make it hard to fit within that limit and we want to avoid making too + ;; much noise. + (when (> (string-length line) 90) + (make-warning package + (G_ "line ~a is way too long (~a characters)") + (list line-number (string-length line)) + #:location + (location (package-file package) + line-number + 0)))) + +(define %hanging-paren-rx + (make-regexp "^[[:blank:]]*[()]+[[:blank:]]*$")) + +(define (report-lone-parentheses package line line-number) + "Emit a warning if LINE contains hanging parentheses." + (when (regexp-exec %hanging-paren-rx line) + (make-warning package + (G_ "parentheses feel lonely, \ +move to the previous or next line") + (list line-number) + #:location + (location (package-file package) + line-number + 0)))) + +(define %formatting-reporters + ;; List of procedures that report formatting issues. These are not separate + ;; checkers because they would need to re-read the file. + (list report-tabulations + report-trailing-white-space + report-long-line + report-lone-parentheses)) + +(define* (report-formatting-issues package file starting-line + #:key (reporters %formatting-reporters)) + "Report white-space issues in FILE starting from STARTING-LINE, and report +them for PACKAGE." + (define (sexp-last-line port) + ;; Return the last line of the sexp read from PORT or an estimate thereof. + (define &failure (list 'failure)) + + (let ((start (ftell port)) + (start-line (port-line port)) + (sexp (catch 'read-error + (lambda () (read port)) + (const &failure)))) + (let ((line (port-line port))) + (seek port start SEEK_SET) + (set-port-line! port start-line) + (if (eq? sexp &failure) + (+ start-line 60) ;conservative estimate + line)))) + + (call-with-input-file file + (lambda (port) + (let loop ((line-number 1) + (last-line #f) + (warnings '())) + (let ((line (read-line port))) + (if (or (eof-object? line) + (and last-line (> line-number last-line))) + warnings + (if (and (= line-number starting-line) + (not last-line)) + (loop (+ 1 line-number) + (+ 1 (sexp-last-line port)) + warnings) + (loop (+ 1 line-number) + last-line + (append + warnings + (if (< line-number starting-line) + '() + (filter + lint-warning? + (map (lambda (report) + (report package line line-number)) + reporters)))))))))))) + +(define (check-formatting package) + "Check the formatting of the source code of PACKAGE." + (let ((location (package-location package))) + (if location + (and=> (search-path %load-path (location-file location)) + (lambda (file) + ;; Report issues starting from the line before the 'package' + ;; form, which usually contains the 'define' form. + (report-formatting-issues package file + (- (location-line location) 1)))) + '()))) + + +;;; +;;; List of checkers. +;;; + +(define %checkers + (list + (lint-checker + (name 'description) + (description "Validate package descriptions") + (check check-description-style)) + (lint-checker + (name 'gnu-description) + (description "Validate synopsis & description of GNU packages") + (check check-gnu-synopsis+description)) + (lint-checker + (name 'inputs-should-be-native) + (description "Identify inputs that should be native inputs") + (check check-inputs-should-be-native)) + (lint-checker + (name 'inputs-should-not-be-input) + (description "Identify inputs that shouldn't be inputs at all") + (check check-inputs-should-not-be-an-input-at-all)) + (lint-checker + (name 'patch-file-names) + (description "Validate file names and availability of patches") + (check check-patch-file-names)) + (lint-checker + (name 'home-page) + (description "Validate home-page URLs") + (check check-home-page)) + (lint-checker + (name 'license) + ;; TRANSLATORS: is the name of a data type and must not be + ;; translated. + (description "Make sure the 'license' field is a \ +or a list thereof") + (check check-license)) + (lint-checker + (name 'source) + (description "Validate source URLs") + (check check-source)) + (lint-checker + (name 'mirror-url) + (description "Suggest 'mirror://' URLs") + (check check-mirror-url)) + (lint-checker + (name 'github-url) + (description "Suggest GitHub URLs") + (check check-github-url)) + (lint-checker + (name 'source-file-name) + (description "Validate file names of sources") + (check check-source-file-name)) + (lint-checker + (name 'source-unstable-tarball) + (description "Check for autogenerated tarballs") + (check check-source-unstable-tarball)) + (lint-checker + (name 'derivation) + (description "Report failure to compile a package to a derivation") + (check check-derivation)) + (lint-checker + (name 'synopsis) + (description "Validate package synopses") + (check check-synopsis-style)) + (lint-checker + (name 'cve) + (description "Check the Common Vulnerabilities and Exposures\ + (CVE) database") + (check check-vulnerabilities)) + (lint-checker + (name 'refresh) + (description "Check the package for new upstream releases") + (check check-for-updates)) + (lint-checker + (name 'formatting) + (description "Look for formatting issues in the source") + (check check-formatting)))) diff --git a/guix/scripts/lint.scm b/guix/scripts/lint.scm index 4eb7e0e200..1c46fba16b 100644 --- a/guix/scripts/lint.scm +++ b/guix/scripts/lint.scm @@ -26,1224 +26,32 @@ ;;; along with GNU Guix. If not, see . (define-module (guix scripts lint) - #:use-module ((guix store) #:hide (close-connection)) - #:use-module (guix base32) - #:use-module (guix download) - #:use-module (guix ftp-client) - #:use-module (guix http-client) #:use-module (guix packages) - #:use-module (guix licenses) - #:use-module (guix records) - #:use-module (guix grafts) + #:use-module (guix lint) #:use-module (guix ui) - #:use-module (guix upstream) - #:use-module (guix utils) - #:use-module (guix memoization) #:use-module (guix scripts) - #:use-module (guix gnu-maintenance) - #:use-module (guix monads) - #:use-module (guix cve) #:use-module (gnu packages) #:use-module (ice-9 match) - #:use-module (ice-9 regex) #:use-module (ice-9 format) - #:use-module (web client) - #:use-module (web uri) - #:use-module ((guix build download) - #:select (maybe-expand-mirrors - (open-connection-for-uri - . guix:open-connection-for-uri) - close-connection)) - #:use-module (web request) - #:use-module (web response) #:use-module (srfi srfi-1) - #:use-module (srfi srfi-6) ;Unicode string ports - #:use-module (srfi srfi-9) - #:use-module (srfi srfi-11) - #:use-module (srfi srfi-26) - #:use-module (srfi srfi-34) - #:use-module (srfi srfi-35) #:use-module (srfi srfi-37) - #:use-module (ice-9 rdelim) #:export (guix-lint - check-description-style - check-inputs-should-be-native - check-inputs-should-not-be-an-input-at-all - check-patch-file-names - check-synopsis-style - check-derivation - check-home-page - check-source - check-source-file-name - check-source-unstable-tarball - check-mirror-url - check-github-url - check-license - check-vulnerabilities - check-for-updates - check-formatting - run-checkers - - lint-warning - lint-warning? - lint-warning-package - lint-warning-message - lint-warning-message-text - lint-warning-message-data - lint-warning-location - - %checkers - lint-checker - lint-checker? - lint-checker-name - lint-checker-description - lint-checker-check)) - - -;;; -;;; Warnings -;;; - -(define-record-type* - lint-warning make-lint-warning - lint-warning? - (package lint-warning-package) - (message-text lint-warning-message-text) - (message-data lint-warning-message-data - (default '())) - (location lint-warning-location - (default #f))) - -(define (lint-warning-message warning) - (apply format #f - (G_ (lint-warning-message-text warning)) - (lint-warning-message-data warning))) - -(define (package-file package) - (location-file - (package-location package))) - -(define* (%make-warning package message-text - #:optional (message-data '()) - #:key field location) - (make-lint-warning - package - message-text - message-data - (or location - (package-field-location package field) - (package-location package)))) - -(define-syntax make-warning - (syntax-rules (G_) - ((_ package (G_ message) rest ...) - (%make-warning package message rest ...)))) + run-checkers)) (define (emit-warnings warnings) ;; Emit a warning about PACKAGE, printing the location of FIELD if it is ;; given, the location of PACKAGE otherwise, the full name of PACKAGE and the ;; provided MESSAGE. (for-each - (match-lambda - (($ package message-text message-data loc) - (format (guix-warning-port) "~a: ~a@~a: ~a~%" - (location->string loc) - (package-name package) (package-version package) - (apply format #f (G_ message-text) message-data)))) + (lambda (lint-warning) + (let ((package (lint-warning-package lint-warning)) + (loc (lint-warning-location lint-warning))) + (format (guix-warning-port) "~a: ~a@~a: ~a~%" + (location->string loc) + (package-name package) (package-version package) + (lint-warning-message lint-warning)))) warnings)) - -;;; -;;; Checkers -;;; - -(define-record-type* - lint-checker make-lint-checker - lint-checker? - ;; TODO: add a 'certainty' field that shows how confident we are in the - ;; checker. Then allow users to only run checkers that have a certain - ;; 'certainty' level. - (name lint-checker-name) - (description lint-checker-description) - (check lint-checker-check)) - -(define (list-checkers-and-exit) - ;; Print information about all available checkers and exit. - (format #t (G_ "Available checkers:~%")) - (for-each (lambda (checker) - (format #t "- ~a: ~a~%" - (lint-checker-name checker) - (G_ (lint-checker-description checker)))) - %checkers) - (exit 0)) - -(define (properly-starts-sentence? s) - (string-match "^[(\"'`[:upper:][:digit:]]" s)) - -(define (starts-with-abbreviation? s) - "Return #t if S starts with what looks like an abbreviation or acronym." - (string-match "^[A-Z][A-Z0-9]+\\>" s)) - -(define %quoted-identifier-rx - ;; A quoted identifier, like 'this'. - (make-regexp "['`][[:graph:]]+'")) - -(define (check-description-style package) - ;; Emit a warning if stylistic issues are found in the description of PACKAGE. - (define (check-not-empty description) - (if (string-null? description) - (list - (make-warning package - (G_ "description should not be empty") - #:field 'description)) - '())) - - (define (check-texinfo-markup description) - "Check that DESCRIPTION can be parsed as a Texinfo fragment. If the -markup is valid return a plain-text version of DESCRIPTION, otherwise #f." - (catch #t - (lambda () (texi->plain-text description)) - (lambda (keys . args) - (make-warning package - (G_ "Texinfo markup in description is invalid") - #:field 'description)))) - - (define (check-trademarks description) - "Check that DESCRIPTION does not contain '™' or '®' characters. See -http://www.gnu.org/prep/standards/html_node/Trademarks.html." - (match (string-index description (char-set #\™ #\®)) - ((and (? number?) index) - (list - (make-warning package - (G_ "description should not contain ~ -trademark sign '~a' at ~d") - (list (string-ref description index) index) - #:field 'description))) - (else '()))) - - (define (check-quotes description) - "Check whether DESCRIPTION contains single quotes and suggest @code." - (if (regexp-exec %quoted-identifier-rx description) - (list - (make-warning package - ;; TRANSLATORS: '@code' is Texinfo markup and must be kept - ;; as is. - (G_ "use @code or similar ornament instead of quotes") - #:field 'description)) - '())) - - (define (check-proper-start description) - (if (or (string-null? description) - (properly-starts-sentence? description) - (string-prefix-ci? (package-name package) description)) - '() - (list - (make-warning - package - (G_ "description should start with an upper-case letter or digit") - #:field 'description)))) - - (define (check-end-of-sentence-space description) - "Check that an end-of-sentence period is followed by two spaces." - (let ((infractions - (reverse (fold-matches - "\\. [A-Z]" description '() - (lambda (m r) - ;; Filter out matches of common abbreviations. - (if (find (lambda (s) - (string-suffix-ci? s (match:prefix m))) - '("i.e" "e.g" "a.k.a" "resp")) - r (cons (match:start m) r))))))) - (if (null? infractions) - '() - (list - (make-warning package - (G_ "sentences in description should be followed ~ -by two spaces; possible infraction~p at ~{~a~^, ~}") - (list (length infractions) - infractions) - #:field 'description))))) - - (let ((description (package-description package))) - (if (string? description) - (append - (check-not-empty description) - (check-quotes description) - (check-trademarks description) - ;; Use raw description for this because Texinfo rendering - ;; automatically fixes end of sentence space. - (check-end-of-sentence-space description) - (match (check-texinfo-markup description) - ((and warning (? lint-warning?)) (list warning)) - (plain-description - (check-proper-start plain-description)))) - (list - (make-warning package - (G_ "invalid description: ~s") - (list description) - #:field 'description))))) - -(define (package-input-intersection inputs-to-check input-names) - "Return the intersection between INPUTS-TO-CHECK, the list of input tuples -of a package, and INPUT-NAMES, a list of package specifications such as -\"glib:bin\"." - (match inputs-to-check - (((labels packages . outputs) ...) - (filter-map (lambda (package output) - (and (package? package) - (let ((input (string-append - (package-name package) - (if (> (length output) 0) - (string-append ":" (car output)) - "")))) - (and (member input input-names) - input)))) - packages outputs)))) - -(define (check-inputs-should-be-native package) - ;; Emit a warning if some inputs of PACKAGE are likely to belong to its - ;; native inputs. - (let ((inputs (package-inputs package)) - (input-names - '("pkg-config" - "cmake" - "extra-cmake-modules" - "glib:bin" - "intltool" - "itstool" - "qttools" - "python-coverage" "python2-coverage" - "python-cython" "python2-cython" - "python-docutils" "python2-docutils" - "python-mock" "python2-mock" - "python-nose" "python2-nose" - "python-pbr" "python2-pbr" - "python-pytest" "python2-pytest" - "python-pytest-cov" "python2-pytest-cov" - "python-setuptools-scm" "python2-setuptools-scm" - "python-sphinx" "python2-sphinx"))) - (map (lambda (input) - (make-warning - package - (G_ "'~a' should probably be a native input") - (list input) - #:field 'inputs)) - (package-input-intersection inputs input-names)))) - -(define (check-inputs-should-not-be-an-input-at-all package) - ;; Emit a warning if some inputs of PACKAGE are likely to should not be - ;; an input at all. - (let ((input-names '("python-setuptools" - "python2-setuptools" - "python-pip" - "python2-pip"))) - (map (lambda (input) - (make-warning - package - (G_ "'~a' should probably not be an input at all") - (list input) - #:field 'inputs)) - (package-input-intersection (package-direct-inputs package) - input-names)))) - -(define (package-name-regexp package) - "Return a regexp that matches PACKAGE's name as a word at the beginning of a -line." - (make-regexp (string-append "^" (regexp-quote (package-name package)) - "\\>") - regexp/icase)) - -(define (check-synopsis-style package) - ;; Emit a warning if stylistic issues are found in the synopsis of PACKAGE. - (define (check-final-period synopsis) - ;; Synopsis should not end with a period, except for some special cases. - (if (and (string-suffix? "." synopsis) - (not (string-suffix? "etc." synopsis))) - (list - (make-warning package - (G_ "no period allowed at the end of the synopsis") - #:field 'synopsis)) - '())) - - (define check-start-article - ;; Skip this check for GNU packages, as suggested by Karl Berry's reply to - ;; . - (if (false-if-exception (gnu-package? package)) - (const '()) - (lambda (synopsis) - (if (or (string-prefix-ci? "A " synopsis) - (string-prefix-ci? "An " synopsis)) - (list - (make-warning package - (G_ "no article allowed at the beginning of \ -the synopsis") - #:field 'synopsis)) - '())))) - - (define (check-synopsis-length synopsis) - (if (>= (string-length synopsis) 80) - (list - (make-warning package - (G_ "synopsis should be less than 80 characters long") - #:field 'synopsis)) - '())) - - (define (check-proper-start synopsis) - (if (properly-starts-sentence? synopsis) - '() - (list - (make-warning package - (G_ "synopsis should start with an upper-case letter or digit") - #:field 'synopsis)))) - - (define (check-start-with-package-name synopsis) - (if (and (regexp-exec (package-name-regexp package) synopsis) - (not (starts-with-abbreviation? synopsis))) - (list - (make-warning package - (G_ "synopsis should not start with the package name") - #:field 'synopsis)) - '())) - - (define (check-texinfo-markup synopsis) - "Check that SYNOPSIS can be parsed as a Texinfo fragment. If the -markup is valid return a plain-text version of SYNOPSIS, otherwise #f." - (catch #t - (lambda () - (texi->plain-text synopsis) - '()) - (lambda (keys . args) - (list - (make-warning package - (G_ "Texinfo markup in synopsis is invalid") - #:field 'synopsis))))) - - (define checks - (list check-proper-start - check-final-period - check-start-article - check-start-with-package-name - check-synopsis-length - check-texinfo-markup)) - - (match (package-synopsis package) - ("" - (list - (make-warning package - (G_ "synopsis should not be empty") - #:field 'synopsis))) - ((? string? synopsis) - (append-map - (lambda (proc) - (proc synopsis)) - checks)) - (invalid - (list - (make-warning package - (G_ "invalid synopsis: ~s") - (list invalid) - #:field 'synopsis))))) - -(define* (probe-uri uri #:key timeout) - "Probe URI, a URI object, and return two values: a symbol denoting the -probing status, such as 'http-response' when we managed to get an HTTP -response from URI, and additional details, such as the actual HTTP response. - -TIMEOUT is the maximum number of seconds (possibly an inexact number) to wait -for connections to complete; when TIMEOUT is #f, wait as long as needed." - (define headers - '((User-Agent . "GNU Guile") - (Accept . "*/*"))) - - (let loop ((uri uri) - (visited '())) - (match (uri-scheme uri) - ((or 'http 'https) - (catch #t - (lambda () - (let ((port (guix:open-connection-for-uri - uri #:timeout timeout)) - (request (build-request uri #:headers headers))) - (define response - (dynamic-wind - (const #f) - (lambda () - (write-request request port) - (force-output port) - (read-response port)) - (lambda () - (close-connection port)))) - - (case (response-code response) - ((302 ; found (redirection) - 303 ; see other - 307 ; temporary redirection - 308) ; permanent redirection - (let ((location (response-location response))) - (if (or (not location) (member location visited)) - (values 'http-response response) - (loop location (cons location visited))))) ;follow the redirect - ((301) ; moved permanently - (let ((location (response-location response))) - ;; Return RESPONSE, unless the final response as we follow - ;; redirects is not 200. - (if location - (let-values (((status response2) - (loop location (cons location visited)))) - (case status - ((http-response) - (values 'http-response - (if (= 200 (response-code response2)) - response - response2))) - (else - (values status response2)))) - (values 'http-response response)))) ;invalid redirect - (else - (values 'http-response response))))) - (lambda (key . args) - (case key - ((bad-header bad-header-component) - ;; This can happen if the server returns an invalid HTTP header, - ;; as is the case with the 'Date' header at sqlite.org. - (values 'invalid-http-response #f)) - ((getaddrinfo-error system-error - gnutls-error tls-certificate-error) - (values key args)) - (else - (apply throw key args)))))) - ('ftp - (catch #t - (lambda () - (let ((conn (ftp-open (uri-host uri) #:timeout timeout))) - (define response - (dynamic-wind - (const #f) - (lambda () - (ftp-chdir conn (dirname (uri-path uri))) - (ftp-size conn (basename (uri-path uri)))) - (lambda () - (ftp-close conn)))) - (values 'ftp-response '(ok)))) - (lambda (key . args) - (case key - ((ftp-error) - (values 'ftp-response `(error ,@args))) - ((getaddrinfo-error system-error gnutls-error) - (values key args)) - (else - (apply throw key args)))))) - (_ - (values 'unknown-protocol #f))))) - -(define (tls-certificate-error-string args) - "Return a string explaining the 'tls-certificate-error' arguments ARGS." - (call-with-output-string - (lambda (port) - (print-exception port #f - 'tls-certificate-error args)))) - -(define (validate-uri uri package field) - "Return #t if the given URI can be reached, otherwise return a warning for -PACKAGE mentionning the FIELD." - (let-values (((status argument) - (probe-uri uri #:timeout 3))) ;wait at most 3 seconds - (case status - ((http-response) - (cond ((= 200 (response-code argument)) - (match (response-content-length argument) - ((? number? length) - ;; As of July 2016, SourceForge returns 200 (instead of 404) - ;; with a small HTML page upon failure. Attempt to detect - ;; such malicious behavior. - (or (> length 1000) - (make-warning package - (G_ "URI ~a returned \ -suspiciously small file (~a bytes)") - (list (uri->string uri) - length) - #:field field))) - (_ #t))) - ((= 301 (response-code argument)) - (if (response-location argument) - (make-warning package - (G_ "permanent redirect from ~a to ~a") - (list (uri->string uri) - (uri->string - (response-location argument))) - #:field field) - (make-warning package - (G_ "invalid permanent redirect \ -from ~a") - (list (uri->string uri)) - #:field field))) - (else - (make-warning package - (G_ "URI ~a not reachable: ~a (~s)") - (list (uri->string uri) - (response-code argument) - (response-reason-phrase argument)) - #:field field)))) - ((ftp-response) - (match argument - (('ok) #t) - (('error port command code message) - (make-warning package - (G_ "URI ~a not reachable: ~a (~s)") - (list (uri->string uri) - code (string-trim-both message)) - #:field field)))) - ((getaddrinfo-error) - (make-warning package - (G_ "URI ~a domain not found: ~a") - (list (uri->string uri) - (gai-strerror (car argument))) - #:field field)) - ((system-error) - (make-warning package - (G_ "URI ~a unreachable: ~a") - (list (uri->string uri) - (strerror - (system-error-errno - (cons status argument)))) - #:field field)) - ((tls-certificate-error) - (make-warning package - (G_ "TLS certificate error: ~a") - (list (tls-certificate-error-string argument)) - #:field field)) - ((invalid-http-response gnutls-error) - ;; Probably a misbehaving server; ignore. - #f) - ((unknown-protocol) ;nothing we can do - #f) - (else - (error "internal linter error" status))))) - -(define (check-home-page package) - "Emit a warning if PACKAGE has an invalid 'home-page' field, or if that -'home-page' is not reachable." - (let ((uri (and=> (package-home-page package) string->uri))) - (cond - ((uri? uri) - (match (validate-uri uri package 'home-page) - ((and (? lint-warning? warning) warning) - (list warning)) - (_ '()))) - ((not (package-home-page package)) - (if (or (string-contains (package-name package) "bootstrap") - (string=? (package-name package) "ld-wrapper")) - '() - (list - (make-warning package - (G_ "invalid value for home page") - #:field 'home-page)))) - (else - (list - (make-warning package - (G_ "invalid home page URL: ~s") - (list (package-home-page package)) - #:field 'home-page)))))) - -(define %distro-directory - (mlambda () - (dirname (search-path %load-path "gnu.scm")))) - -(define (check-patch-file-names package) - "Emit a warning if the patches requires by PACKAGE are badly named or if the -patch could not be found." - (guard (c ((message-condition? c) ;raised by 'search-patch' - (list - ;; Use %make-warning, as condition-mesasge is already - ;; translated. - (%make-warning package (condition-message c) - #:field 'patch-file-names)))) - (define patches - (or (and=> (package-source package) origin-patches) - '())) - - (append - (if (every (match-lambda ;patch starts with package name? - ((? string? patch) - (and=> (string-contains (basename patch) - (package-name package)) - zero?)) - (_ #f)) ;must be an or something like that. - patches) - '() - (list - (make-warning - package - (G_ "file names of patches should start with the package name") - #:field 'patch-file-names))) - - ;; Check whether we're reaching tar's maximum file name length. - (let ((prefix (string-length (%distro-directory))) - (margin (string-length "guix-0.13.0-10-123456789/")) - (max 99)) - (filter-map (match-lambda - ((? string? patch) - (if (> (+ margin (if (string-prefix? (%distro-directory) - patch) - (- (string-length patch) prefix) - (string-length patch))) - max) - (make-warning - package - (G_ "~a: file name is too long") - (list (basename patch)) - #:field 'patch-file-names) - #f)) - (_ #f)) - patches))))) - -(define (escape-quotes str) - "Replace any quote character in STR by an escaped quote character." - (list->string - (string-fold-right (lambda (chr result) - (match chr - (#\" (cons* #\\ #\"result)) - (_ (cons chr result)))) - '() - str))) - -(define official-gnu-packages* - (mlambda () - "A memoizing version of 'official-gnu-packages' that returns the empty -list when something goes wrong, such as a networking issue." - (let ((gnus (false-if-exception (official-gnu-packages)))) - (or gnus '())))) - -(define (check-gnu-synopsis+description package) - "Make sure that, if PACKAGE is a GNU package, it uses the synopsis and -descriptions maintained upstream." - (match (find (lambda (descriptor) - (string=? (gnu-package-name descriptor) - (package-name package))) - (official-gnu-packages*)) - (#f ;not a GNU package, so nothing to do - '()) - (descriptor ;a genuine GNU package - (append - (let ((upstream (gnu-package-doc-summary descriptor)) - (downstream (package-synopsis package))) - (if (and upstream - (or (not (string? downstream)) - (not (string=? upstream downstream)))) - (list - (make-warning package - (G_ "proposed synopsis: ~s~%") - (list upstream) - #:field 'synopsis)) - '())) - - (let ((upstream (gnu-package-doc-description descriptor)) - (downstream (package-description package))) - (if (and upstream - (or (not (string? downstream)) - (not (string=? (fill-paragraph upstream 100) - (fill-paragraph downstream 100))))) - (list - (make-warning - package - (G_ "proposed description:~% \"~a\"~%") - (list (fill-paragraph (escape-quotes upstream) 77 7)) - #:field 'description)) - '())))))) - -(define (origin-uris origin) - "Return the list of URIs (strings) for ORIGIN." - (match (origin-uri origin) - ((? string? uri) - (list uri)) - ((uris ...) - uris))) - -(define (check-source package) - "Emit a warning if PACKAGE has an invalid 'source' field, or if that -'source' is not reachable." - (define (warnings-for-uris uris) - (filter lint-warning? - (map - (lambda (uri) - (validate-uri uri package 'source)) - (append-map (cut maybe-expand-mirrors <> %mirrors) - uris)))) - - (let ((origin (package-source package))) - (if (and origin - (eqv? (origin-method origin) url-fetch)) - (let* ((uris (map string->uri (origin-uris origin))) - (warnings (warnings-for-uris uris))) - - ;; Just make sure that at least one of the URIs is valid. - (if (eq? (length uris) (length warnings)) - ;; When everything fails, report all of WARNINGS, otherwise don't - ;; report anything. - ;; - ;; XXX: Ideally we'd still allow warnings to be raised if *some* - ;; URIs are unreachable, but distinguish that from the error case - ;; where *all* the URIs are unreachable. - (cons* - (make-warning package - (G_ "all the source URIs are unreachable:") - #:field 'source) - warnings) - '())) - '()))) - -(define (check-source-file-name package) - "Emit a warning if PACKAGE's origin has no meaningful file name." - (define (origin-file-name-valid? origin) - ;; Return #f if the source file name contains only a version or is #f; - ;; indicates that the origin needs a 'file-name' field. - (let ((file-name (origin-actual-file-name origin)) - (version (package-version package))) - (and file-name - ;; Common in many projects is for the filename to start - ;; with a "v" followed by the version, - ;; e.g. "v3.2.0.tar.gz". - (not (string-match (string-append "^v?" version) file-name))))) - - (let ((origin (package-source package))) - (if (or (not origin) (origin-file-name-valid? origin)) - '() - (list - (make-warning package - (G_ "the source file name should contain the package name") - #:field 'source))))) - -(define (check-source-unstable-tarball package) - "Emit a warning if PACKAGE's source is an autogenerated tarball." - (define (check-source-uri uri) - (if (and (string=? (uri-host (string->uri uri)) "github.com") - (match (split-and-decode-uri-path - (uri-path (string->uri uri))) - ((_ _ "archive" _ ...) #t) - (_ #f))) - (make-warning package - (G_ "the source URI should not be an autogenerated tarball") - #:field 'source) - #f)) - - (let ((origin (package-source package))) - (if (and (origin? origin) - (eqv? (origin-method origin) url-fetch)) - (filter-map check-source-uri - (origin-uris origin)) - '()))) - -(define (check-mirror-url package) - "Check whether PACKAGE uses source URLs that should be 'mirror://'." - (define (check-mirror-uri uri) ;XXX: could be optimized - (let loop ((mirrors %mirrors)) - (match mirrors - (() - #f) - (((mirror-id mirror-urls ...) rest ...) - (match (find (cut string-prefix? <> uri) mirror-urls) - (#f - (loop rest)) - (prefix - (make-warning package - (G_ "URL should be \ -'mirror://~a/~a'") - (list mirror-id - (string-drop uri (string-length prefix))) - #:field 'source))))))) - - (let ((origin (package-source package))) - (if (and (origin? origin) - (eqv? (origin-method origin) url-fetch)) - (let ((uris (origin-uris origin))) - (filter-map check-mirror-uri uris)) - '()))) - -(define* (check-github-url package #:key (timeout 3)) - "Check whether PACKAGE uses source URLs that redirect to GitHub." - (define (follow-redirect url) - (let* ((uri (string->uri url)) - (port (guix:open-connection-for-uri uri #:timeout timeout)) - (response (http-head uri #:port port))) - (close-port port) - (case (response-code response) - ((301 302) - (uri->string (assoc-ref (response-headers response) 'location))) - (else #f)))) - - (define (follow-redirects-to-github uri) - (cond - ((string-prefix? "https://github.com/" uri) uri) - ((string-prefix? "http" uri) - (and=> (follow-redirect uri) follow-redirects-to-github)) - ;; Do not attempt to follow redirects on URIs other than http and https - ;; (such as mirror, file) - (else #f))) - - (let ((origin (package-source package))) - (if (and (origin? origin) - (eqv? (origin-method origin) url-fetch)) - (filter-map - (lambda (uri) - (and=> (follow-redirects-to-github uri) - (lambda (github-uri) - (if (string=? github-uri uri) - #f - (make-warning - package - (G_ "URL should be '~a'") - (list github-uri) - #:field 'source))))) - (origin-uris origin)) - '()))) - -(define (check-derivation package) - "Emit a warning if we fail to compile PACKAGE to a derivation." - (define (try system) - (catch #t - (lambda () - (guard (c ((store-protocol-error? c) - (make-warning package - (G_ "failed to create ~a derivation: ~a") - (list system - (store-protocol-error-message c)))) - ((message-condition? c) - (make-warning package - (G_ "failed to create ~a derivation: ~a") - (list system - (condition-message c))))) - (with-store store - ;; Disable grafts since it can entail rebuilds. - (parameterize ((%graft? #f)) - (package-derivation store package system #:graft? #f) - - ;; If there's a replacement, make sure we can compute its - ;; derivation. - (match (package-replacement package) - (#f #t) - (replacement - (package-derivation store replacement system - #:graft? #f))))))) - (lambda args - (make-warning package - (G_ "failed to create ~a derivation: ~s") - (list system args))))) - - (filter lint-warning? - (map try (package-supported-systems package)))) - -(define (check-license package) - "Warn about type errors of the 'license' field of PACKAGE." - (match (package-license package) - ((or (? license?) - ((? license?) ...)) - '()) - (x - (list - (make-warning package (G_ "invalid license field") - #:field 'license))))) - -(define (call-with-networking-fail-safe message error-value proc) - "Call PROC catching any network-related errors. Upon a networking error, -display a message including MESSAGE and return ERROR-VALUE." - (guard (c ((http-get-error? c) - (warning (G_ "~a: HTTP GET error for ~a: ~a (~s)~%") - message - (uri->string (http-get-error-uri c)) - (http-get-error-code c) - (http-get-error-reason c)) - error-value)) - (catch #t - proc - (match-lambda* - (('getaddrinfo-error errcode) - (warning (G_ "~a: host lookup failure: ~a~%") - message - (gai-strerror errcode)) - error-value) - (('tls-certificate-error args ...) - (warning (G_ "~a: TLS certificate error: ~a") - message - (tls-certificate-error-string args)) - error-value) - (args - (apply throw args)))))) - -(define-syntax-rule (with-networking-fail-safe message error-value exp ...) - (call-with-networking-fail-safe message error-value - (lambda () exp ...))) - -(define (current-vulnerabilities*) - "Like 'current-vulnerabilities', but return the empty list upon networking -or HTTP errors. This allows network-less operation and makes problems with -the NIST server non-fatal." - (with-networking-fail-safe (G_ "while retrieving CVE vulnerabilities") - '() - (current-vulnerabilities))) - -(define package-vulnerabilities - (let ((lookup (delay (vulnerabilities->lookup-proc - (current-vulnerabilities*))))) - (lambda (package) - "Return a list of vulnerabilities affecting PACKAGE." - ;; First we retrieve the Common Platform Enumeration (CPE) name and - ;; version for PACKAGE, then we can pass them to LOOKUP. - (let ((name (or (assoc-ref (package-properties package) - 'cpe-name) - (package-name package))) - (version (or (assoc-ref (package-properties package) - 'cpe-version) - (package-version package)))) - ((force lookup) name version))))) - -(define (check-vulnerabilities package) - "Check for known vulnerabilities for PACKAGE." - (let ((package (or (package-replacement package) package))) - (match (package-vulnerabilities package) - (() - '()) - ((vulnerabilities ...) - (let* ((patched (package-patched-vulnerabilities package)) - (known-safe (or (assq-ref (package-properties package) - 'lint-hidden-cve) - '())) - (unpatched (remove (lambda (vuln) - (let ((id (vulnerability-id vuln))) - (or (member id patched) - (member id known-safe)))) - vulnerabilities))) - (if (null? unpatched) - '() - (list - (make-warning - package - (G_ "probably vulnerable to ~a") - (list (string-join (map vulnerability-id unpatched) - ", ")))))))))) - -(define (check-for-updates package) - "Check if there is an update available for PACKAGE." - (match (with-networking-fail-safe - (G_ "while retrieving upstream info for '~a'") - (list (package-name package)) - #f - (package-latest-release* package (force %updaters))) - ((? upstream-source? source) - (if (version>? (upstream-source-version source) - (package-version package)) - (list - (make-warning package - (G_ "can be upgraded to ~a") - (list (upstream-source-version source)) - #:field 'version)) - '())) - (#f '()))) ; cannot find newer upstream release - - -;;; -;;; Source code formatting. -;;; - -(define (report-tabulations package line line-number) - "Warn about tabulations found in LINE." - (match (string-index line #\tab) - (#f #t) - (index - (make-warning package - (G_ "tabulation on line ~a, column ~a") - (list line-number index) - #:location - (location (package-file package) - line-number - index))))) - -(define (report-trailing-white-space package line line-number) - "Warn about trailing white space in LINE." - (unless (or (string=? line (string-trim-right line)) - (string=? line (string #\page))) - (make-warning package - (G_ "trailing white space on line ~a") - (list line-number) - #:location - (location (package-file package) - line-number - 0)))) - -(define (report-long-line package line line-number) - "Emit a warning if LINE is too long." - ;; Note: We don't warn at 80 characters because sometimes hashes and URLs - ;; make it hard to fit within that limit and we want to avoid making too - ;; much noise. - (when (> (string-length line) 90) - (make-warning package - (G_ "line ~a is way too long (~a characters)") - (list line-number (string-length line)) - #:location - (location (package-file package) - line-number - 0)))) - -(define %hanging-paren-rx - (make-regexp "^[[:blank:]]*[()]+[[:blank:]]*$")) - -(define (report-lone-parentheses package line line-number) - "Emit a warning if LINE contains hanging parentheses." - (when (regexp-exec %hanging-paren-rx line) - (make-warning package - (G_ "parentheses feel lonely, \ -move to the previous or next line") - (list line-number) - #:location - (location (package-file package) - line-number - 0)))) - -(define %formatting-reporters - ;; List of procedures that report formatting issues. These are not separate - ;; checkers because they would need to re-read the file. - (list report-tabulations - report-trailing-white-space - report-long-line - report-lone-parentheses)) - -(define* (report-formatting-issues package file starting-line - #:key (reporters %formatting-reporters)) - "Report white-space issues in FILE starting from STARTING-LINE, and report -them for PACKAGE." - (define (sexp-last-line port) - ;; Return the last line of the sexp read from PORT or an estimate thereof. - (define &failure (list 'failure)) - - (let ((start (ftell port)) - (start-line (port-line port)) - (sexp (catch 'read-error - (lambda () (read port)) - (const &failure)))) - (let ((line (port-line port))) - (seek port start SEEK_SET) - (set-port-line! port start-line) - (if (eq? sexp &failure) - (+ start-line 60) ;conservative estimate - line)))) - - (call-with-input-file file - (lambda (port) - (let loop ((line-number 1) - (last-line #f) - (warnings '())) - (let ((line (read-line port))) - (if (or (eof-object? line) - (and last-line (> line-number last-line))) - warnings - (if (and (= line-number starting-line) - (not last-line)) - (loop (+ 1 line-number) - (+ 1 (sexp-last-line port)) - warnings) - (loop (+ 1 line-number) - last-line - (append - warnings - (if (< line-number starting-line) - '() - (filter - lint-warning? - (map (lambda (report) - (report package line line-number)) - reporters)))))))))))) - -(define (check-formatting package) - "Check the formatting of the source code of PACKAGE." - (let ((location (package-location package))) - (if location - (and=> (search-path %load-path (location-file location)) - (lambda (file) - ;; Report issues starting from the line before the 'package' - ;; form, which usually contains the 'define' form. - (report-formatting-issues package file - (- (location-line location) 1)))) - '()))) - - -;;; -;;; List of checkers. -;;; - -(define %checkers - (list - (lint-checker - (name 'description) - (description "Validate package descriptions") - (check check-description-style)) - (lint-checker - (name 'gnu-description) - (description "Validate synopsis & description of GNU packages") - (check check-gnu-synopsis+description)) - (lint-checker - (name 'inputs-should-be-native) - (description "Identify inputs that should be native inputs") - (check check-inputs-should-be-native)) - (lint-checker - (name 'inputs-should-not-be-input) - (description "Identify inputs that shouldn't be inputs at all") - (check check-inputs-should-not-be-an-input-at-all)) - (lint-checker - (name 'patch-file-names) - (description "Validate file names and availability of patches") - (check check-patch-file-names)) - (lint-checker - (name 'home-page) - (description "Validate home-page URLs") - (check check-home-page)) - (lint-checker - (name 'license) - ;; TRANSLATORS: is the name of a data type and must not be - ;; translated. - (description "Make sure the 'license' field is a \ -or a list thereof") - (check check-license)) - (lint-checker - (name 'source) - (description "Validate source URLs") - (check check-source)) - (lint-checker - (name 'mirror-url) - (description "Suggest 'mirror://' URLs") - (check check-mirror-url)) - (lint-checker - (name 'github-url) - (description "Suggest GitHub URLs") - (check check-github-url)) - (lint-checker - (name 'source-file-name) - (description "Validate file names of sources") - (check check-source-file-name)) - (lint-checker - (name 'source-unstable-tarball) - (description "Check for autogenerated tarballs") - (check check-source-unstable-tarball)) - (lint-checker - (name 'derivation) - (description "Report failure to compile a package to a derivation") - (check check-derivation)) - (lint-checker - (name 'synopsis) - (description "Validate package synopses") - (check check-synopsis-style)) - (lint-checker - (name 'cve) - (description "Check the Common Vulnerabilities and Exposures\ - (CVE) database") - (check check-vulnerabilities)) - (lint-checker - (name 'refresh) - (description "Check the package for new upstream releases") - (check check-for-updates)) - (lint-checker - (name 'formatting) - (description "Look for formatting issues in the source") - (check check-formatting)))) - (define* (run-checkers package #:optional (checkers %checkers)) "Run the given CHECKERS on PACKAGE." (let ((tty? (isatty? (current-error-port)))) @@ -1260,6 +68,16 @@ or a list thereof") (format (current-error-port) "\x1b[K") (force-output (current-error-port))))) +(define (list-checkers-and-exit) + ;; Print information about all available checkers and exit. + (format #t (G_ "Available checkers:~%")) + (for-each (lambda (checker) + (format #t "- ~a: ~a~%" + (lint-checker-name checker) + (G_ (lint-checker-description checker)))) + %checkers) + (exit 0)) + ;;; ;;; Command-line options. diff --git a/po/guix/POTFILES.in b/po/guix/POTFILES.in index ad06ebce95..8b556ac0ec 100644 --- a/po/guix/POTFILES.in +++ b/po/guix/POTFILES.in @@ -40,6 +40,7 @@ gnu/machine/ssh.scm guix/scripts.scm guix/scripts/build.scm guix/discovery.scm +guix/lint.scm guix/scripts/download.scm guix/scripts/package.scm guix/scripts/install.scm diff --git a/tests/lint.scm b/tests/lint.scm index d8b2ca54cd..59be061a99 100644 --- a/tests/lint.scm +++ b/tests/lint.scm @@ -33,7 +33,7 @@ #:use-module (guix git-download) #:use-module (guix build-system gnu) #:use-module (guix packages) - #:use-module (guix scripts lint) + #:use-module (guix lint) #:use-module (guix ui) #:use-module (gnu packages) #:use-module (gnu packages glib) -- 2.22.0 From debbugs-submit-bounces@debbugs.gnu.org Mon Jul 15 15:51:45 2019 Received: (at 35790) by debbugs.gnu.org; 15 Jul 2019 19:51:45 +0000 Received: from localhost ([127.0.0.1]:49199 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1hn70j-0000MU-9H for submit@debbugs.gnu.org; Mon, 15 Jul 2019 15:51:45 -0400 Received: from mira.cbaines.net ([212.71.252.8]:45810) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1hn70g-0000ML-OC for 35790@debbugs.gnu.org; Mon, 15 Jul 2019 15:51:43 -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 4AFEC171BA; Mon, 15 Jul 2019 20:51:40 +0100 (BST) Received: from capella (localhost [127.0.0.1]) by localhost (OpenSMTPD) with ESMTP id fd2f2e67; Mon, 15 Jul 2019 19:51:40 +0000 (UTC) References: <87a7dyoryh.fsf@gnu.org> <20190702192542.16179-1-mail@cbaines.net> <87pnmfgw03.fsf@gnu.org> <87wogkh4s0.fsf@cbaines.net> <87k1cjr6vv.fsf@gnu.org> User-agent: mu4e 1.2.0; emacs 26.2 From: Christopher Baines To: Ludovic =?utf-8?Q?Court=C3=A8s?= Subject: Re: [bug#35790] [PATCH 1/2] lint: Move the linting code to a different module. In-reply-to: <87k1cjr6vv.fsf@gnu.org> Date: Mon, 15 Jul 2019 20:51:35 +0100 Message-ID: <87pnmbgjp4.fsf@cbaines.net> MIME-Version: 1.0 Content-Type: multipart/signed; boundary="=-=-="; micalg=pgp-sha512; protocol="application/pgp-signature" X-Spam-Score: -0.0 (/) X-Debbugs-Envelope-To: 35790 Cc: 35790@debbugs.gnu.org X-BeenThere: debbugs-submit@debbugs.gnu.org X-Mailman-Version: 2.1.18 Precedence: list List-Id: List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: debbugs-submit-bounces@debbugs.gnu.org Sender: "Debbugs-submit" X-Spam-Score: -1.0 (-) --=-=-= Content-Type: text/plain; charset=utf-8 Content-Transfer-Encoding: quoted-printable Ludovic Court=C3=A8s writes: > Hi Chris! > > Christopher Baines skribis: > >> Ludovic Court=C3=A8s writes: >> >>> Christopher Baines skribis: >>> >>>> To try and move towards making programatic access to the linting code = easier, >>>> this commit separates out the linting script, from the linting functio= nality >>>> that it uses. >>> >>> For the final version, please write a change log. >> >> Sure, any suggestions about how to write it? I wasn't sure whether to >> list everything that had been moved from (guix scripts lint) to (guix >> lint), or say that the file has moved, and list the things that have >> been moved back. > > Maybe something like: > > * guix/scripts/lint.scm (check-foo, check-bar): Move to=E2=80=A6 > * guix/lint.scm: =E2=80=A6 here. > > and also mention things that go beyond simply moving things around (if > applicable). > > But again, don=E2=80=99t spend a whole day on this, it=E2=80=99s mostly s= o the future us > have an easily searchable log. Ok, I've made an initial attempt at this, and re-sent the patches. >> Actually, now that I've run make, that's spotted some problems in some >> checks. >> >> guix/lint.scm:198:17: warning: possibly unbound variable `texi->plain-te= xt' >> guix/lint.scm:406:8: warning: possibly unbound variable `texi->plain-tex= t' >> guix/lint.scm:737:36: warning: possibly unbound variable `fill-paragraph' >> guix/lint.scm:738:36: warning: possibly unbound variable `fill-paragraph' >> guix/lint.scm:743:20: warning: possibly unbound variable `fill-paragraph' >> >> I don't think these are as easy to solve, as these functions come from >> (guix ui). > > Ah yes, indeed. > > In that case it=E2=80=99s OK because (guix ui) is used as part of the lin= ter=E2=80=99s > job. Perhaps for clarity we should write: > > #:use-module ((guix ui) #:select (texi->plain-text fill-paragraph)) > > Uses of the =E2=80=98warning=E2=80=99 procedure or similar UI functionali= ty should be > left to (guix scripts lint), though. I've made this #:use-module change, and also moved emit-warnings to the (guix scripts lint) module. I've re-sent all 4 patches now. Thanks, Chris --=-=-= Content-Type: application/pgp-signature; name="signature.asc" -----BEGIN PGP SIGNATURE----- iQKTBAEBCgB9FiEEPonu50WOcg2XVOCyXiijOwuE9XcFAl0s2UdfFIAAAAAALgAo aXNzdWVyLWZwckBub3RhdGlvbnMub3BlbnBncC5maWZ0aGhvcnNlbWFuLm5ldDNF ODlFRUU3NDU4RTcyMEQ5NzU0RTBCMjVFMjhBMzNCMEI4NEY1NzcACgkQXiijOwuE 9XfEBg/+LoK0HkkCGLgoXXkQGcuBfRdlw2FsZjT7KLp9wTa3LSpl4n6dE+aHmfqv YnCXwDwASagb6KoILw4apYF5FreTcl+bgjwUkcTWZNoSYJaoWlPVKQ6SXN/RoTUC SfxEtC1XXOhRV4vVkzT86Plj/+xWcvPZBm5IoRO8yPSmdQf4Mo6lder9ISGvwxSw wPRWhnepO926ouE+OKARIYFTmAnUyFpRaLUWU8QlCxdaFAk/51gQnJvD/L/ZLAws Ypw/haY23Ij8VOWtw5ACtz+W1GTI3L6MANxmgF+anv1Lb5WQ8QBfhrzIxaHYempx 1pgnRRPXeV1I/CBqhL6R00PxnK2hpVQxjjbGBvNKBCJrh4zwcTWQNUR5NXvHzvmX eCD9HIGQd9URJVsI9S9PHSRoXhe8ALZz3L4FcBogT4wy9EwyCbGjf14QjnvyFhcE eTzDDXdrjDTOQPbiWyzAxUthRZSZwjf+H2m8SJJtI/w/C5u7BwFjvgdZo9B2j1Hp u4QFkpUCPy/kQEFFc8N/ufjDbiL4lc710FYMF6USQ0Pwzf7wtKPg8+oNEUJIaUof NFNPrL0Q8X4r9D1uYKkaBfeawVCJzWwg9YXUU/7Z89k4SdmBm+Bwfzu5x1xAC8p9 6qnReY9J/04etHdNnUWTDuLV1uDe2hf/2t0/bv3SLK9GMIC+1L8= =kCVm -----END PGP SIGNATURE----- --=-=-=-- From debbugs-submit-bounces@debbugs.gnu.org Mon Jul 15 16:17:32 2019 Received: (at 35790) by debbugs.gnu.org; 15 Jul 2019 20:17:32 +0000 Received: from localhost ([127.0.0.1]:49212 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1hn7Pf-00010h-Rg for submit@debbugs.gnu.org; Mon, 15 Jul 2019 16:17:32 -0400 Received: from eggs.gnu.org ([209.51.188.92]:42422) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1hn7Pe-00010R-3L for 35790@debbugs.gnu.org; Mon, 15 Jul 2019 16:17:30 -0400 Received: from fencepost.gnu.org ([2001:470:142:3::e]:56189) by eggs.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1hn7PY-0005JD-BT; Mon, 15 Jul 2019 16:17:24 -0400 Received: from [2a01:e0a:1d:7270:af76:b9b:ca24:c465] (port=53310 helo=ribbon) by fencepost.gnu.org with esmtpsa (TLS1.2:RSA_AES_256_CBC_SHA1:256) (Exim 4.82) (envelope-from ) id 1hn7PX-0002gj-Rm; Mon, 15 Jul 2019 16:17:24 -0400 From: =?utf-8?Q?Ludovic_Court=C3=A8s?= To: Christopher Baines Subject: Re: [bug#35790] [PATCH 4/4] lint: Separate checkers by dependence on the internet. References: <87k1cjr6vv.fsf@gnu.org> <20190715194558.13804-1-mail@cbaines.net> <20190715194558.13804-4-mail@cbaines.net> Date: Mon, 15 Jul 2019 22:17:21 +0200 In-Reply-To: <20190715194558.13804-4-mail@cbaines.net> (Christopher Baines's message of "Mon, 15 Jul 2019 20:45:58 +0100") Message-ID: <87o91vhx2m.fsf@gnu.org> User-Agent: Gnus/5.13 (Gnus v5.13) Emacs/26.2 (gnu/linux) MIME-Version: 1.0 Content-Type: text/plain; charset=utf-8 Content-Transfer-Encoding: quoted-printable X-detected-operating-system: by eggs.gnu.org: GNU/Linux 2.2.x-3.x [generic] X-Spam-Score: -2.3 (--) X-Debbugs-Envelope-To: 35790 Cc: 35790@debbugs.gnu.org X-BeenThere: debbugs-submit@debbugs.gnu.org X-Mailman-Version: 2.1.18 Precedence: list List-Id: List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: debbugs-submit-bounces@debbugs.gnu.org Sender: "Debbugs-submit" X-Spam-Score: -3.3 (---) Hi! It seems to me we=E2=80=99re all set now. Thanks a lot for all the work and for your patience! Ludo=E2=80=99. From debbugs-submit-bounces@debbugs.gnu.org Mon Jul 15 18:23:25 2019 Received: (at 35790-done) by debbugs.gnu.org; 15 Jul 2019 22:23:25 +0000 Received: from localhost ([127.0.0.1]:49323 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1hn9NV-0006e4-DD for submit@debbugs.gnu.org; Mon, 15 Jul 2019 18:23:25 -0400 Received: from mira.cbaines.net ([212.71.252.8]:46352) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1hn9NU-0006dw-4n for 35790-done@debbugs.gnu.org; Mon, 15 Jul 2019 18:23:24 -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 8B146171DC; Mon, 15 Jul 2019 23:23:22 +0100 (BST) Received: from capella (localhost [127.0.0.1]) by localhost (OpenSMTPD) with ESMTP id 035bef16; Mon, 15 Jul 2019 22:23:22 +0000 (UTC) References: <87k1cjr6vv.fsf@gnu.org> <20190715194558.13804-1-mail@cbaines.net> <20190715194558.13804-4-mail@cbaines.net> <87o91vhx2m.fsf@gnu.org> User-agent: mu4e 1.2.0; emacs 26.2 From: Christopher Baines To: Ludovic =?utf-8?Q?Court=C3=A8s?= Subject: Re: [bug#35790] [PATCH 4/4] lint: Separate checkers by dependence on the internet. In-reply-to: <87o91vhx2m.fsf@gnu.org> Date: Mon, 15 Jul 2019 23:23:19 +0100 Message-ID: <87o91vgco8.fsf@cbaines.net> MIME-Version: 1.0 Content-Type: multipart/signed; boundary="=-=-="; micalg=pgp-sha512; protocol="application/pgp-signature" X-Spam-Score: -0.0 (/) X-Debbugs-Envelope-To: 35790-done Cc: 35790-done@debbugs.gnu.org X-BeenThere: debbugs-submit@debbugs.gnu.org X-Mailman-Version: 2.1.18 Precedence: list List-Id: List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: debbugs-submit-bounces@debbugs.gnu.org Sender: "Debbugs-submit" X-Spam-Score: -1.0 (-) --=-=-= Content-Type: text/plain; charset=utf-8 Content-Transfer-Encoding: quoted-printable Ludovic Court=C3=A8s writes: > Hi! > > It seems to me we=E2=80=99re all set now. Great, I've pushed these to master now. > Thanks a lot for all the work and for your patience! No problem :) In terms of next steps, I think this is a big bit of the work needed to get lint warnings in to the Guix Data Service done, but there's still a big chunk to do. I hope to start looking at actually trying to load in the lint warnings soon. This might involve extending the inferior API if that's helpful. I also want to attempt to store translations for the lint warnings in one way or another, as that'll begin to address the lack of localisation in the Guix Data Service. There's also some thinking about how to manage the network dependent checkers. I'd like to get that information in anyway, but also, I think it might be possible to maybe separate out the network independant parts of the checkers that are currently in the network dependent list. For example, the synopsis checker is only in there as it attempts to connect to the network to check if packages are a GNU package, and I'm wondering if that can be avoided. Anyway, hopefully the code refactoring is generally helpful, and maybe the --no-network option for guix lint will come in useful as well. Chris --=-=-= Content-Type: application/pgp-signature; name="signature.asc" -----BEGIN PGP SIGNATURE----- iQKTBAEBCgB9FiEEPonu50WOcg2XVOCyXiijOwuE9XcFAl0s/NhfFIAAAAAALgAo aXNzdWVyLWZwckBub3RhdGlvbnMub3BlbnBncC5maWZ0aGhvcnNlbWFuLm5ldDNF ODlFRUU3NDU4RTcyMEQ5NzU0RTBCMjVFMjhBMzNCMEI4NEY1NzcACgkQXiijOwuE 9Xfe1RAAhkXJ7HF1MeKGHtxGW9Fy6L1DZFTaylcZ40/CnXHY3RZHHJIqR/54L/nN AmuG196EAjfLOuyWPS7am4EXs0uUeAPnF0F1iKh0FDFc6Sw1F4PD4DSh2pnTREmj fFnHEh65V10OKsmCW3ZcfIf35D/dzQW0mXNcO6Z9qwTpZmbJ0VPdMEwZPK7l3ZsU qOXu56hqTgc7RigsWMxKYnrrrr1lPSVVcw9qDGp4Z7dz73PAYO0U9ILsBI2Odtti ucTJxHnWHUASYR/DLN07kM4dk83sorqaYQuIcIXU30JzbBf2h/F+iVti5CSUH4kB LBkeOcwxzzrcUKH0VgrmvB5gVWzSDVLCx/+82LdBygurgPC7vTuuPLp3FeWvO3GZ VUG7o/Hv3lu3jLYsMJEGYoFqueomlB8vRFVO3M3wsKSebH4680lf07zeiQr8BbdK OW6PtJs1UY+tyztT0qirkPXAWzGc0L5IotD6BiSsZydl/DA9bS6uy7uaTf4x89zT WKRde9WXwCxzzHKtxQkk/f1ulm7U2noB6uxCH6+LofzysfZRE2I0nBSy1EbhkRsn zVeoFAVuOK5kgSLDgSpg/lLrys2R+pivU5/34XPIeBy7Z+q82gxdEcMW7w1VvBvk 6fj3IgrR6IQDPjXmJK75ZxdfWidSUHCR2oiIyyP927NF1MxWssA= =siiW -----END PGP SIGNATURE----- --=-=-=-- From debbugs-submit-bounces@debbugs.gnu.org Tue Jul 16 17:34:42 2019 Received: (at 35790-done) by debbugs.gnu.org; 16 Jul 2019 21:34:42 +0000 Received: from localhost ([127.0.0.1]:51272 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1hnV5t-0000WR-Pu for submit@debbugs.gnu.org; Tue, 16 Jul 2019 17:34:42 -0400 Received: from eggs.gnu.org ([209.51.188.92]:45436) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1hnV5s-0000W5-9U for 35790-done@debbugs.gnu.org; Tue, 16 Jul 2019 17:34:40 -0400 Received: from fencepost.gnu.org ([2001:470:142:3::e]:46768) by eggs.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1hnV5l-0006md-Uj; Tue, 16 Jul 2019 17:34:34 -0400 Received: from [2a01:e0a:1d:7270:af76:b9b:ca24:c465] (port=60096 helo=ribbon) by fencepost.gnu.org with esmtpsa (TLS1.2:RSA_AES_256_CBC_SHA1:256) (Exim 4.82) (envelope-from ) id 1hnV5l-00015O-5O; Tue, 16 Jul 2019 17:34:33 -0400 From: =?utf-8?Q?Ludovic_Court=C3=A8s?= To: Christopher Baines Subject: Re: [bug#35790] [PATCH 4/4] lint: Separate checkers by dependence on the internet. References: <87k1cjr6vv.fsf@gnu.org> <20190715194558.13804-1-mail@cbaines.net> <20190715194558.13804-4-mail@cbaines.net> <87o91vhx2m.fsf@gnu.org> <87o91vgco8.fsf@cbaines.net> X-URL: http://www.fdn.fr/~lcourtes/ X-Revolutionary-Date: 28 Messidor an 227 de la =?utf-8?Q?R=C3=A9volution?= X-PGP-Key-ID: 0x090B11993D9AEBB5 X-PGP-Key: http://www.fdn.fr/~lcourtes/ludovic.asc X-PGP-Fingerprint: 3CE4 6455 8A84 FDC6 9DB4 0CFB 090B 1199 3D9A EBB5 X-OS: x86_64-pc-linux-gnu Date: Tue, 16 Jul 2019 23:34:31 +0200 In-Reply-To: <87o91vgco8.fsf@cbaines.net> (Christopher Baines's message of "Mon, 15 Jul 2019 23:23:19 +0100") Message-ID: <87ftn5ek9k.fsf@gnu.org> User-Agent: Gnus/5.13 (Gnus v5.13) Emacs/26.2 (gnu/linux) MIME-Version: 1.0 Content-Type: text/plain; charset=utf-8 Content-Transfer-Encoding: quoted-printable X-detected-operating-system: by eggs.gnu.org: GNU/Linux 2.2.x-3.x [generic] X-Spam-Score: -2.3 (--) X-Debbugs-Envelope-To: 35790-done Cc: 35790-done@debbugs.gnu.org X-BeenThere: debbugs-submit@debbugs.gnu.org X-Mailman-Version: 2.1.18 Precedence: list List-Id: List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: debbugs-submit-bounces@debbugs.gnu.org Sender: "Debbugs-submit" X-Spam-Score: -3.3 (---) Hi! Christopher Baines skribis: > Great, I've pushed these to master now. Yay! \o/ > I hope to start looking at actually trying to load in the lint warnings > soon. This might involve extending the inferior API if that's helpful. I > also want to attempt to store translations for the lint warnings in one > way or another, as that'll begin to address the lack of localisation in > the Guix Data Service. Regarding inferiors, you could always build up an =E2=80=9Cinferior lint warning=E2=80=9D API, similar to what=E2=80=99s done for = , and likewise for l10n. It needs some thought because we don=E2=80=99t want to mirror every single = Guix API with an inferior equivalent. So perhaps you can run a large part of the processing in the inferior. > There's also some thinking about how to manage the network dependent > checkers. I'd like to get that information in anyway, but also, I think > it might be possible to maybe separate out the network independant parts > of the checkers that are currently in the network dependent list. For > example, the synopsis checker is only in there as it attempts to connect > to the network to check if packages are a GNU package, and I'm wondering > if that can be avoided. Dunno, but I don=E2=80=99t think it=E2=80=99s super important either. What might be more useful is to indicate how critical a warning is: lack of source code is critical, but missing-space-after-period less so. > Anyway, hopefully the code refactoring is generally helpful, and maybe > the --no-network option for guix lint will come in useful as well. Definitely. Thanks! Ludo=E2=80=99. From unknown Thu Sep 11 20:11:55 2025 Received: (at fakecontrol) by fakecontrolmessage; To: internal_control@debbugs.gnu.org From: Debbugs Internal Request Subject: Internal Control Message-Id: bug archived. Date: Wed, 14 Aug 2019 11:24:05 +0000 User-Agent: Fakemail v42.6.9 # This is a fake control message. # # The action: # bug archived. thanks # This fakemail brought to you by your local debbugs # administrator