nixo
/
guix-devel
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

scripts: lint: Separate the message warning text and data. 

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.
This commit is contained in:
Christopher Baines 2019-06-16 13:52:13 +01:00
parent 50fc2384fe
commit 57238532f4
No known key found for this signature in database
GPG Key ID: 5E28A33B0B84F577
1 changed files with 106 additions and 92 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

198
guix/scripts/lint.scm
View File

@ -88,6 +88,8 @@
lint-warning? lint-warning?
lint-warning-package lint-warning-package
lint-warning-message lint-warning-message
lint-warning-message-text
lint-warning-message-data
lint-warning-location lint-warning-location
%checkers %checkers
@ -105,35 +107,49 @@
(define-record-type* <lint-warning> (define-record-type* <lint-warning>
lint-warning make-lint-warning lint-warning make-lint-warning
lint-warning? lint-warning?
(package lint-warning-package) (package lint-warning-package)
(message lint-warning-message) (message-text lint-warning-message-text)
(location lint-warning-location (message-data lint-warning-message-data
(default #f))) (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) (define (package-file package)
(location-file (location-file
(package-location package))) (package-location package)))
(define* (make-warning package message (define* (%make-warning package message-text
#:key field location) #:optional (message-data '())
#:key field location)
(make-lint-warning (make-lint-warning
package package
message message-text
message-data
(or location (or location
(package-field-location package field) (package-field-location package field)
(package-location package)))) (package-location package))))
(define-syntax make-warning
(syntax-rules (G_)
((_ package (G_ message) rest ...)
(%make-warning package message rest ...))))
(define (emit-warnings warnings) (define (emit-warnings warnings)
;; Emit a warning about PACKAGE, printing the location of FIELD if it is ;; 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 ;; given, the location of PACKAGE otherwise, the full name of PACKAGE and the
;; provided MESSAGE. ;; provided MESSAGE.
(for-each (for-each
(match-lambda (match-lambda
(($ <lint-warning> package message loc) (($ <lint-warning> package message-text message-data loc)
(format (guix-warning-port) "~a: ~a@~a: ~a~%" (format (guix-warning-port) "~a: ~a@~a: ~a~%"
(location->string loc) (location->string loc)
(package-name package) (package-version package) (package-name package) (package-version package)
message))) (apply format #f (G_ message-text) message-data))))
warnings)) warnings))
@ -199,9 +215,9 @@ http://www.gnu.org/prep/standards/html_node/Trademarks.html."
((and (? number?) index) ((and (? number?) index)
(list (list
(make-warning package (make-warning package
(format #f (G_ "description should not contain ~ (G_ "description should not contain ~
trademark sign '~a' at ~d") trademark sign '~a' at ~d")
(string-ref description index) index) (list (string-ref description index) index)
#:field 'description))) #:field 'description)))
(else '()))) (else '())))
@ -242,10 +258,10 @@ trademark sign '~a' at ~d")
'() '()
(list (list
(make-warning package (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~^, ~}") by two spaces; possible infraction~p at ~{~a~^, ~}")
(length infractions) (list (length infractions)
infractions) infractions)
#:field 'description))))) #:field 'description)))))
(let ((description (package-description package))) (let ((description (package-description package)))
@ -263,7 +279,8 @@ by two spaces; possible infraction~p at ~{~a~^, ~}")
(check-proper-start plain-description)))) (check-proper-start plain-description))))
(list (list
(make-warning package (make-warning package
(format #f (G_ "invalid description: ~s") description) (G_ "invalid description: ~s")
(list description)
#:field 'description))))) #:field 'description)))))
(define (package-input-intersection inputs-to-check input-names) (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) (map (lambda (input)
(make-warning (make-warning
package package
(format #f (G_ "'~a' should probably be a native input") (G_ "'~a' should probably be a native input")
input) (list input)
#:field 'inputs)) #:field 'inputs))
(package-input-intersection inputs input-names)))) (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) (map (lambda (input)
(make-warning (make-warning
package package
(format #f (G_ "'~a' should probably not be an input at all")
(G_ "'~a' should probably not be an input at all") (list input)
input)
#:field 'inputs)) #:field 'inputs))
(package-input-intersection (package-direct-inputs package) (package-input-intersection (package-direct-inputs package)
input-names)))) input-names))))
@ -423,7 +439,9 @@ markup is valid return a plain-text version of SYNOPSIS, otherwise #f."
checks)) checks))
(invalid (invalid
(list (list
(make-warning package (format #f (G_ "invalid synopsis: ~s") invalid) (make-warning package
(G_ "invalid synopsis: ~s")
(list invalid)
#:field 'synopsis))))) #:field 'synopsis)))))
(define* (probe-uri uri #:key timeout) (define* (probe-uri uri #:key timeout)
@ -540,64 +558,59 @@ PACKAGE mentionning the FIELD."
;; such malicious behavior. ;; such malicious behavior.
(or (> length 1000) (or (> length 1000)
(make-warning package (make-warning package
(format #f (G_ "URI ~a returned \
(G_ "URI ~a returned \
suspiciously small file (~a bytes)") suspiciously small file (~a bytes)")
(uri->string uri) (list (uri->string uri)
length) length)
#:field field))) #:field field)))
(_ #t))) (_ #t)))
((= 301 (response-code argument)) ((= 301 (response-code argument))
(if (response-location argument) (if (response-location argument)
(make-warning package (make-warning package
(format #f (G_ "permanent redirect from ~a to ~a") (G_ "permanent redirect from ~a to ~a")
(uri->string uri) (list (uri->string uri)
(uri->string (uri->string
(response-location argument))) (response-location argument)))
#:field field) #:field field)
(make-warning package (make-warning package
(format #f (G_ "invalid permanent redirect \ (G_ "invalid permanent redirect \
from ~a") from ~a")
(uri->string uri)) (list (uri->string uri))
#:field field))) #:field field)))
(else (else
(make-warning package (make-warning package
(format #f (G_ "URI ~a not reachable: ~a (~s)")
(G_ "URI ~a not reachable: ~a (~s)") (list (uri->string uri)
(uri->string uri) (response-code argument)
(response-code argument) (response-reason-phrase argument))
(response-reason-phrase argument))
#:field field)))) #:field field))))
((ftp-response) ((ftp-response)
(match argument (match argument
(('ok) #t) (('ok) #t)
(('error port command code message) (('error port command code message)
(make-warning package (make-warning package
(format #f (G_ "URI ~a not reachable: ~a (~s)")
(G_ "URI ~a not reachable: ~a (~s)") (list (uri->string uri)
(uri->string uri) code (string-trim-both message))
code (string-trim-both message))
#:field field)))) #:field field))))
((getaddrinfo-error) ((getaddrinfo-error)
(make-warning package (make-warning package
(format #f (G_ "URI ~a domain not found: ~a")
(G_ "URI ~a domain not found: ~a") (list (uri->string uri)
(uri->string uri) (gai-strerror (car argument)))
(gai-strerror (car argument)))
#:field field)) #:field field))
((system-error) ((system-error)
(make-warning package (make-warning package
(format #f (G_ "URI ~a unreachable: ~a")
(G_ "URI ~a unreachable: ~a") (list (uri->string uri)
(uri->string uri) (strerror
(strerror (system-error-errno
(system-error-errno (cons status argument))))
(cons status argument))))
#:field field)) #:field field))
((tls-certificate-error) ((tls-certificate-error)
(make-warning package (make-warning package
(format #f (G_ "TLS certificate error: ~a") (G_ "TLS certificate error: ~a")
(tls-certificate-error-string argument)) (list (tls-certificate-error-string argument))
#:field field)) #:field field))
((invalid-http-response gnutls-error) ((invalid-http-response gnutls-error)
;; Probably a misbehaving server; ignore. ;; Probably a misbehaving server; ignore.
@ -627,8 +640,9 @@ from ~a")
#:field 'home-page)))) #:field 'home-page))))
(else (else
(list (list
(make-warning package (format #f (G_ "invalid home page URL: ~s") (make-warning package
(package-home-page package)) (G_ "invalid home page URL: ~s")
(list (package-home-page package))
#:field 'home-page)))))) #:field 'home-page))))))
(define %distro-directory (define %distro-directory
@ -640,8 +654,10 @@ from ~a")
patch could not be found." patch could not be found."
(guard (c ((message-condition? c) ;raised by 'search-patch' (guard (c ((message-condition? c) ;raised by 'search-patch'
(list (list
(make-warning package (condition-message c) ;; Use %make-warning, as condition-mesasge is already
#:field 'patch-file-names)))) ;; translated.
(%make-warning package (condition-message c)
#:field 'patch-file-names))))
(define patches (define patches
(or (and=> (package-source package) origin-patches) (or (and=> (package-source package) origin-patches)
'())) '()))
@ -674,8 +690,8 @@ patch could not be found."
max) max)
(make-warning (make-warning
package package
(format #f (G_ "~a: file name is too long") (G_ "~a: file name is too long")
(basename patch)) (list (basename patch))
#:field 'patch-file-names) #:field 'patch-file-names)
#f)) #f))
(_ #f)) (_ #f))
@ -716,8 +732,8 @@ descriptions maintained upstream."
(not (string=? upstream downstream)))) (not (string=? upstream downstream))))
(list (list
(make-warning package (make-warning package
(format #f (G_ "proposed synopsis: ~s~%") (G_ "proposed synopsis: ~s~%")
upstream) (list upstream)
#:field 'synopsis)) #:field 'synopsis))
'())) '()))
@ -730,9 +746,8 @@ descriptions maintained upstream."
(list (list
(make-warning (make-warning
package package
(format #f (G_ "proposed description:~% \"~a\"~%")
(G_ "proposed description:~% \"~a\"~%") (list (fill-paragraph (escape-quotes upstream) 77 7))
(fill-paragraph (escape-quotes upstream) 77 7))
#:field 'description)) #:field 'description))
'())))))) '()))))))
@ -831,10 +846,10 @@ descriptions maintained upstream."
(loop rest)) (loop rest))
(prefix (prefix
(make-warning package (make-warning package
(format #f (G_ "URL should be \ (G_ "URL should be \
'mirror://~a/~a'") 'mirror://~a/~a'")
mirror-id (list mirror-id
(string-drop uri (string-length prefix))) (string-drop uri (string-length prefix)))
#:field 'source))))))) #:field 'source)))))))
(let ((origin (package-source package))) (let ((origin (package-source package)))
@ -876,7 +891,8 @@ descriptions maintained upstream."
#f #f
(make-warning (make-warning
package package
(format #f (G_ "URL should be '~a'") github-uri) (G_ "URL should be '~a'")
(list github-uri)
#:field 'source))))) #:field 'source)))))
(origin-uris origin)) (origin-uris origin))
'()))) '())))
@ -888,14 +904,14 @@ descriptions maintained upstream."
(lambda () (lambda ()
(guard (c ((store-protocol-error? c) (guard (c ((store-protocol-error? c)
(make-warning package (make-warning package
(format #f (G_ "failed to create ~a derivation: ~a") (G_ "failed to create ~a derivation: ~a")
system (list system
(store-protocol-error-message c)))) (store-protocol-error-message c))))
((message-condition? c) ((message-condition? c)
(make-warning package (make-warning package
(format #f (G_ "failed to create ~a derivation: ~a") (G_ "failed to create ~a derivation: ~a")
system (list system
(condition-message c))))) (condition-message c)))))
(with-store store (with-store store
;; Disable grafts since it can entail rebuilds. ;; Disable grafts since it can entail rebuilds.
(parameterize ((%graft? #f)) (parameterize ((%graft? #f))
@ -910,8 +926,8 @@ descriptions maintained upstream."
#:graft? #f))))))) #:graft? #f)))))))
(lambda args (lambda args
(make-warning package (make-warning package
(format #f (G_ "failed to create ~a derivation: ~s") (G_ "failed to create ~a derivation: ~s")
system args))))) (list system args)))))
(filter lint-warning? (filter lint-warning?
(map try (package-supported-systems package)))) (map try (package-supported-systems package))))
@ -1001,15 +1017,15 @@ the NIST server non-fatal."
(list (list
(make-warning (make-warning
package package
(format #f (G_ "probably vulnerable to ~a") (G_ "probably vulnerable to ~a")
(string-join (map vulnerability-id unpatched) (list (string-join (map vulnerability-id unpatched)
", ")))))))))) ", "))))))))))
(define (check-for-updates package) (define (check-for-updates package)
"Check if there is an update available for PACKAGE." "Check if there is an update available for PACKAGE."
(match (with-networking-fail-safe (match (with-networking-fail-safe
(format #f (G_ "while retrieving upstream info for '~a'") (G_ "while retrieving upstream info for '~a'")
(package-name package)) (list (package-name package))
#f #f
(package-latest-release* package (force %updaters))) (package-latest-release* package (force %updaters)))
((? upstream-source? source) ((? upstream-source? source)
@ -1017,8 +1033,8 @@ the NIST server non-fatal."
(package-version package)) (package-version package))
(list (list
(make-warning package (make-warning package
(format #f (G_ "can be upgraded to ~a") (G_ "can be upgraded to ~a")
(upstream-source-version source)) (list (upstream-source-version source))
#:field 'version)) #:field 'version))
'())) '()))
(#f '()))) ; cannot find newer upstream release (#f '()))) ; cannot find newer upstream release
@ -1034,8 +1050,8 @@ the NIST server non-fatal."
(#f #t) (#f #t)
(index (index
(make-warning package (make-warning package
(format #f (G_ "tabulation on line ~a, column ~a") (G_ "tabulation on line ~a, column ~a")
line-number index) (list line-number index)
#:location #:location
(location (package-file package) (location (package-file package)
line-number line-number
@ -1046,9 +1062,8 @@ the NIST server non-fatal."
(unless (or (string=? line (string-trim-right line)) (unless (or (string=? line (string-trim-right line))
(string=? line (string #\page))) (string=? line (string #\page)))
(make-warning package (make-warning package
(format #f (G_ "trailing white space on line ~a")
(G_ "trailing white space on line ~a") (list line-number)
line-number)
#:location #:location
(location (package-file package) (location (package-file package)
line-number line-number
@ -1061,8 +1076,8 @@ the NIST server non-fatal."
;; much noise. ;; much noise.
(when (> (string-length line) 90) (when (> (string-length line) 90)
(make-warning package (make-warning package
(format #f (G_ "line ~a is way too long (~a characters)") (G_ "line ~a is way too long (~a characters)")
line-number (string-length line)) (list line-number (string-length line))
#:location #:location
(location (package-file package) (location (package-file package)
line-number line-number
@ -1075,10 +1090,9 @@ the NIST server non-fatal."
"Emit a warning if LINE contains hanging parentheses." "Emit a warning if LINE contains hanging parentheses."
(when (regexp-exec %hanging-paren-rx line) (when (regexp-exec %hanging-paren-rx line)
(make-warning package (make-warning package
(format #f (G_ "parentheses feel lonely, \
(G_ "parentheses feel lonely, \
move to the previous or next line") move to the previous or next line")
line-number) (list line-number)
#:location #:location
(location (package-file package) (location (package-file package)
line-number line-number