From mboxrd@z Thu Jan 1 00:00:00 1970 From: Christopher Baines Subject: Re: Linting, and how to get the information in to the Guix Data Serivce Date: Mon, 06 May 2019 20:10:18 +0100 Message-ID: <87d0kvo0v9.fsf@cbaines.net> References: <875zqnjv7h.fsf@cbaines.net> Mime-Version: 1.0 Content-Type: multipart/signed; boundary="==-=-="; micalg=pgp-sha512; protocol="application/pgp-signature" Return-path: Received: from eggs.gnu.org ([209.51.188.92]:35625) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1hNj0N-0003cl-4q for guix-devel@gnu.org; Mon, 06 May 2019 15:10:30 -0400 Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.71) (envelope-from ) id 1hNj0J-0007pU-Nz for guix-devel@gnu.org; Mon, 06 May 2019 15:10:27 -0400 Received: from mira.cbaines.net ([2a01:7e00::f03c:91ff:fe69:8da9]:44050) by eggs.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1hNj0J-0007mr-6a for guix-devel@gnu.org; Mon, 06 May 2019 15:10:23 -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 F0E1F16FA2 for ; Mon, 6 May 2019 20:10:20 +0100 (BST) Received: from capella (localhost [127.0.0.1]) by localhost (OpenSMTPD) with ESMTP id 6c54c5aa for ; Mon, 6 May 2019 19:10:20 +0000 (UTC) In-reply-to: <875zqnjv7h.fsf@cbaines.net> List-Id: "Development of GNU Guix and the GNU System distribution." List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: guix-devel-bounces+gcggd-guix-devel=m.gmane.org@gnu.org Sender: "Guix-devel" To: guix-devel@gnu.org --==-=-= Content-Type: multipart/mixed; boundary="=-=-=" --=-=-= Content-Type: text/plain Christopher Baines writes: > I've never worked with this part of Guix before, and some of it is quite > complex, so I've started by attempting to do the first bit, storing > warnings as data before outputting them. I've attached a patch. Now hopefuily with an actually attached patch... --=-=-= Content-Type: text/x-patch; charset=utf-8 Content-Disposition: attachment; filename=0001-scripts-lint-Handle-warnings-with-a-record-type.patch Content-Transfer-Encoding: quoted-printable Content-Description: Patch From=20cd16443893afdacf9f3e4d8256cc943a5928aed4 Mon Sep 17 00:00:00 2001 From: Christopher Baines Date: Mon, 6 May 2019 19:00:58 +0100 Subject: [PATCH] scripts: lint: Handle warnings with a record type. Rather than emiting warnings directly to a port, have the checkers return t= he 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. =2D-- guix/scripts/lint.scm | 501 ++++++++++++++++++++++-------------------- 1 file changed, 268 insertions(+), 233 deletions(-) diff --git a/guix/scripts/lint.scm b/guix/scripts/lint.scm index dc338a1d7b..878864030a 100644 =2D-- a/guix/scripts/lint.scm +++ b/guix/scripts/lint.scm @@ -93,42 +93,65 @@ =20 ;;; =2D;;; Helpers +;;; Warnings ;;; =2D(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-field + (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 an= d the ;; provided MESSAGE. =2D (let ((loc (or (package-field-location package field) =2D (package-location package)))) =2D (format (guix-warning-port) "~a: ~a@~a: ~a~%" =2D (location->string loc) =2D (package-name package) (package-version package) =2D message))) =2D =2D(define (call-with-accumulated-warnings thunk) =2D "Call THUNK, accumulating any warnings in the current state, using the= state =2Dmonad." =2D (let ((port (open-output-string))) =2D (mlet %state-monad ((state (current-state)) =2D (result -> (parameterize ((guix-warning-port po= rt)) =2D (thunk))) =2D (warning -> (get-output-string port))) =2D (mbegin %state-monad =2D (munless (string=3D? "" warning) =2D (set-current-state (cons warning state))) =2D (return result))))) =2D =2D(define-syntax-rule (with-accumulated-warnings exp ...) =2D "Evaluate EXP and accumulate warnings in the state monad." =2D (call-with-accumulated-warnings =2D (lambda () =2D 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 ;;; ;;; Checkers ;;; + (define-record-type* lint-checker make-lint-checker lint-checker? @@ -164,9 +187,9 @@ monad." ;; Emit a warning if stylistic issues are found in the description of PA= CKAGE. (define (check-not-empty description) (when (string-null? description) =2D (emit-warning package + (make-warning package (G_ "description should not be empty") =2D 'description))) + #:field 'description))) =20 (define (check-texinfo-markup description) "Check that DESCRIPTION can be parsed as a Texinfo fragment. If the @@ -174,39 +197,38 @@ markup is valid return a plain-text version of DESCRI= PTION, otherwise #f." (catch #t (lambda () (texi->plain-text description)) (lambda (keys . args) =2D (emit-warning package + (make-warning package (G_ "Texinfo markup in description is invalid") =2D 'description) =2D #f))) + #:field 'description)))) =20 (define (check-trademarks description) "Check that DESCRIPTION does not contain '=E2=84=A2' or '=C2=AE' chara= cters. 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) =2D (emit-warning package + (make-warning package (format #f (G_ "description should not contain ~ trademark sign '~a' at ~d") (string-ref description index) index) =2D '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) =2D (emit-warning package =2D + (make-warning package ;; TRANSLATORS: '@code' is Texinfo markup and must be = kept ;; as is. (G_ "use @code or similar ornament instead of quotes") =2D 'description))) + #:field 'description))) =20 (define (check-proper-start description) (unless (or (properly-starts-sentence? description) (string-prefix-ci? (package-name package) description)) =2D (emit-warning package =2D (G_ "description should start with an upper-case let= ter or digit") =2D '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 +242,30 @@ trademark sign '~a' at ~d") '("i.e" "e.g" "a.k.a" "resp")) r (cons (match:start m) r))))))) (unless (null? infractions) =2D (emit-warning package + (make-warning package (format #f (G_ "sentences in description should be f= ollowed ~ by two spaces; possible infraction~p at ~{~a~^, ~}") (length infractions) infractions) =2D 'description)))) + #:field 'description)))) =20 (let ((description (package-description package))) (if (string? description) =2D (begin =2D (check-not-empty description) =2D (check-quotes description) =2D (check-trademarks description) =2D ;; Use raw description for this because Texinfo rendering =2D ;; automatically fixes end of sentence space. =2D (check-end-of-sentence-space description) =2D (and=3D> (check-texinfo-markup description) =2D check-proper-start)) =2D (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") descriptio= n) =2D 'description)))) + #:field 'description)))) =20 (define (package-input-intersection inputs-to-check input-names) "Return the intersection between INPUTS-TO-CHECK, the list of input tupl= es @@ -281,13 +306,13 @@ of a package, and INPUT-NAMES, a list of package spec= ifications such as "python-pytest-cov" "python2-pytest-cov" "python-setuptools-scm" "python2-setuptools-scm" "python-sphinx" "python2-sphinx"))) =2D (for-each (lambda (input) =2D (emit-warning =2D package =2D (format #f (G_ "'~a' should probably be a native input") =2D input) =2D 'inputs-to-check)) =2D (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 be @@ -296,14 +321,15 @@ of a package, and INPUT-NAMES, a list of package spec= ifications such as "python2-setuptools" "python-pip" "python2-pip"))) =2D (for-each (lambda (input) =2D (emit-warning =2D package =2D (format #f =2D (G_ "'~a' should probably not be an input at al= l") =2D input))) =2D (package-input-intersection (package-direct-inputs package) =2D 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 beginning = of a @@ -316,17 +342,17 @@ line." ;; Emit a warning if stylistic issues are found in the synopsis of PACKA= GE. (define (check-not-empty synopsis) (when (string-null? synopsis) =2D (emit-warning package + (make-warning package (G_ "synopsis should not be empty") =2D 'synopsis))) + #:field 'synopsis))) =20 (define (check-final-period synopsis) ;; Synopsis should not end with a period, except for some special case= s. (when (and (string-suffix? "." synopsis) (not (string-suffix? "etc." synopsis))) =2D (emit-warning package + (make-warning package (G_ "no period allowed at the end of the synopsis") =2D 'synopsis))) + #:field 'synopsis))) =20 (define check-start-article ;; Skip this check for GNU packages, as suggested by Karl Berry's repl= y to @@ -336,29 +362,29 @@ line." (lambda (synopsis) (when (or (string-prefix-ci? "A " synopsis) (string-prefix-ci? "An " synopsis)) =2D (emit-warning package + (make-warning package (G_ "no article allowed at the beginning of \ the synopsis") =2D 'synopsis))))) + #:field 'synopsis))))) =20 (define (check-synopsis-length synopsis) (when (>=3D (string-length synopsis) 80) =2D (emit-warning package + (make-warning package (G_ "synopsis should be less than 80 characters long") =2D 'synopsis))) + #:field 'synopsis))) =20 (define (check-proper-start synopsis) (unless (properly-starts-sentence? synopsis) =2D (emit-warning package + (make-warning package (G_ "synopsis should start with an upper-case letter o= r digit") =2D '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))) =2D (emit-warning package + (make-warning package (G_ "synopsis should not start with the package name") =2D 'synopsis))) + #:field 'synopsis))) =20 (define (check-texinfo-markup synopsis) "Check that SYNOPSIS can be parsed as a Texinfo fragment. If the @@ -366,10 +392,9 @@ markup is valid return a plain-text version of SYNOPSI= S, otherwise #f." (catch #t (lambda () (texi->plain-text synopsis)) (lambda (keys . args) =2D (emit-warning package + (make-warning package (G_ "Texinfo markup in synopsis is invalid") =2D 'synopsis) =2D #f))) + #:field 'synopsis)))) =20 (define checks (list check-not-empty @@ -382,12 +407,13 @@ markup is valid return a plain-text version of SYNOPS= IS, otherwise #f." =20 (match (package-synopsis package) ((? string? synopsis) =2D (for-each (lambda (proc) =2D (proc synopsis)) =2D checks)) + (apply append-warnings + (map (lambda (proc) + (proc synopsis)) + checks))) (invalid =2D (emit-warning package (format #f (G_ "invalid synopsis: ~s") invali= d) =2D 'synopsis)))) + (make-warning package (format #f (G_ "invalid synopsis: ~s") invalid) + #:field 'synopsis)))) =20 (define* (probe-uri uri #:key timeout) "Probe URI, a URI object, and return two values: a symbol denoting the @@ -502,71 +528,66 @@ warning for PACKAGE mentionning the FIELD." ;; with a small HTML page upon failure. Attempt to detect ;; such malicious behavior. (or (> length 1000) =2D (begin =2D (emit-warning package =2D (format #f =2D (G_ "URI ~a returned \ + (make-warning package + (format #f + (G_ "URI ~a returned \ suspiciously small file (~a bytes)") =2D (uri->string uri) =2D length)) =2D #f))) + (uri->string uri) + length) + #:field field))) (_ #t))) ((=3D 301 (response-code argument)) (if (response-location argument) =2D (begin =2D (emit-warning package =2D (format #f (G_ "permanent redirect fro= m ~a to ~a") =2D (uri->string uri) =2D (uri->string =2D (response-location argument))= )) =2D #t) =2D (begin =2D (emit-warning package =2D (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 redirect= \ from ~a") =2D (uri->string uri))) =2D #f))) + (uri->string uri)) + #:field))) (else =2D (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)) =2D field) =2D #f))) + #:field field)))) ((ftp-response) (match argument (('ok) #t) (('error port command code message) =2D (emit-warning package + (make-warning package (format #f (G_ "URI ~a not reachable: ~a (~s)") (uri->string uri) =2D code (string-trim-both message))) =2D #f))) + code (string-trim-both message)) + #:field field)))) ((getaddrinfo-error) =2D (emit-warning package + (make-warning package (format #f (G_ "URI ~a domain not found: ~a") (uri->string uri) (gai-strerror (car argument))) =2D field) =2D #f) + #:field field)) ((system-error) =2D (emit-warning package + (make-warning package (format #f (G_ "URI ~a unreachable: ~a") (uri->string uri) (strerror (system-error-errno (cons status argument)))) =2D field) =2D #f) + #:field field)) ((tls-certificate-error) =2D (emit-warning package + (make-warning package (format #f (G_ "TLS certificate error: ~a") =2D (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 +606,13 @@ from ~a") ((not (package-home-page package)) (unless (or (string-contains (package-name package) "bootstrap") (string=3D? (package-name package) "ld-wrapper")) =2D (emit-warning package + (make-warning package (G_ "invalid value for home page") =2D 'home-page))) + #:field 'home-page))) (else =2D (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)) =2D 'home-page))))) + #:field 'home-page))))) =20 (define %distro-directory (mlambda () @@ -601,42 +622,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' =2D (emit-warning package (condition-message c) =2D 'patch-file-names))) + (make-warning package (condition-message c) + #:field 'patch-file-names))) (define patches (or (and=3D> (package-source package) origin-patches) '())) =20 =2D (unless (every (match-lambda ;patch starts with package name? + (cons* + (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 like = that. + patches) + (make-warning + package + (G_ "file names of patches should start with the package name") + #:field 'patch-file-names)) + + ;; Check whether we're reaching tar's maximum file name length. + (let ((prefix (string-length (%distro-directory))) + (margin (string-length "guix-0.13.0-10-123456789/")) + (max 99)) + (filter-map (match-lambda ((? string? patch) =2D (and=3D> (string-contains (basename patch) =2D (package-name package)) =2D zero?)) =2D (_ #f)) ;must be an or something like= that. =2D patches) =2D (emit-warning =2D package =2D (G_ "file names of patches should start with the package name") =2D 'patch-file-names)) =2D =2D ;; Check whether we're reaching tar's maximum file name length. =2D (let ((prefix (string-length (%distro-directory))) =2D (margin (string-length "guix-0.13.0-10-123456789/")) =2D (max 99)) =2D (for-each (match-lambda =2D ((? string? patch) =2D (when (> (+ margin (if (string-prefix? (%distro-direc= tory) =2D patch) =2D (- (string-length patch) prefi= x) =2D (string-length patch))) =2D max) =2D (emit-warning =2D package =2D (format #f (G_ "~a: file name is too long") =2D (basename patch)) =2D 'patch-file-names))) =2D (_ #f)) =2D patches)))) + (when (> (+ margin (if (string-prefix? (%distro-dire= ctory) + patch) + (- (string-length patch) pref= ix) + (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 +687,29 @@ descriptions maintained upstream." (#f ;not a GNU package, so nothing t= o do #t) (descriptor ;a genuine GNU package =2D (let ((upstream (gnu-package-doc-summary descriptor)) =2D (downstream (package-synopsis package)) =2D (loc (or (package-field-location package 'synopsis) =2D (package-location package)))) =2D (when (and upstream =2D (or (not (string? downstream)) =2D (not (string=3D? upstream downstream)))) =2D (format (guix-warning-port) =2D (G_ "~a: ~a: proposed synopsis: ~s~%") =2D (location->string loc) (package-full-name package) =2D upstream))) =2D =2D (let ((upstream (gnu-package-doc-description descriptor)) =2D (downstream (package-description package)) =2D (loc (or (package-field-location package 'description) =2D (package-location package)))) =2D (when (and upstream =2D (or (not (string? downstream)) =2D (not (string=3D? (fill-paragraph upstream 100) =2D (fill-paragraph downstream 100))))) =2D (format (guix-warning-port) =2D (G_ "~a: ~a: proposed description:~% \"~a\"~%") =2D (location->string loc) (package-full-name package) =2D (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 +722,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." =2D (define (try-uris uris) =2D (run-with-state =2D (anym %state-monad =2D (lambda (uri) =2D (with-accumulated-warnings =2D (validate-uri uri package 'source))) =2D (append-map (cut maybe-expand-mirrors <> %mirrors) =2D uris)) =2D '())) + (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)) =2D (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. =2D (call-with-values =2D (lambda () (try-uris uris)) =2D (lambda (success? warnings) + (if (eq? (length uris) (length warnings)) ;; When everything fails, report all of WARNINGS, otherwise do= n't ;; report anything. ;; ;; XXX: Ideally we'd still allow warnings to be raised if *som= e* ;; URIs are unreachable, but distinguish that from the error c= ase ;; where *all* the URIs are unreachable. =2D (unless success? =2D (emit-warning package =2D (G_ "all the source URIs are unreachable:") =2D 'source) =2D (for-each (lambda (warning) =2D (display warning (guix-warning-port))) =2D (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 +766,9 @@ descriptions maintained upstream." =20 (let ((origin (package-source package))) (unless (or (not origin) (origin-file-name-valid? origin)) =2D (emit-warning package + (make-warning package (G_ "the source file name should contain the package n= ame") =2D 'source)))) + #:field 'source)))) =20 (define (check-source-unstable-tarball package) "Emit a warning if PACKAGE's source is an autogenerated tarball." @@ -761,14 +778,14 @@ descriptions maintained upstream." (uri-path (string->uri uri))) ((_ _ "archive" _ ...) #t) (_ #f))) =2D (emit-warning package + (make-warning package (G_ "the source URI should not be an autogenerated tar= ball") =2D 'source))) + #:field 'source))) (let ((origin (package-source package))) (when (and (origin? origin) (eqv? (origin-method origin) url-fetch)) (let ((uris (origin-uris origin))) =2D (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 +799,18 @@ descriptions maintained upstream." (#f (loop rest)) (prefix =2D (emit-warning package + (make-warning package (format #f (G_ "URL should be \ 'mirror://~a/~a'") mirror-id (string-drop uri (string-length prefix))) =2D 'source))))))) + #:field 'source))))))) =20 (let ((origin (package-source package))) (when (and (origin? origin) (eqv? (origin-method origin) url-fetch)) (let ((uris (origin-uris origin))) =2D (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 +836,15 @@ descriptions maintained upstream." (let ((origin (package-source package))) (when (and (origin? origin) (eqv? (origin-method origin) url-fetch)) =2D (for-each + (filter-map (lambda (uri) (and=3D> (follow-redirects-to-github uri) (lambda (github-uri) (unless (string=3D? github-uri uri) =2D (emit-warning + (make-warning package (format #f (G_ "URL should be '~a'") github-uri) =2D 'source))))) + #:field 'source))))) (origin-uris origin))))) =20 (define (check-derivation package) @@ -836,12 +853,12 @@ descriptions maintained upstream." (catch #t (lambda () (guard (c ((store-protocol-error? c) =2D (emit-warning package + (make-warning package (format #f (G_ "failed to create ~a deriv= ation: ~a") system (store-protocol-error-message c))= )) ((message-condition? c) =2D (emit-warning package + (make-warning package (format #f (G_ "failed to create ~a deriv= ation: ~a") system (condition-message c))))) @@ -858,11 +875,11 @@ descriptions maintained upstream." (package-derivation store replacement system #:graft? #f))))))) (lambda args =2D (emit-warning package + (make-warning package (format #f (G_ "failed to create ~a derivation: ~s") system args))))) =20 =2D (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 +888,8 @@ descriptions maintained upstream." ((? license?) ...)) #t) (x =2D (emit-warning package (G_ "invalid license field") =2D '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 error, @@ -944,10 +961,10 @@ the NIST server non-fatal." (member id known-safe)))) vulnerabilities))) (unless (null? unpatched) =2D (emit-warning package =2D (format #f (G_ "probably vulnerable to ~a") =2D (string-join (map vulnerability-id unpa= tched) =2D ", "))))))))) + (make-warning package + (format #f (G_ "probably vulnerable to ~a") + (string-join (map vulnerability-id u= npatched) + ", "))))))))) =20 (define (check-for-updates package) "Check if there is an update available for PACKAGE." @@ -959,9 +976,10 @@ the NIST server non-fatal." ((? upstream-source? source) (when (version>? (upstream-source-version source) (package-version package)) =2D (emit-warning package + (make-warning package (format #f (G_ "can be upgraded to ~a") =2D (upstream-source-version source))))) + (upstream-source-version source)) + #:field 'version))) (#f #f))) ; cannot find newer upstream release =20 @@ -974,18 +992,26 @@ the NIST server non-fatal." (match (string-index line #\tab) (#f #t) (index =2D (emit-warning package + (make-warning package (format #f (G_ "tabulation on line ~a, column ~a") =2D 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))) =2D (emit-warning package + (make-warning package (format #f (G_ "trailing white space on line ~a") =2D 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 +1019,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) =2D (emit-warning package + (make-warning package (format #f (G_ "line ~a is way too long (~a characters)") =2D 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 +1033,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) =2D (emit-warning package + (make-warning package (format #f =2D (G_ "line ~a: parentheses feel lonely, \ + (G_ "parentheses feel lonely, \ move to the previous or next line") =2D 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 sepa= rate @@ -1155,7 +1189,8 @@ or a list thereof") (package-name package) (package-version package) (lint-checker-name checker)) (force-output (current-error-port))) =2D ((lint-checker-check checker) package)) + (emit-warnings + ((lint-checker-check checker) package))) checkers) (when tty? (format (current-error-port) "\x1b[K") =2D-=20 2.21.0 --=-=-=-- --==-=-= Content-Type: application/pgp-signature; name="signature.asc" -----BEGIN PGP SIGNATURE----- iQKTBAEBCgB9FiEEPonu50WOcg2XVOCyXiijOwuE9XcFAlzQhppfFIAAAAAALgAo aXNzdWVyLWZwckBub3RhdGlvbnMub3BlbnBncC5maWZ0aGhvcnNlbWFuLm5ldDNF ODlFRUU3NDU4RTcyMEQ5NzU0RTBCMjVFMjhBMzNCMEI4NEY1NzcACgkQXiijOwuE 9Xd2FxAAqQ/4O9nssadr3QfqIy2QxKES3H3BhMECPnmAPAqPEWssMdBU/UkkKZxR AhtCumyJZQzIoZrxJSvCjDGXdDrxr4/uRSCzkA7WVatnXK4MiPv03dMA3XJcAP4Q mo4egOvSJAzkaz303NO1XKy3oN01Hts0or9KMnPjLNLDdzhKFNmX48+RwzDOhLE/ xvud1o56d0LlcLOyO1t/QazfCf5VOQcugzMDttGzRWEurQDeJ8fpT6kqJyY61AHA 3xCWt6qvoozu2L/Wn36tqgtYkeaD0aAsfgaUDr7B8nJb/7xhYsuakjtAH33PL83h TA5+cN5Bc+MNL9Y/Cf/clzvMSHIhF45cdsYhYMdGLeXTDdoj/xyf43VJXn1q8Zo7 xlN7l5NI8u6jOW4WjYxGTy/lAzOhsc+3qaim6aDYBVRcVWtabgxt+107RReiOaUu FM3qVW91fCuU4xJeo/rZAE2h87g1HG6uPpCJgu3EaAK256nQqYMdME5R1sawyI8T 4Mx1gpwlxLx5giCqlIjwrJe6uAZV20PQO4+5OoBxMcQ03CYPH1TQQTMe/BWDcNpK tRO+tMyPtZTZetHgBz2SqLatH05yDug12WN0/OlfhDn/cfxYRtRCttC0lANWnrG0 hmKbP013+DlwtlwKL6uphOtxJgkOGG1oLk+0ID2TEvDVDyJAjxo= =cwzk -----END PGP SIGNATURE----- --==-=-=--