;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2014 Cyril Roelandt <tipecaml@gmail.com>
;;; Copyright © 2014, 2015 Eric Bavier <bavier@member.fsf.org>
-;;; Copyright © 2013, 2014, 2015, 2016 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2013, 2014, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2015, 2016 Mathieu Lirzin <mthl@gnu.org>
;;; Copyright © 2016 Danny Milosavljevic <dannym+a@scratchpost.org>
;;; Copyright © 2016 Hartmut Goebel <h.goebel@crazy-compilers.com>
+;;; Copyright © 2017 Alex Kost <alezost@gmail.com>
;;;
;;; This file is part of GNU Guix.
;;;
#:use-module (guix records)
#:use-module (guix ui)
#:use-module (guix utils)
- #:use-module (guix combinators)
+ #:use-module (guix memoization)
#:use-module (guix scripts)
#:use-module (guix gnu-maintenance)
#:use-module (guix monads)
#:use-module (web uri)
#:use-module ((guix build download)
#:select (maybe-expand-mirrors
- open-connection-for-uri
+ (open-connection-for-uri
+ . guix:open-connection-for-uri)
close-connection))
#:use-module (web request)
#:use-module (web response)
;; provided MESSAGE.
(let ((loc (or (package-field-location package field)
(package-location package))))
- (format (guix-warning-port) "~a: ~a: ~a~%"
+ (format (guix-warning-port) "~a: ~a@~a: ~a~%"
(location->string loc)
- (package-full-name package)
+ (package-name package) (package-version package)
message)))
(define (call-with-accumulated-warnings thunk)
(define (list-checkers-and-exit)
;; Print information about all available checkers and exit.
- (format #t (_ "Available checkers:~%"))
+ (format #t (G_ "Available checkers:~%"))
(for-each (lambda (checker)
(format #t "- ~a: ~a~%"
(lint-checker-name checker)
- (_ (lint-checker-description checker))))
+ (G_ (lint-checker-description checker))))
%checkers)
(exit 0))
(define (check-not-empty description)
(when (string-null? description)
(emit-warning package
- (_ "description should not be empty")
+ (G_ "description should not be empty")
'description)))
(define (check-texinfo-markup description)
(lambda () (texi->plain-text description))
(lambda (keys . args)
(emit-warning package
- (_ "Texinfo markup in description is invalid")
+ (G_ "Texinfo markup in description is invalid")
'description)
#f)))
(match (string-index description (char-set #\™ #\®))
((and (? number?) index)
(emit-warning package
- (format #f (_ "description should not contain ~
+ (format #f (G_ "description should not contain ~
trademark sign '~a' at ~d")
(string-ref description index) index)
'description))
;; TRANSLATORS: '@code' is Texinfo markup and must be kept
;; as is.
- (_ "use @code or similar ornament instead of quotes")
+ (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
- (_ "description should start with an upper-case letter or digit")
+ (G_ "description should start with an upper-case letter or digit")
'description)))
(define (check-end-of-sentence-space description)
r (cons (match:start m) r)))))))
(unless (null? infractions)
(emit-warning package
- (format #f (_ "sentences in description should be followed ~
+ (format #f (G_ "sentences in description should be followed ~
by two spaces; possible infraction~p at ~{~a~^, ~}")
(length infractions)
infractions)
(and=> (check-texinfo-markup description)
check-proper-start))
(emit-warning package
- (format #f (_ "invalid description: ~s") description)
+ (format #f (G_ "invalid description: ~s") description)
'description))))
-(define (warn-if-package-has-input linted inputs-to-check input-names message)
- ;; Emit a warning MESSAGE if some of the inputs named in INPUT-NAMES are
- ;; contained in INPUTS-TO-CHECK, which are assumed to be inputs of package
- ;; LINTED.
+(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) ...)
- (for-each (lambda (package output)
- (when (package? package)
- (let ((input (string-append
- (package-name package)
- (if (> (length output) 0)
- (string-append ":" (car output))
- ""))))
- (when (member input input-names)
- (emit-warning linted
- (format #f (_ message) input)
- 'inputs-to-check)))))
- 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 ((message "'~a' should probably be a native input")
- (inputs (package-inputs package))
+ (let ((inputs (package-inputs package))
(input-names
'("pkg-config"
"extra-cmake-modules"
"python-pytest-cov" "python2-pytest-cov"
"python-setuptools-scm" "python2-setuptools-scm"
"python-sphinx" "python2-sphinx")))
- (warn-if-package-has-input package inputs input-names message)))
+ (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 ((message "'~a' should probably not be an input at all")
- (inputs (package-inputs package))
- (input-names
- '("python-setuptools"
- "python2-setuptools"
- "python-pip"
- "python2-pip")))
- (warn-if-package-has-input package (package-inputs package)
- input-names message)
- (warn-if-package-has-input package (package-native-inputs package)
- input-names message)
- (warn-if-package-has-input package (package-propagated-inputs package)
- input-names message)))
+ (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
(define (check-not-empty synopsis)
(when (string-null? synopsis)
(emit-warning package
- (_ "synopsis should not be empty")
+ (G_ "synopsis should not be empty")
'synopsis)))
(define (check-final-period synopsis)
(when (and (string-suffix? "." synopsis)
(not (string-suffix? "etc." synopsis)))
(emit-warning package
- (_ "no period allowed at the end of the synopsis")
+ (G_ "no period allowed at the end of the synopsis")
'synopsis)))
(define check-start-article
(when (or (string-prefix-ci? "A " synopsis)
(string-prefix-ci? "An " synopsis))
(emit-warning package
- (_ "no article allowed at the beginning of \
+ (G_ "no article allowed at the beginning of \
the synopsis")
'synopsis)))))
(define (check-synopsis-length synopsis)
(when (>= (string-length synopsis) 80)
(emit-warning package
- (_ "synopsis should be less than 80 characters long")
+ (G_ "synopsis should be less than 80 characters long")
'synopsis)))
(define (check-proper-start synopsis)
(unless (properly-starts-sentence? synopsis)
(emit-warning package
- (_ "synopsis should start with an upper-case letter or digit")
+ (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
- (_ "synopsis should not start with the package name")
+ (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))
+ (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)
(proc synopsis))
checks))
(invalid
- (emit-warning package (format #f (_ "invalid synopsis: ~s") invalid)
+ (emit-warning package (format #f (G_ "invalid synopsis: ~s") invalid)
'synopsis))))
(define* (probe-uri uri #:key timeout)
((or 'http 'https)
(catch #t
(lambda ()
- (let ((port (open-connection-for-uri uri #:timeout timeout))
+ (let ((port (guix:open-connection-for-uri
+ uri #:timeout timeout))
(request (build-request uri #:headers headers)))
(define response
(dynamic-wind
(begin
(emit-warning package
(format #f
- (_ "URI ~a returned \
+ (G_ "URI ~a returned \
suspiciously small file (~a bytes)")
(uri->string uri)
length))
(begin
(emit-warning package
(format #f
- (_ "URI ~a not reachable: ~a (~s)")
+ (G_ "URI ~a not reachable: ~a (~s)")
(uri->string uri)
(response-code argument)
(response-reason-phrase argument))
(('error port command code message)
(emit-warning package
(format #f
- (_ "URI ~a not reachable: ~a (~s)")
+ (G_ "URI ~a not reachable: ~a (~s)")
(uri->string uri)
code (string-trim-both message)))
#f)))
((getaddrinfo-error)
(emit-warning package
(format #f
- (_ "URI ~a domain not found: ~a")
+ (G_ "URI ~a domain not found: ~a")
(uri->string uri)
(gai-strerror (car argument)))
field)
((system-error)
(emit-warning package
(format #f
- (_ "URI ~a unreachable: ~a")
+ (G_ "URI ~a unreachable: ~a")
(uri->string uri)
(strerror
(system-error-errno
#f)
((tls-certificate-error)
(emit-warning package
- (format #f (_ "TLS certificate error: ~a")
+ (format #f (G_ "TLS certificate error: ~a")
(tls-certificate-error-string argument))))
((invalid-http-response gnutls-error)
;; Probably a misbehaving server; ignore.
(unless (or (string-contains (package-name package) "bootstrap")
(string=? (package-name package) "ld-wrapper"))
(emit-warning package
- (_ "invalid value for home page")
+ (G_ "invalid value for home page")
'home-page)))
(else
- (emit-warning package (format #f (_ "invalid home page URL: ~s")
+ (emit-warning package (format #f (G_ "invalid home page URL: ~s")
(package-home-page package))
'home-page)))))
'()))
(emit-warning
package
- (_ "file names of patches should start with the package name")
+ (G_ "file names of patches should start with the package name")
'patch-file-names))))
(define (escape-quotes str)
str)))
(define official-gnu-packages*
- (memoize
- (lambda ()
- "A memoizing version of 'official-gnu-packages' that returns the empty
+ (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 '())))))
+ (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
(or (not (string? downstream))
(not (string=? upstream downstream))))
(format (guix-warning-port)
- (_ "~a: ~a: proposed synopsis: ~s~%")
+ (G_ "~a: ~a: proposed synopsis: ~s~%")
(location->string loc) (package-full-name package)
upstream)))
(not (string=? (fill-paragraph upstream 100)
(fill-paragraph downstream 100)))))
(format (guix-warning-port)
- (_ "~a: ~a: proposed description:~% \"~a\"~%")
+ (G_ "~a: ~a: proposed description:~% \"~a\"~%")
(location->string loc) (package-full-name package)
(fill-paragraph (escape-quotes upstream) 77 7)))))))
;; where *all* the URIs are unreachable.
(unless success?
(emit-warning package
- (_ "all the source URIs are unreachable:")
+ (G_ "all the source URIs are unreachable:")
'source)
(for-each (lambda (warning)
(display warning (guix-warning-port)))
(let ((origin (package-source package)))
(unless (or (not origin) (origin-file-name-valid? origin))
(emit-warning package
- (_ "the source file name should contain the package name")
+ (G_ "the source file name should contain the package name")
'source))))
(define (check-mirror-url package)
(loop rest))
(prefix
(emit-warning package
- (format #f (_ "URL should be \
+ (format #f (G_ "URL should be \
'mirror://~a/~a'")
mirror-id
(string-drop uri (string-length prefix)))
(lambda ()
(guard (c ((nix-protocol-error? c)
(emit-warning package
- (format #f (_ "failed to create derivation: ~a")
+ (format #f (G_ "failed to create derivation: ~a")
(nix-protocol-error-message c))))
((message-condition? c)
(emit-warning package
- (format #f (_ "failed to create derivation: ~a")
+ (format #f (G_ "failed to create derivation: ~a")
(condition-message c)))))
(with-store store
;; Disable grafts since it can entail rebuilds.
(package-derivation store replacement #:graft? #f))))))
(lambda args
(emit-warning package
- (format #f (_ "failed to create derivation: ~s~%")
+ (format #f (G_ "failed to create derivation: ~s~%")
args)))))
(define (check-license package)
((? license?) ...))
#t)
(x
- (emit-warning package (_ "invalid license field")
+ (emit-warning package (G_ "invalid license field")
'license))))
(define (patch-file-name patch)
or HTTP errors. This allows network-less operation and makes problems with
the NIST server non-fatal.."
(guard (c ((http-get-error? c)
- (warning (_ "failed to retrieve CVE vulnerabilities \
+ (warning (G_ "failed to retrieve CVE vulnerabilities \
from ~s: ~a (~s)~%")
(uri->string (http-get-error-uri c))
(http-get-error-code c)
(http-get-error-reason c))
- (warning (_ "assuming no CVE vulnerabilities~%"))
+ (warning (G_ "assuming no CVE vulnerabilities~%"))
'()))
(catch #t
(lambda ()
(current-vulnerabilities))
(match-lambda*
(('getaddrinfo-error errcode)
- (warning (_ "failed to lookup NIST host: ~a~%")
+ (warning (G_ "failed to lookup NIST host: ~a~%")
(gai-strerror errcode))
- (warning (_ "assuming no CVE vulnerabilities~%"))
+ (warning (G_ "assuming no CVE vulnerabilities~%"))
'())
(('tls-certificate-error args ...)
- (warning (_ "TLS certificate error: ~a")
+ (warning (G_ "TLS certificate error: ~a")
(tls-certificate-error-string args))
- (warning (_ "assuming no CVE vulnerabilities~%"))
+ (warning (G_ "assuming no CVE vulnerabilities~%"))
'())
(args
(apply throw args))))))
vulnerabilities)))
(unless (null? unpatched)
(emit-warning package
- (format #f (_ "probably vulnerable to ~a")
+ (format #f (G_ "probably vulnerable to ~a")
(string-join (map vulnerability-id unpatched)
", ")))))))))
(#f #t)
(index
(emit-warning package
- (format #f (_ "tabulation on line ~a, column ~a")
+ (format #f (G_ "tabulation on line ~a, column ~a")
line-number index)))))
(define (report-trailing-white-space package line line-number)
(string=? line (string #\page)))
(emit-warning package
(format #f
- (_ "trailing white space on line ~a")
+ (G_ "trailing white space on line ~a")
line-number))))
(define (report-long-line package line line-number)
;; much noise.
(when (> (string-length line) 90)
(emit-warning package
- (format #f (_ "line ~a is way too long (~a characters)")
+ (format #f (G_ "line ~a is way too long (~a characters)")
line-number (string-length line)))))
(define %hanging-paren-rx
(when (regexp-exec %hanging-paren-rx line)
(emit-warning package
(format #f
- (_ "line ~a: parentheses feel lonely, \
+ (G_ "line ~a: parentheses feel lonely, \
move to the previous or next line")
line-number))))
(define* (run-checkers package #:optional (checkers %checkers))
"Run the given CHECKERS on PACKAGE."
- (let ((tty? (isatty? (current-error-port)))
- (name (package-full-name package)))
+ (let ((tty? (isatty? (current-error-port))))
(for-each (lambda (checker)
(when tty?
- (format (current-error-port) "checking ~a [~a]...\x1b[K\r"
- name (lint-checker-name checker))
+ (format (current-error-port) "checking ~a@~a [~a]...\x1b[K\r"
+ (package-name package) (package-version package)
+ (lint-checker-name checker))
(force-output (current-error-port)))
((lint-checker-check checker) package))
checkers)
'())
(define (show-help)
- (display (_ "Usage: guix lint [OPTION]... [PACKAGE]...
+ (display (G_ "Usage: guix lint [OPTION]... [PACKAGE]...
Run a set of checkers on the specified package; if none is specified,
run the checkers on all packages.\n"))
- (display (_ "
+ (display (G_ "
-c, --checkers=CHECKER1,CHECKER2...
only run the specified checkers"))
- (display (_ "
+ (display (G_ "
-h, --help display this help and exit"))
- (display (_ "
+ (display (G_ "
-l, --list-checkers display the list of available lint checkers"))
- (display (_ "
+ (display (G_ "
-V, --version display version information and exit"))
(newline)
(show-bug-report-information))
(unless (memq c
(map lint-checker-name
%checkers))
- (leave (_ "~a: invalid checker~%") c)))
+ (leave (G_ "~a: invalid checker~%") c)))
names)
(alist-cons 'checkers
(filter (lambda (checker)
;; Return the alist of option values.
(args-fold* args %options
(lambda (opt name arg result)
- (leave (_ "~A: unrecognized option~%") name))
+ (leave (G_ "~A: unrecognized option~%") name))
(lambda (arg result)
(alist-cons 'argument arg result))
%default-options))
HCoop / jackhill / guix / guix.git / blobdiff