From f363c836e0b4c416dae594af4257459da592b35c Mon Sep 17 00:00:00 2001 From: Christopher Baines Date: Tue, 2 Jul 2019 20:25:41 +0100 Subject: lint: Move the linting code to a different module. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit 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). --- guix/scripts/lint.scm | 1220 +------------------------------------------------ 1 file changed, 19 insertions(+), 1201 deletions(-) (limited to 'guix/scripts/lint.scm') 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. -- cgit v1.2.3