summaryrefslogtreecommitdiff
path: root/guix/scripts
diff options
context:
space:
mode:
authorLudovic Courtès <ludo@gnu.org>2019-07-17 15:51:10 +0200
committerLudovic Courtès <ludo@gnu.org>2019-07-17 15:51:10 +0200
commit64de896a71a9ba3091259834077d54c0146bdab6 (patch)
treeda58cc584fcc42a2b04f692aa3b1ada4c8949f5e /guix/scripts
parent5247aab8d6a18a4081ab7caeddb4fc083bca1f6b (diff)
parent6bfcb729268e0d20c6ae78224aef0eaad2ee2e74 (diff)
Merge branch 'master' into core-updates
Diffstat (limited to 'guix/scripts')
-rw-r--r--guix/scripts/lint.scm1178
-rw-r--r--guix/scripts/publish.scm2
2 files changed, 54 insertions, 1126 deletions
diff --git a/guix/scripts/lint.scm b/guix/scripts/lint.scm
index dc338a1d7b..98ee469501 100644
--- a/guix/scripts/lint.scm
+++ b/guix/scripts/lint.scm
@@ -26,1127 +26,33 @@
;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
(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
+ run-checkers))
- %checkers
- lint-checker
- lint-checker?
- lint-checker-name
- lint-checker-description
- lint-checker-check))
-
-
-;;;
-;;; Helpers
-;;;
-(define* (emit-warning package message #:optional field)
+(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.
- (let ((loc (or (package-field-location package field)
- (package-location package))))
- (format (guix-warning-port) "~a: ~a@~a: ~a~%"
- (location->string loc)
- (package-name package) (package-version package)
- message)))
-
-(define (call-with-accumulated-warnings thunk)
- "Call THUNK, accumulating any warnings in the current state, using the state
-monad."
- (let ((port (open-output-string)))
- (mlet %state-monad ((state (current-state))
- (result -> (parameterize ((guix-warning-port port))
- (thunk)))
- (warning -> (get-output-string port)))
- (mbegin %state-monad
- (munless (string=? "" warning)
- (set-current-state (cons warning state)))
- (return result)))))
-
-(define-syntax-rule (with-accumulated-warnings exp ...)
- "Evaluate EXP and accumulate warnings in the state monad."
- (call-with-accumulated-warnings
- (lambda ()
- exp ...)))
-
-
-;;;
-;;; Checkers
-;;;
-(define-record-type* <lint-checker>
- 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)
- (when (string-null? description)
- (emit-warning package
- (G_ "description should not be empty")
- '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)
- (emit-warning package
- (G_ "Texinfo markup in description is invalid")
- 'description)
- #f)))
-
- (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)
- (emit-warning package
- (format #f (G_ "description should not contain ~
-trademark sign '~a' at ~d")
- (string-ref description index) index)
- 'description))
- (else #t)))
-
- (define (check-quotes description)
- "Check whether DESCRIPTION contains single quotes and suggest @code."
- (when (regexp-exec %quoted-identifier-rx description)
- (emit-warning package
-
- ;; TRANSLATORS: '@code' is Texinfo markup and must be kept
- ;; as is.
- (G_ "use @code or similar ornament instead of quotes")
- 'description)))
-
- (define (check-proper-start description)
- (unless (or (properly-starts-sentence? description)
- (string-prefix-ci? (package-name package) description))
- (emit-warning package
- (G_ "description should start with an upper-case letter or digit")
- '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)))))))
- (unless (null? infractions)
- (emit-warning package
- (format #f (G_ "sentences in description should be followed ~
-by two spaces; possible infraction~p at ~{~a~^, ~}")
- (length infractions)
- infractions)
- 'description))))
-
- (let ((description (package-description package)))
- (if (string? description)
- (begin
- (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=> (check-texinfo-markup description)
- check-proper-start))
- (emit-warning package
- (format #f (G_ "invalid description: ~s") description)
- '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")))
- (for-each (lambda (input)
- (emit-warning
- package
- (format #f (G_ "'~a' should probably be a native input")
- input)
- 'inputs-to-check))
- (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")))
- (for-each (lambda (input)
- (emit-warning
- package
- (format #f
- (G_ "'~a' should probably not be an input at all")
- input)))
- (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-not-empty synopsis)
- (when (string-null? synopsis)
- (emit-warning package
- (G_ "synopsis should not be empty")
- 'synopsis)))
-
- (define (check-final-period synopsis)
- ;; Synopsis should not end with a period, except for some special cases.
- (when (and (string-suffix? "." synopsis)
- (not (string-suffix? "etc." synopsis)))
- (emit-warning package
- (G_ "no period allowed at the end of the synopsis")
- 'synopsis)))
-
- (define check-start-article
- ;; Skip this check for GNU packages, as suggested by Karl Berry's reply to
- ;; <http://lists.gnu.org/archive/html/bug-womb/2014-11/msg00000.html>.
- (if (false-if-exception (gnu-package? package))
- (const #t)
- (lambda (synopsis)
- (when (or (string-prefix-ci? "A " synopsis)
- (string-prefix-ci? "An " synopsis))
- (emit-warning package
- (G_ "no article allowed at the beginning of \
-the synopsis")
- 'synopsis)))))
-
- (define (check-synopsis-length synopsis)
- (when (>= (string-length synopsis) 80)
- (emit-warning package
- (G_ "synopsis should be less than 80 characters long")
- 'synopsis)))
-
- (define (check-proper-start synopsis)
- (unless (properly-starts-sentence? synopsis)
- (emit-warning package
- (G_ "synopsis should start with an upper-case letter or digit")
- 'synopsis)))
-
- (define (check-start-with-package-name synopsis)
- (when (and (regexp-exec (package-name-regexp package) synopsis)
- (not (starts-with-abbreviation? synopsis)))
- (emit-warning package
- (G_ "synopsis should not start with the package name")
- '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)
- (emit-warning package
- (G_ "Texinfo markup in synopsis is invalid")
- 'synopsis)
- #f)))
-
- (define checks
- (list check-not-empty
- check-proper-start
- check-final-period
- check-start-article
- check-start-with-package-name
- check-synopsis-length
- check-texinfo-markup))
-
- (match (package-synopsis package)
- ((? string? synopsis)
- (for-each (lambda (proc)
- (proc synopsis))
- checks))
- (invalid
- (emit-warning package (format #f (G_ "invalid synopsis: ~s") invalid)
- '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 #f and emit 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)
- (begin
- (emit-warning package
- (format #f
- (G_ "URI ~a returned \
-suspiciously small file (~a bytes)")
- (uri->string uri)
- length))
- #f)))
- (_ #t)))
- ((= 301 (response-code argument))
- (if (response-location argument)
- (begin
- (emit-warning package
- (format #f (G_ "permanent redirect from ~a to ~a")
- (uri->string uri)
- (uri->string
- (response-location argument))))
- #t)
- (begin
- (emit-warning package
- (format #f (G_ "invalid permanent redirect \
-from ~a")
- (uri->string uri)))
- #f)))
- (else
- (emit-warning package
- (format #f
- (G_ "URI ~a not reachable: ~a (~s)")
- (uri->string uri)
- (response-code argument)
- (response-reason-phrase argument))
- field)
- #f)))
- ((ftp-response)
- (match argument
- (('ok) #t)
- (('error port command code message)
- (emit-warning package
- (format #f
- (G_ "URI ~a not reachable: ~a (~s)")
- (uri->string uri)
- code (string-trim-both message)))
- #f)))
- ((getaddrinfo-error)
- (emit-warning package
- (format #f
- (G_ "URI ~a domain not found: ~a")
- (uri->string uri)
- (gai-strerror (car argument)))
- field)
- #f)
- ((system-error)
- (emit-warning package
- (format #f
- (G_ "URI ~a unreachable: ~a")
- (uri->string uri)
- (strerror
- (system-error-errno
- (cons status argument))))
- field)
- #f)
- ((tls-certificate-error)
- (emit-warning package
- (format #f (G_ "TLS certificate error: ~a")
- (tls-certificate-error-string argument))))
- ((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)
- (validate-uri uri package 'home-page))
- ((not (package-home-page package))
- (unless (or (string-contains (package-name package) "bootstrap")
- (string=? (package-name package) "ld-wrapper"))
- (emit-warning package
- (G_ "invalid value for home page")
- 'home-page)))
- (else
- (emit-warning package (format #f (G_ "invalid home page URL: ~s")
- (package-home-page package))
- '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'
- (emit-warning package (condition-message c)
- 'patch-file-names)))
- (define patches
- (or (and=> (package-source package) origin-patches)
- '()))
-
- (unless (every (match-lambda ;patch starts with package name?
- ((? string? patch)
- (and=> (string-contains (basename patch)
- (package-name package))
- zero?))
- (_ #f)) ;must be an <origin> or something like that.
- patches)
- (emit-warning
- package
- (G_ "file names of patches should start with the package name")
- '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))
- (for-each (match-lambda
- ((? string? patch)
- (when (> (+ margin (if (string-prefix? (%distro-directory)
- patch)
- (- (string-length patch) prefix)
- (string-length patch)))
- max)
- (emit-warning
- package
- (format #f (G_ "~a: file name is too long")
- (basename patch))
- 'patch-file-names)))
- (_ #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
- #t)
- (descriptor ;a genuine GNU package
- (let ((upstream (gnu-package-doc-summary descriptor))
- (downstream (package-synopsis package))
- (loc (or (package-field-location package 'synopsis)
- (package-location package))))
- (when (and upstream
- (or (not (string? downstream))
- (not (string=? upstream downstream))))
- (format (guix-warning-port)
- (G_ "~a: ~a: proposed synopsis: ~s~%")
- (location->string loc) (package-full-name package)
- upstream)))
-
- (let ((upstream (gnu-package-doc-description descriptor))
- (downstream (package-description package))
- (loc (or (package-field-location package 'description)
- (package-location package))))
- (when (and upstream
- (or (not (string? downstream))
- (not (string=? (fill-paragraph upstream 100)
- (fill-paragraph downstream 100)))))
- (format (guix-warning-port)
- (G_ "~a: ~a: proposed description:~% \"~a\"~%")
- (location->string loc) (package-full-name package)
- (fill-paragraph (escape-quotes upstream) 77 7)))))))
-
-(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 (try-uris uris)
- (run-with-state
- (anym %state-monad
- (lambda (uri)
- (with-accumulated-warnings
- (validate-uri uri package 'source)))
- (append-map (cut maybe-expand-mirrors <> %mirrors)
- uris))
- '()))
-
- (let ((origin (package-source package)))
- (when (and origin
- (eqv? (origin-method origin) url-fetch))
- (let ((uris (map string->uri (origin-uris origin))))
-
- ;; Just make sure that at least one of the URIs is valid.
- (call-with-values
- (lambda () (try-uris uris))
- (lambda (success? 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.
- (unless success?
- (emit-warning package
- (G_ "all the source URIs are unreachable:")
- 'source)
- (for-each (lambda (warning)
- (display warning (guix-warning-port)))
- (reverse 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)))
- (unless (or (not origin) (origin-file-name-valid? origin))
- (emit-warning package
- (G_ "the source file name should contain the package name")
- 'source))))
-
-(define (check-source-unstable-tarball package)
- "Emit a warning if PACKAGE's source is an autogenerated tarball."
- (define (check-source-uri uri)
- (when (and (string=? (uri-host (string->uri uri)) "github.com")
- (match (split-and-decode-uri-path
- (uri-path (string->uri uri)))
- ((_ _ "archive" _ ...) #t)
- (_ #f)))
- (emit-warning package
- (G_ "the source URI should not be an autogenerated tarball")
- 'source)))
- (let ((origin (package-source package)))
- (when (and (origin? origin)
- (eqv? (origin-method origin) url-fetch))
- (let ((uris (origin-uris origin)))
- (for-each check-source-uri uris)))))
-
-(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
- (()
- #t)
- (((mirror-id mirror-urls ...) rest ...)
- (match (find (cut string-prefix? <> uri) mirror-urls)
- (#f
- (loop rest))
- (prefix
- (emit-warning package
- (format #f (G_ "URL should be \
-'mirror://~a/~a'")
- mirror-id
- (string-drop uri (string-length prefix)))
- 'source)))))))
-
- (let ((origin (package-source package)))
- (when (and (origin? origin)
- (eqv? (origin-method origin) url-fetch))
- (let ((uris (origin-uris origin)))
- (for-each 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)))
- (when (and (origin? origin)
- (eqv? (origin-method origin) url-fetch))
- (for-each
- (lambda (uri)
- (and=> (follow-redirects-to-github uri)
- (lambda (github-uri)
- (unless (string=? github-uri uri)
- (emit-warning
- package
- (format #f (G_ "URL should be '~a'") github-uri)
- '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)
- (emit-warning package
- (format #f (G_ "failed to create ~a derivation: ~a")
- system
- (store-protocol-error-message c))))
- ((message-condition? c)
- (emit-warning package
- (format #f (G_ "failed to create ~a derivation: ~a")
- 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
- (emit-warning package
- (format #f (G_ "failed to create ~a derivation: ~s")
- system args)))))
-
- (for-each 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?) ...))
- #t)
- (x
- (emit-warning package (G_ "invalid license 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)
- (()
- #t)
- ((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)))
- (unless (null? unpatched)
- (emit-warning package
- (format #f (G_ "probably vulnerable to ~a")
- (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
- (format #f (G_ "while retrieving upstream info for '~a'")
- (package-name package))
- #f
- (package-latest-release* package (force %updaters)))
- ((? upstream-source? source)
- (when (version>? (upstream-source-version source)
- (package-version package))
- (emit-warning package
- (format #f (G_ "can be upgraded to ~a")
- (upstream-source-version source)))))
- (#f #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
- (emit-warning package
- (format #f (G_ "tabulation on line ~a, column ~a")
- 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)))
- (emit-warning package
- (format #f
- (G_ "trailing white space on line ~a")
- line-number))))
-
-(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)
- (emit-warning package
- (format #f (G_ "line ~a is way too long (~a characters)")
- line-number (string-length line)))))
-
-(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)
- (emit-warning package
- (format #f
- (G_ "line ~a: parentheses feel lonely, \
-move to the previous or next line")
- line-number))))
-
-(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))
- (let ((line (read-line port)))
- (or (eof-object? line)
- (and last-line (> line-number last-line))
- (if (and (= line-number starting-line)
- (not last-line))
- (loop (+ 1 line-number)
- (+ 1 (sexp-last-line port)))
- (begin
- (unless (< line-number starting-line)
- (for-each (lambda (report)
- (report package line line-number))
- reporters))
- (loop (+ 1 line-number) last-line)))))))))
-
-(define (check-formatting package)
- "Check the formatting of the source code of PACKAGE."
- (let ((location (package-location package)))
- (when 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: <license> is the name of a data type and must not be
- ;; translated.
- (description "Make sure the 'license' field is a <license> \
-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))
+ (for-each
+ (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))
+
+(define (run-checkers package checkers)
"Run the given CHECKERS on PACKAGE."
(let ((tty? (isatty? (current-error-port))))
(for-each (lambda (checker)
@@ -1155,12 +61,23 @@ or a list thereof")
(package-name package) (package-version package)
(lint-checker-name checker))
(force-output (current-error-port)))
- ((lint-checker-check checker) package))
+ (emit-warnings
+ ((lint-checker-check checker) package)))
checkers)
(when tty?
(format (current-error-port) "\x1b[K")
(force-output (current-error-port)))))
+(define (list-checkers-and-exit checkers)
+ ;; 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.
@@ -1194,26 +111,33 @@ run the checkers on all packages.\n"))
;; 'certainty'.
(list (option '(#\c "checkers") #t #f
(lambda (opt name arg result)
- (let ((names (map string->symbol (string-split arg #\,))))
+ (let ((names (map string->symbol (string-split arg #\,)))
+ (checker-names (map lint-checker-name %all-checkers)))
(for-each (lambda (c)
- (unless (memq c
- (map lint-checker-name
- %checkers))
+ (unless (memq c checker-names)
(leave (G_ "~a: invalid checker~%") c)))
names)
(alist-cons 'checkers
(filter (lambda (checker)
(member (lint-checker-name checker)
names))
- %checkers)
+ %all-checkers)
result))))
+ (option '(#\n "no-network") #f #f
+ (lambda (opt name arg result)
+ (alist-cons 'checkers
+ %local-checkers
+ (alist-delete 'checkers
+ result))))
(option '(#\h "help") #f #f
(lambda args
(show-help)
(exit 0)))
(option '(#\l "list-checkers") #f #f
- (lambda args
- (list-checkers-and-exit)))
+ (lambda (opt name arg result)
+ (alist-cons 'list?
+ #t
+ result)))
(option '(#\V "version") #f #f
(lambda args
(show-version-and-exit "guix lint")))))
@@ -1231,13 +155,17 @@ run the checkers on all packages.\n"))
(let* ((opts (parse-options))
(args (filter-map (match-lambda
- (('argument . value)
- value)
- (_ #f))
+ (('argument . value)
+ value)
+ (_ #f))
(reverse opts)))
- (checkers (or (assoc-ref opts 'checkers) %checkers)))
- (if (null? args)
- (fold-packages (lambda (p r) (run-checkers p checkers)) '())
- (for-each (lambda (spec)
- (run-checkers (specification->package spec) checkers))
- args))))
+ (checkers (or (assoc-ref opts 'checkers) %all-checkers)))
+ (cond
+ ((assoc-ref opts 'list?)
+ (list-checkers-and-exit checkers))
+ ((null? args)
+ (fold-packages (lambda (p r) (run-checkers p checkers)) '()))
+ (else
+ (for-each (lambda (spec)
+ (run-checkers (specification->package spec) checkers))
+ args)))))
diff --git a/guix/scripts/publish.scm b/guix/scripts/publish.scm
index c716998a5b..8fb67f9268 100644
--- a/guix/scripts/publish.scm
+++ b/guix/scripts/publish.scm
@@ -694,7 +694,7 @@ to compress or decompress the log file; just return it as-is."
(h1 "GNU Guix Substitute Server")
(p "Hi, "
(a (@ (href
- "https://gnu.org/s/guix/manual/html_node/Invoking-guix-publish.html"))
+ "https://guix.gnu.org/manual/en/html_node/Invoking-guix-publish.html"))
(tt "guix publish"))
" speaking. Welcome!")))
port)))))