diff options
Diffstat (limited to 'guix/lint.scm')
| -rw-r--r-- | guix/lint.scm | 498 |
1 files changed, 388 insertions, 110 deletions
diff --git a/guix/lint.scm b/guix/lint.scm index a7d6bbba4f..527fda165a 100644 --- a/guix/lint.scm +++ b/guix/lint.scm @@ -11,6 +11,9 @@ ;;; Copyright © 2018, 2019 Arun Isaac <arunisaac@systemreboot.net> ;;; Copyright © 2020 Chris Marusich <cmmarusich@gmail.com> ;;; 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. ;;; @@ -29,6 +32,7 @@ (define-module (guix lint) #:use-module (guix store) + #:autoload (guix base16) (bytevector->base16-string) #:use-module (guix base32) #:use-module (guix diagnostics) #:use-module (guix download) @@ -37,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) @@ -65,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) @@ -76,14 +82,17 @@ #:export (check-description-style check-inputs-should-be-native check-inputs-should-not-be-an-input-at-all + check-wrapper-inputs check-patch-file-names check-patch-headers check-synopsis-style check-derivation check-home-page + check-name check-source check-source-file-name check-source-unstable-tarball + check-optional-tests check-mirror-url check-github-url check-license @@ -93,6 +102,7 @@ check-archival check-profile-collisions check-haskell-stackage + check-tests-true lint-warning lint-warning? @@ -155,6 +165,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 ;;; @@ -173,14 +255,40 @@ (define (check-name package) "Check whether PACKAGE's name matches our guidelines." (let ((name (package-name package))) - ;; Currently checks only whether the name is too short. - (if (and (<= (string-length name) 1) - (not (string=? name "r"))) ; common-sense exception - (list - (make-warning package - (G_ "name should be longer than a single character") - #:field 'name)) - '()))) + (cond + ;; Currently checks only whether the name is too short. + ((and (<= (string-length name) 1) + (not (string=? name "r"))) ; common-sense exception + (list + (make-warning package + (G_ "name should be longer than a single character") + #:field 'name))) + ((string-index name #\_) + (list + (make-warning package + (G_ "name should use hyphens instead of underscores") + #:field 'name))) + (else '())))) + +(define (check-tests-true package) + "Check whether PACKAGE explicitly requests to run tests, which is +superfluous when building natively and incorrect when cross-compiling." + (define (tests-explicitly-enabled?) + (apply (lambda* (#:key tests? #:allow-other-keys) + (eq? tests? #t)) + (package-arguments package))) + (if (and (tests-explicitly-enabled?) + ;; Some packages, e.g. gnutls, set #:tests? + ;; differently depending on whether it is being + ;; cross-compiled. + (parameterize ((%current-target-system "aarch64-linux-gnu")) + (tests-explicitly-enabled?))) + (list (make-warning package + ;; TRANSLATORS: #:tests? and #t are Scheme constants + ;; and must not be translated. + (G_ "#:tests? must not be explicitly set to #t") + #:field 'arguments)) + '())) (define (properly-starts-sentence? s) (string-match "^[(\"'`[:upper:][:digit:]]" s)) @@ -269,6 +377,24 @@ 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) + (list + (make-warning package + (G_ "description contains trailing whitespace") + #:field 'description)) + '())) + (let ((description (package-description package))) (if (string? description) (append @@ -278,6 +404,8 @@ 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)) (plain-description @@ -375,6 +503,49 @@ of a package, and INPUT-NAMES, a list of package specifications such as (package-input-intersection (package-direct-inputs package) input-names)))) +(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." @@ -447,13 +618,23 @@ markup is valid return a plain-text version of SYNOPSIS, otherwise #f." (G_ "Texinfo markup in synopsis is invalid") #:field 'synopsis))))) + (define (check-no-trailing-whitespace synopsis) + "Check that SYNOPSIS doesn't have trailing whitespace." + (if (string-suffix? " " synopsis) + (list + (make-warning package + (G_ "synopsis contains trailing whitespace") + #: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)) + check-texinfo-markup + check-no-trailing-whitespace)) (match (package-synopsis package) ("" @@ -565,6 +746,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 @@ -750,7 +976,8 @@ warnings." ((blank? line) (loop)) ((or (string-prefix? "--- " line) - (string-prefix? "+++ " line)) + (string-prefix? "+++ " line) + (string-prefix? "diff --git " line)) (list (make-warning package (G_ "~a: patch lacks comment and \ upstream status") @@ -982,69 +1209,91 @@ 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)) '()))) -(cond-expand - (guile-3 - ;; Guile 3.0.0 does not export this predicate. - (define exception-with-kind-and-args? - (exception-predicate &exception-with-kind-and-args))) - (else ;Guile 2 - (define exception-with-kind-and-args? - (const #f)))) +;; Guile 3.0.0 does not export this predicate. +(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) - (catch #t ;TODO: Remove 'catch' when Guile 2.x is no longer supported. - (lambda () - (guard (c ((store-protocol-error? c) - (make-warning package - (G_ "failed to create ~a derivation: ~a") - (list system - (store-protocol-error-message c)))) - ((exception-with-kind-and-args? c) - (make-warning package - (G_ "failed to create ~a derivation: ~s") - (list system - (cons (exception-kind c) - (exception-args c))))) - ((message-condition? c) - (make-warning package - (G_ "failed to create ~a derivation: ~a") - (list system - (condition-message c)))) - ((formatted-message? c) - (let ((str (apply format #f - (formatted-message-string c) - (formatted-message-arguments c)))) - (make-warning package - (G_ "failed to create ~a derivation: ~a") - (list system str))))) - (parameterize ((%graft? #f)) - (package-derivation store package system #:graft? #f) + (guard (c ((store-protocol-error? c) + (make-warning package + (G_ "failed to create ~a derivation: ~a") + (list system + (store-protocol-error-message c)))) + ((exception-with-kind-and-args? c) + (make-warning package + (G_ "failed to create ~a derivation: ~s") + (list system + (cons (exception-kind c) + (exception-args c))))) + ((message-condition? c) + (make-warning package + (G_ "failed to create ~a derivation: ~a") + (list system + (condition-message c)))) + ((formatted-message? c) + (let ((str (apply format #f + (formatted-message-string c) + (formatted-message-arguments c)))) + (make-warning package + (G_ "failed to create ~a derivation: ~a") + (list system str))))) + (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))))) + ;; 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)))))) (define (check-with-store store) (filter lint-warning? @@ -1098,46 +1347,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 @@ -1219,6 +1428,43 @@ upstream releases") #:field 'source))))))) +(define (lookup-disarchive-spec hash) + "If Disarchive mirrors have a spec for HASH, return the list of SWH +directory identifiers the spec refers to. Otherwise return #f." + (define (extract-swh-id spec) + ;; Return the list of SWH directory identifiers SPEC refers to, where SPEC + ;; is a Disarchive sexp. Instead of attempting to parse it, traverse it + ;; in a pretty unintelligent fashion. + (let loop ((sexp spec) + (ids '())) + (match sexp + ((? string? str) + (let ((prefix "swh:1:dir:")) + (if (string-prefix? prefix str) + (cons (string-drop str (string-length prefix)) ids) + ids))) + ((head tail ...) + (loop tail (loop head ids))) + (_ ids)))) + + (any (lambda (mirror) + (with-networking-fail-safe + (format #f (G_ "failed to access Disarchive database at ~a") + mirror) + #f + (guard (c ((http-get-error? c) #f)) + (let* ((url (string-append mirror + (symbol->string + (content-hash-algorithm hash)) + "/" + (bytevector->base16-string + (content-hash-value hash)))) + (port (http-fetch (string->uri url) #:text? #t)) + (spec (read port))) + (close-port port) + (extract-swh-id spec))))) + %disarchive-mirrors)) + (define (check-archival package) "Check whether PACKAGE's source code is archived on Software Heritage. If it's not, and if its source code is a VCS snapshot, then send a \"save\" @@ -1294,13 +1540,33 @@ try again later") (symbol->string (content-hash-algorithm hash))) (#f - (list (make-warning package - (G_ "source not archived on Software \ -Heritage") - #:field 'source))) + ;; If SWH doesn't have HASH as is, it may be because it's + ;; a hand-crafted tarball. In that case, check whether + ;; the Disarchive database has an entry for that tarball. + (match (lookup-disarchive-spec hash) + (#f + (list (make-warning package + (G_ "source not archived on Software \ +Heritage and missing from the Disarchive database") + #:field 'source))) + (directory-ids + (match (find (lambda (id) + (not (lookup-directory id))) + directory-ids) + (#f '()) + (id + (list (make-warning package + (G_ " +Disarchive entry refers to non-existent SWH directory '~a'") + (list id) + #:field 'source))))))) ((? content?) '()))) - '())))) + '())) + (_ + (list (make-warning package + (G_ "unsupported source type") + #:field 'source))))) (match-lambda* (('swh-error url method response) (response->warning url method response)) @@ -1474,6 +1740,10 @@ them for PACKAGE." (description "Validate package names") (check check-name)) (lint-checker + (name 'tests-true) + (description "Check if tests are explicitly enabled") + (check check-tests-true)) + (lint-checker (name 'description) (description "Validate package descriptions") (check check-description-style)) @@ -1486,6 +1756,10 @@ them for PACKAGE." (description "Identify inputs that shouldn't be inputs at all") (check check-inputs-should-not-be-an-input-at-all)) (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. @@ -1493,6 +1767,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)) |