diff options
Diffstat (limited to 'guix/lint.scm')
-rw-r--r-- | guix/lint.scm | 274 |
1 files changed, 225 insertions, 49 deletions
diff --git a/guix/lint.scm b/guix/lint.scm index 198e091f47..d76a2f5e03 100644 --- a/guix/lint.scm +++ b/guix/lint.scm @@ -13,6 +13,7 @@ ;;; Copyright © 2020 Timothy Sample <samplet@ngyro.com> ;;; Copyright © 2021 Xinglu Chen <public@yoctocell.xyz> ;;; Copyright © 2021 Maxime Devos <maximedevos@telenet.be> +;;; Copyright © 2021 Brice Waegeneire <brice@waegenei.re> ;;; ;;; This file is part of GNU Guix. ;;; @@ -40,7 +41,8 @@ #:use-module (guix packages) #:use-module (guix i18n) #:use-module ((guix gexp) - #:select (local-file? local-file-absolute-file-name)) + #:select (gexp? local-file? local-file-absolute-file-name + gexp->approximate-sexp)) #:use-module (guix licenses) #:use-module (guix records) #:use-module (guix grafts) @@ -68,6 +70,7 @@ . guix:open-connection-for-uri))) #:use-module (web request) #:use-module (web response) + #:autoload (gnutls) (error->string) #:use-module (srfi srfi-1) #:use-module (srfi srfi-6) ;Unicode string ports #:use-module (srfi srfi-9) @@ -80,6 +83,7 @@ check-inputs-should-be-native check-inputs-should-not-be-an-input-at-all check-input-labels + check-wrapper-inputs check-patch-file-names check-patch-headers check-synopsis-style @@ -89,6 +93,7 @@ check-source check-source-file-name check-source-unstable-tarball + check-optional-tests check-mirror-url check-github-url check-license @@ -161,6 +166,78 @@ ;;; +;;; Procedures for analysing Scheme code in package definitions +;;; + +(define* (find-procedure-body expression found + #:key (not-found (const '()))) + "Try to find the body of the procedure defined inline by EXPRESSION. +If it was found, call FOUND with its body. If it wasn't, call +the thunk NOT-FOUND." + (match expression + (`(,(or 'let 'let*) . ,_) + (find-procedure-body (car (last-pair expression)) found + #:not-found not-found)) + (`(,(or 'lambda 'lambda*) ,_ . ,code) + (found code)) + (_ (not-found)))) + +(define* (report-bogus-phase-deltas package bogus-deltas) + "Report a bogus invocation of ‘modify-phases’." + (list (make-warning package + ;; TRANSLATORS: 'modify-phases' is a Scheme syntax + ;; and should not be translated. + (G_ "incorrect call to ‘modify-phases’") + #:field 'arguments))) + +(define* (find-phase-deltas package found + #:key (not-found (const '())) + (bogus + (cut report-bogus-phase-deltas package <>))) + "Try to find the clauses of the ‘modify-phases’ form in the phases +specification of PACKAGE. If they were found, all FOUND with a list +of the clauses. If they weren't (e.g. because ‘modify-phases’ wasn't +used at all), call the thunk NOT-FOUND instead. If ‘modify-phases’ +was used, but the clauses don't form a list, call BOGUS with the +not-a-list." + (apply (lambda* (#:key phases #:allow-other-keys) + (define phases/sexp + (if (gexp? phases) + (gexp->approximate-sexp phases) + phases)) + (match phases/sexp + (`(modify-phases ,_ . ,changes) + ((if (list? changes) found bogus) changes)) + (_ (not-found)))) + (package-arguments package))) + +(define (report-bogus-phase-procedure package) + "Report a syntactically-invalid phase clause." + (list (make-warning package + ;; TRANSLATORS: See ‘modify-phases’ in the manual. + (G_ "invalid phase clause") + #:field 'arguments))) + +(define* (find-phase-procedure package expression found + #:key (not-found (const '())) + (bogus (cut report-bogus-phase-procedure + package))) + "Try to find the procedure in the phase clause EXPRESSION. If it was +found, call FOUND with the procedure expression. If EXPRESSION isn't +actually a phase clause, call the thunk BOGUS. If the phase form doesn't +have a procedure, call the thunk NOT-FOUND." + (match expression + (('add-after before after proc-expr) + (found proc-expr)) + (('add-before after before proc-expr) + (found proc-expr)) + (('replace _ proc-expr) + (found proc-expr)) + (('delete _) (not-found)) + (_ (bogus)))) + + +;;; ;;; Checkers ;;; @@ -301,6 +378,15 @@ by two spaces; possible infraction~p at ~{~a~^, ~}") infractions) #:field 'description))))) + (define (check-no-leading-whitespace description) + "Check that DESCRIPTION doesn't have trailing whitespace." + (if (string-prefix? " " description) + (list + (make-warning package + (G_ "description contains leading whitespace") + #:field 'description)) + '())) + (define (check-no-trailing-whitespace description) "Check that DESCRIPTION doesn't have trailing whitespace." (if (string-suffix? " " description) @@ -319,6 +405,7 @@ by two spaces; possible infraction~p at ~{~a~^, ~}") ;; Use raw description for this because Texinfo rendering ;; automatically fixes end of sentence space. (check-end-of-sentence-space description) + (check-no-leading-whitespace description) (check-no-trailing-whitespace description) (match (check-texinfo-markup description) ((and warning (? lint-warning?)) (list warning)) @@ -448,6 +535,49 @@ of a package, and INPUT-NAMES, a list of package specifications such as (inputs ,package-inputs) (propagated-inputs ,package-propagated-inputs)))) +(define (report-wrap-program-error package wrapper-name) + "Warn that \"bash-minimal\" is missing from 'inputs', while WRAPPER-NAME +requires it." + (make-warning package + (G_ "\"bash-minimal\" should be in 'inputs' when '~a' is used") + (list wrapper-name))) + +(define (check-wrapper-inputs package) + "Emit a warning if PACKAGE uses 'wrap-program' or similar, but \"bash\" +or \"bash-minimal\" is not in its inputs. 'wrap-script' is not supported." + (define input-names '("bash" "bash-minimal")) + (define has-bash-input? + (pair? (package-input-intersection (package-inputs package) + input-names))) + (define (check-procedure-body body) + (match body + ;; Explicitely setting an interpreter is acceptable, + ;; #:sh support is added on 'core-updates'. + ;; TODO(core-updates): remove mention of core-updates. + (('wrap-program _ '#:sh . _) '()) + (('wrap-program _ . _) + (list (report-wrap-program-error package 'wrap-program))) + ;; Wrapper of 'wrap-program' for Qt programs. + ;; TODO #:sh is not yet supported but probably will be. + (('wrap-qt-program _ '#:sh . _) '()) + (('wrap-qt-program _ . _) + (list (report-wrap-program-error package 'wrap-qt-program))) + ((x . y) + (append (check-procedure-body x) (check-procedure-body y))) + (_ '()))) + (define (check-phase-procedure expression) + (find-procedure-body expression check-procedure-body)) + (define (check-delta expression) + (find-phase-procedure package expression check-phase-procedure)) + (define (check-deltas deltas) + (append-map check-delta deltas)) + (if has-bash-input? + ;; "bash" (or "bash-minimal") is in 'inputs', so everything seems ok. + '() + ;; "bash" is not in 'inputs'. Verify 'wrap-program' and friends + ;; are unused + (find-phase-deltas package check-deltas))) + (define (package-name-regexp package) "Return a regexp that matches PACKAGE's name as a word at the beginning of a line." @@ -648,6 +778,51 @@ for connections to complete; when TIMEOUT is #f, wait as long as needed." (_ (values 'unknown-protocol #f))))) +(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) + (('gnutls-error error function _ ...) + (warning (G_ "~a: TLS error in '~a': ~a~%") + message + function (error->string error)) + error-value) + ((and ('system-error _ ...) args) + (let ((errno (system-error-errno args))) + (if (member errno (list ECONNRESET ECONNABORTED ECONNREFUSED)) + (let ((details (call-with-output-string + (lambda (port) + (print-exception port #f (car args) + (cdr args)))))) + (warning (G_ "~a: ~a~%") message details) + error-value) + (apply throw args)))) + (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 (tls-certificate-error-string args) "Return a string explaining the 'tls-certificate-error' arguments ARGS." (call-with-output-string @@ -1066,15 +1241,17 @@ descriptions maintained upstream." (eqv? (origin-method origin) url-fetch)) (filter-map (lambda (uri) - (and=> (follow-redirects-to-github uri) + (and=> (with-networking-fail-safe + (format #f (G_ "while accessing '~a'") uri) + #f + (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))))) + (and (not (string=? github-uri uri)) + (make-warning + package + (G_ "URL should be '~a'") + (list github-uri) + #:field 'source))))) (origin-uris origin)) '()))) @@ -1082,6 +1259,37 @@ descriptions maintained upstream." (define exception-with-kind-and-args? (exception-predicate &exception-with-kind-and-args)) +(define (check-optional-tests package) + "Emit a warning if the test suite is run unconditionally." + (define (sexp-contains-atom? sexp atom) + "Test if SEXP contains ATOM." + (if (pair? sexp) + (or (sexp-contains-atom? (car sexp) atom) + (sexp-contains-atom? (cdr sexp) atom)) + (eq? sexp atom))) + (define (sexp-uses-tests?? sexp) + "Test if SEXP contains the symbol 'tests?'." + (sexp-contains-atom? sexp 'tests?)) + (define (check-procedure-body code) + (if (sexp-uses-tests?? code) + '() + (list (make-warning package + ;; TRANSLATORS: check and #:tests? are a + ;; Scheme symbol and keyword respectively + ;; and should not be translated. + (G_ "the 'check' phase should respect #:tests?") + #:field 'arguments)))) + (define (check-check-procedure expression) + (find-procedure-body expression check-procedure-body)) + (define (check-phases-delta delta) + (match delta + (`(replace 'check ,expression) + (check-check-procedure expression)) + (_ '()))) + (define (check-phases-deltas deltas) + (append-map check-phases-delta deltas)) + (find-phase-deltas package check-phases-deltas)) + (define* (check-derivation package #:key store) "Emit a warning if we fail to compile PACKAGE to a derivation." (define (try store system) @@ -1171,46 +1379,6 @@ of the propagated inputs it pulls in." (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) - ((and ('system-error _ ...) args) - (let ((errno (system-error-errno args))) - (if (member errno (list ECONNRESET ECONNABORTED ECONNREFUSED)) - (let ((details (call-with-output-string - (lambda (port) - (print-exception port #f (car args) - (cdr args)))))) - (warning (G_ "~a: ~a~%") message details) - error-value) - (apply throw args)))) - (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 @@ -1620,6 +1788,10 @@ them for PACKAGE." (description "Identify input labels that do not match package names") (check check-input-labels)) (lint-checker + (name 'wrapper-inputs) + (description "Make sure 'wrap-program' can finds its interpreter.") + (check check-wrapper-inputs)) + (lint-checker (name 'license) ;; TRANSLATORS: <license> is the name of a data type and must not be ;; translated. @@ -1627,6 +1799,10 @@ them for PACKAGE." or a list thereof") (check check-license)) (lint-checker + (name 'optional-tests) + (description "Make sure tests are only run when requested") + (check check-optional-tests)) + (lint-checker (name 'mirror-url) (description "Suggest 'mirror://' URLs") (check check-mirror-url)) |