summaryrefslogtreecommitdiff
path: root/guix
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
parent5247aab8d6a18a4081ab7caeddb4fc083bca1f6b (diff)
parent6bfcb729268e0d20c6ae78224aef0eaad2ee2e74 (diff)
downloadgnu-guix-64de896a71a9ba3091259834077d54c0146bdab6.tar
gnu-guix-64de896a71a9ba3091259834077d54c0146bdab6.tar.gz
Merge branch 'master' into core-updates
Diffstat (limited to 'guix')
-rw-r--r--guix/build-system/cargo.scm2
-rw-r--r--guix/build-system/node.scm135
-rw-r--r--guix/build/cargo-build-system.scm12
-rw-r--r--guix/build/compile.scm32
-rw-r--r--guix/build/json.scm387
-rw-r--r--guix/build/node-build-system.scm166
-rw-r--r--guix/build/syscalls.scm19
-rw-r--r--guix/channels.scm94
-rw-r--r--guix/derivations.scm65
-rw-r--r--guix/download.scm3
-rw-r--r--guix/gexp.scm92
-rw-r--r--guix/lint.scm1231
-rw-r--r--guix/remote.scm47
-rw-r--r--guix/scripts/lint.scm1178
-rw-r--r--guix/scripts/publish.scm2
-rw-r--r--guix/self.scm2
16 files changed, 2182 insertions, 1285 deletions
diff --git a/guix/build-system/cargo.scm b/guix/build-system/cargo.scm
index fa211d456d..10a1bac844 100644
--- a/guix/build-system/cargo.scm
+++ b/guix/build-system/cargo.scm
@@ -61,7 +61,7 @@ to NAME and VERSION."
(define %cargo-build-system-modules
;; Build-side modules imported by default.
`((guix build cargo-build-system)
- (json parser)
+ (guix build json)
,@%cargo-utils-modules))
(define* (cargo-build store name inputs
diff --git a/guix/build-system/node.scm b/guix/build-system/node.scm
new file mode 100644
index 0000000000..05c24c47d5
--- /dev/null
+++ b/guix/build-system/node.scm
@@ -0,0 +1,135 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2016 Jelle Licht <jlicht@fsfe.org>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Guix is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (guix build-system node)
+ #:use-module (guix store)
+ #:use-module (guix build json)
+ #:use-module (guix build union)
+ #:use-module (guix utils)
+ #:use-module (guix packages)
+ #:use-module (guix derivations)
+ #:use-module (guix search-paths)
+ #:use-module (guix build-system)
+ #:use-module (guix build-system gnu)
+ #:use-module (ice-9 match)
+ #:export (npm-meta-uri
+ %node-build-system-modules
+ node-build
+ node-build-system))
+
+(define (npm-meta-uri name)
+ "Return a URI string for the metadata of node module NAME found in the npm
+registry."
+ (string-append "https://registry.npmjs.org/" name))
+
+(define %node-build-system-modules
+ ;; Build-side modules imported by default.
+ `((guix build node-build-system)
+ (guix build json)
+ (guix build union)
+ ,@%gnu-build-system-modules)) ;; TODO: Might be not needed
+
+(define (default-node)
+ "Return the default Node package."
+ ;; Lazily resolve the binding to avoid a circular dependency.
+ (let ((node (resolve-interface '(gnu packages node))))
+ (module-ref node 'node)))
+
+(define* (lower name
+ #:key source inputs native-inputs outputs system target
+ (node (default-node))
+ #:allow-other-keys
+ #:rest arguments)
+ "Return a bag for NAME."
+ (define private-keywords
+ '(#:source #:target #:node #:inputs #:native-inputs))
+
+ (and (not target) ;XXX: no cross-compilation
+ (bag
+ (name name)
+ (system system)
+ (host-inputs `(,@(if source
+ `(("source" ,source))
+ '())
+ ,@inputs
+
+ ;; Keep the standard inputs of 'gnu-build-system'.
+ ,@(standard-packages)))
+ (build-inputs `(("node" ,node)
+ ,@native-inputs))
+ (outputs outputs)
+ (build node-build)
+ (arguments (strip-keyword-arguments private-keywords arguments)))))
+
+(define* (node-build store name inputs
+ #:key
+ (npm-flags ''())
+ (tests? #t)
+ (phases '(@ (guix build node-build-system)
+ %standard-phases))
+ (outputs '("out"))
+ (search-paths '())
+ (system (%current-system))
+ (guile #f)
+ (imported-modules %node-build-system-modules)
+ (modules '((guix build node-build-system)
+ (guix build json)
+ (guix build union)
+ (guix build utils))))
+ "Build SOURCE using NODE and INPUTS."
+ (define builder
+ `(begin
+ (use-modules ,@modules)
+ (node-build #:name ,name
+ #:source ,(match (assoc-ref inputs "source")
+ (((? derivation? source))
+ (derivation->output-path source))
+ ((source)
+ source)
+ (source
+ source))
+ #:system ,system
+ #:npm-flags ,npm-flags
+ #:tests? ,tests?
+ #:phases ,phases
+ #:outputs %outputs
+ #:search-paths ',(map search-path-specification->sexp
+ search-paths)
+ #:inputs %build-inputs)))
+
+ (define guile-for-build
+ (match guile
+ ((? package?)
+ (package-derivation store guile system #:graft? #f))
+ (#f
+ (let* ((distro (resolve-interface '(gnu packages commencement)))
+ (guile (module-ref distro 'guile-final)))
+ (package-derivation store guile system #:graft? #f)))))
+
+ (build-expression->derivation store name builder
+ #:inputs inputs
+ #:system system
+ #:modules imported-modules
+ #:outputs outputs
+ #:guile-for-build guile-for-build))
+
+(define node-build-system
+ (build-system
+ (name 'node)
+ (description "The standard Node build system")
+ (lower lower)))
diff --git a/guix/build/cargo-build-system.scm b/guix/build/cargo-build-system.scm
index 1f36304b15..f38de16cf7 100644
--- a/guix/build/cargo-build-system.scm
+++ b/guix/build/cargo-build-system.scm
@@ -20,6 +20,7 @@
(define-module (guix build cargo-build-system)
#:use-module ((guix build gnu-build-system) #:prefix gnu:)
+ #:use-module (guix build json)
#:use-module (guix build utils)
#:use-module (guix build cargo-utils)
#:use-module (ice-9 popen)
@@ -27,7 +28,6 @@
#:use-module (ice-9 ftw)
#:use-module (ice-9 format)
#:use-module (ice-9 match)
- #:use-module (json parser)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-26)
#:export (%standard-phases
@@ -42,15 +42,15 @@
(define (manifest-targets)
"Extract all targets from the Cargo.toml manifest"
(let* ((port (open-input-pipe "cargo read-manifest"))
- (data (json->scm port))
- (targets (hash-ref data "targets" '())))
+ (data (read-json port))
+ (targets (or (assoc-ref data "targets") '())))
(close-port port)
targets))
(define (has-executable-target?)
"Check if the current cargo project declares any binary targets."
(let* ((bin? (lambda (kind) (string=? kind "bin")))
- (get-kinds (lambda (dep) (hash-ref dep "kind")))
+ (get-kinds (lambda (dep) (assoc-ref dep "kind")))
(bin-dep? (lambda (dep) (find bin? (get-kinds dep)))))
(find bin-dep? (manifest-targets))))
@@ -99,6 +99,7 @@ Cargo.toml file present at its root."
inputs)
;; Configure cargo to actually use this new directory.
+ (setenv "CARGO_HOME" (string-append (getcwd) "/.cargo"))
(mkdir-p ".cargo")
(let ((port (open-file ".cargo/config" "w" #:encoding "utf-8")))
(display "
@@ -148,9 +149,6 @@ directory = '" port)
;; Make cargo reuse all the artifacts we just built instead
;; of defaulting to making a new temp directory
(setenv "CARGO_TARGET_DIR" "./target")
- ;; Force cargo to honor our .cargo/config definitions
- ;; https://github.com/rust-lang/cargo/issues/6397
- (setenv "CARGO_HOME" ".")
;; Only install crates which include binary targets,
;; otherwise cargo will raise an error.
diff --git a/guix/build/compile.scm b/guix/build/compile.scm
index c8fe273f7e..c127456fd0 100644
--- a/guix/build/compile.scm
+++ b/guix/build/compile.scm
@@ -18,6 +18,7 @@
;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
(define-module (guix build compile)
+ #:use-module (srfi srfi-1)
#:use-module (ice-9 match)
#:use-module (ice-9 format)
#:use-module (ice-9 threads)
@@ -58,13 +59,23 @@
((kw _ rest ...)
(loop rest `(#f ,kw ,@result))))))
+(define (supported-warning-type? type)
+ "Return true if TYPE, a symbol, denotes a supported warning type."
+ (find (lambda (warning-type)
+ (eq? type (warning-type-name warning-type)))
+ %warning-types))
+
(define %warnings
;; FIXME: 'format' is missing because it reports "non-literal format
;; strings" due to the fact that we use 'G_' instead of '_'. We'll need
;; help from Guile to solve this.
- '(unsupported-warning unbound-variable arity-mismatch
- macro-use-before-definition ;new in 2.2
- shadowed-toplevel)) ;new in 2.2.5
+ (let ((optional (lambda (type)
+ (if (supported-warning-type? type)
+ (list type)
+ '()))))
+ `(unbound-variable arity-mismatch
+ macro-use-before-definition ;new in 2.2
+ ,@(optional 'shadowed-toplevel)))) ;new in 2.2.5
(define (optimization-options file)
"Return the default set of optimizations options for FILE."
@@ -118,8 +129,9 @@ front."
(lambda ()
(set! path initial-value)))))
-(define (call/exit-on-exception thunk)
- "Evaluate THUNK and exit right away if an exception is thrown."
+(define (call/exit-on-exception file thunk)
+ "Evaluate THUNK and exit right away if an exception is thrown. Report FILE
+as the file that was being compiled when the exception was thrown."
(catch #t
thunk
(const #f)
@@ -130,15 +142,18 @@ front."
(stack (make-stack #t))
(depth (stack-length stack))
(frame (and (> depth 1) (stack-ref stack 1))))
+ (newline port)
+ (format port "error: failed to compile '~a':~%~%" file)
(false-if-exception (display-backtrace stack port))
(print-exception port frame key args)))
;; Don't go any further.
(primitive-exit 1))))
-(define-syntax-rule (exit-on-exception exp ...)
- "Evaluate EXP and exit if an exception is thrown."
- (call/exit-on-exception (lambda () exp ...)))
+(define-syntax-rule (exit-on-exception file exp ...)
+ "Evaluate EXP and exit if an exception is thrown. Report FILE as the faulty
+file when an exception is thrown."
+ (call/exit-on-exception file (lambda () exp ...)))
(define* (compile-files source-directory build-directory files
#:key
@@ -162,6 +177,7 @@ files are for HOST, a GNU triplet such as \"x86_64-linux-gnu\"."
;; Exit as soon as something goes wrong.
(exit-on-exception
+ file
(with-target host
(lambda ()
(let ((relative (relative-file source-directory file)))
diff --git a/guix/build/json.scm b/guix/build/json.scm
new file mode 100644
index 0000000000..361ea76728
--- /dev/null
+++ b/guix/build/json.scm
@@ -0,0 +1,387 @@
+;;;; json.scm --- JSON reader/writer
+;;;; Copyright (C) 2015 Free Software Foundation, Inc.
+;;;;
+;;;; This library is free software; you can redistribute it and/or
+;;;; modify it under the terms of the GNU Lesser General Public
+;;;; License as published by the Free Software Foundation; either
+;;;; version 3 of the License, or (at your option) any later version.
+;;;;
+;;;; This library is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;;;; Lesser General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this library; if not, write to the Free Software
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+;;;;
+
+(define-module (guix build json) ;; originally (ice-9 json)
+ #:use-module (ice-9 match)
+ #:export (read-json write-json))
+
+;; Snarfed from
+;; https://github.com/cwebber/activitystuff/blob/master/activitystuff/contrib/json.scm
+;;
+
+;;;
+;;; Reader
+;;;
+
+(define (json-error port)
+ (throw 'json-error port))
+
+(define (assert-char port char)
+ "Read a character from PORT and throw an invalid JSON error if the
+character is not CHAR."
+ (unless (eqv? (read-char port) char)
+ (json-error port)))
+
+(define (whitespace? char)
+ "Return #t if CHAR is a whitespace character."
+ (char-set-contains? char-set:whitespace char))
+
+(define (consume-whitespace port)
+ "Discard characters from PORT until a non-whitespace character is
+encountered.."
+ (match (peek-char port)
+ ((? eof-object?) *unspecified*)
+ ((? whitespace?)
+ (read-char port)
+ (consume-whitespace port))
+ (_ *unspecified*)))
+
+(define (make-keyword-reader keyword value)
+ "Parse the keyword symbol KEYWORD as VALUE."
+ (let ((str (symbol->string keyword)))
+ (lambda (port)
+ (let loop ((i 0))
+ (cond
+ ((= i (string-length str)) value)
+ ((eqv? (string-ref str i) (read-char port))
+ (loop (1+ i)))
+ (else (json-error port)))))))
+
+(define read-true (make-keyword-reader 'true #t))
+(define read-false (make-keyword-reader 'false #f))
+(define read-null (make-keyword-reader 'null #nil))
+
+(define (read-hex-digit port)
+ "Read a hexadecimal digit from PORT."
+ (match (read-char port)
+ (#\0 0)
+ (#\1 1)
+ (#\2 2)
+ (#\3 3)
+ (#\4 4)
+ (#\5 5)
+ (#\6 6)
+ (#\7 7)
+ (#\8 8)
+ (#\9 9)
+ ((or #\A #\a) 10)
+ ((or #\B #\b) 11)
+ ((or #\C #\c) 12)
+ ((or #\D #\d) 13)
+ ((or #\E #\e) 14)
+ ((or #\F #\f) 15)
+ (_ (json-error port))))
+
+(define (read-utf16-character port)
+ "Read a hexadecimal encoded UTF-16 character from PORT."
+ (integer->char
+ (+ (* (read-hex-digit port) (expt 16 3))
+ (* (read-hex-digit port) (expt 16 2))
+ (* (read-hex-digit port) 16)
+ (read-hex-digit port))))
+
+(define (read-escape-character port)
+ "Read escape character from PORT."
+ (match (read-char port)
+ (#\" #\")
+ (#\\ #\\)
+ (#\/ #\/)
+ (#\b #\backspace)
+ (#\f #\page)
+ (#\n #\newline)
+ (#\r #\return)
+ (#\t #\tab)
+ (#\u (read-utf16-character port))
+ (_ (json-error port))))
+
+(define (read-string port)
+ "Read a JSON encoded string from PORT."
+ (assert-char port #\")
+ (let loop ((result '()))
+ (match (read-char port)
+ ((? eof-object?) (json-error port))
+ (#\" (list->string (reverse result)))
+ (#\\ (loop (cons (read-escape-character port) result)))
+ (char (loop (cons char result))))))
+
+(define char-set:json-digit
+ (char-set #\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9))
+
+(define (digit? char)
+ (char-set-contains? char-set:json-digit char))
+
+(define (read-digit port)
+ "Read a digit 0-9 from PORT."
+ (match (read-char port)
+ (#\0 0)
+ (#\1 1)
+ (#\2 2)
+ (#\3 3)
+ (#\4 4)
+ (#\5 5)
+ (#\6 6)
+ (#\7 7)
+ (#\8 8)
+ (#\9 9)
+ (else (json-error port))))
+
+(define (read-digits port)
+ "Read a sequence of digits from PORT."
+ (let loop ((result '()))
+ (match (peek-char port)
+ ((? eof-object?)
+ (reverse result))
+ ((? digit?)
+ (loop (cons (read-digit port) result)))
+ (else (reverse result)))))
+
+(define (list->integer digits)
+ "Convert the list DIGITS to an integer."
+ (let loop ((i (1- (length digits)))
+ (result 0)
+ (digits digits))
+ (match digits
+ (() result)
+ ((n . tail)
+ (loop (1- i)
+ (+ result (* n (expt 10 i)))
+ tail)))))
+
+(define (read-positive-integer port)
+ "Read a positive integer with no leading zeroes from PORT."
+ (match (read-digits port)
+ ((0 . _)
+ (json-error port)) ; no leading zeroes allowed
+ ((digits ...)
+ (list->integer digits))))
+
+(define (read-exponent port)
+ "Read exponent from PORT."
+ (define (read-expt)
+ (list->integer (read-digits port)))
+
+ (unless (memv (read-char port) '(#\e #\E))
+ (json-error port))
+
+ (match (peek-char port)
+ ((? eof-object?)
+ (json-error port))
+ (#\-
+ (read-char port)
+ (- (read-expt)))
+ (#\+
+ (read-char port)
+ (read-expt))
+ ((? digit?)
+ (read-expt))
+ (_ (json-error port))))
+
+(define (read-fraction port)
+ "Read fractional number part from PORT as an inexact number."
+ (let* ((digits (read-digits port))
+ (numerator (list->integer digits))
+ (denomenator (expt 10 (length digits))))
+ (/ numerator denomenator)))
+
+(define (read-positive-number port)
+ "Read a positive number from PORT."
+ (let* ((integer (match (peek-char port)
+ ((? eof-object?)
+ (json-error port))
+ (#\0
+ (read-char port)
+ 0)
+ ((? digit?)
+ (read-positive-integer port))
+ (_ (json-error port))))
+ (fraction (match (peek-char port)
+ (#\.
+ (read-char port)
+ (read-fraction port))
+ (_ 0)))
+ (exponent (match (peek-char port)
+ ((or #\e #\E)
+ (read-exponent port))
+ (_ 0)))
+ (n (* (+ integer fraction) (expt 10 exponent))))
+
+ ;; Keep integers as exact numbers, but convert numbers encoded as
+ ;; floating point numbers to an inexact representation.
+ (if (zero? fraction)
+ n
+ (exact->inexact n))))
+
+(define (read-number port)
+ "Read a number from PORT"
+ (match (peek-char port)
+ ((? eof-object?)
+ (json-error port))
+ (#\-
+ (read-char port)
+ (- (read-positive-number port)))
+ ((? digit?)
+ (read-positive-number port))
+ (_ (json-error port))))
+
+(define (read-object port)
+ "Read key/value map from PORT."
+ (define (read-key+value-pair)
+ (let ((key (read-string port)))
+ (consume-whitespace port)
+ (assert-char port #\:)
+ (consume-whitespace port)
+ (let ((value (read-value port)))
+ (cons key value))))
+
+ (assert-char port #\{)
+ (consume-whitespace port)
+
+ (if (eqv? #\} (peek-char port))
+ (begin
+ (read-char port)
+ '(@)) ; empty object
+ (let loop ((result (list (read-key+value-pair))))
+ (consume-whitespace port)
+ (match (peek-char port)
+ (#\, ; read another value
+ (read-char port)
+ (consume-whitespace port)
+ (loop (cons (read-key+value-pair) result)))
+ (#\} ; end of object
+ (read-char port)
+ (cons '@ (reverse result)))
+ (_ (json-error port))))))
+
+(define (read-array port)
+ "Read array from PORT."
+ (assert-char port #\[)
+ (consume-whitespace port)
+
+ (if (eqv? #\] (peek-char port))
+ (begin
+ (read-char port)
+ '()) ; empty array
+ (let loop ((result (list (read-value port))))
+ (consume-whitespace port)
+ (match (peek-char port)
+ (#\, ; read another value
+ (read-char port)
+ (consume-whitespace port)
+ (loop (cons (read-value port) result)))
+ (#\] ; end of array
+ (read-char port)
+ (reverse result))
+ (_ (json-error port))))))
+
+(define (read-value port)
+ "Read a JSON value from PORT."
+ (consume-whitespace port)
+ (match (peek-char port)
+ ((? eof-object?) (json-error port))
+ (#\" (read-string port))
+ (#\{ (read-object port))
+ (#\[ (read-array port))
+ (#\t (read-true port))
+ (#\f (read-false port))
+ (#\n (read-null port))
+ ((or #\- (? digit?))
+ (read-number port))
+ (_ (json-error port))))
+
+(define (read-json port)
+ "Read JSON text from port and return an s-expression representation."
+ (let ((result (read-value port)))
+ (consume-whitespace port)
+ (unless (eof-object? (peek-char port))
+ (json-error port))
+ result))
+
+
+;;;
+;;; Writer
+;;;
+
+(define (write-string str port)
+ "Write STR to PORT in JSON string format."
+ (define (escape-char char)
+ (display (match char
+ (#\" "\\\"")
+ (#\\ "\\\\")
+ (#\/ "\\/")
+ (#\backspace "\\b")
+ (#\page "\\f")
+ (#\newline "\\n")
+ (#\return "\\r")
+ (#\tab "\\t")
+ (_ char))
+ port))
+
+ (display "\"" port)
+ (string-for-each escape-char str)
+ (display "\"" port))
+
+(define (write-object alist port)
+ "Write ALIST to PORT in JSON object format."
+ ;; Keys may be strings or symbols.
+ (define key->string
+ (match-lambda
+ ((? string? key) key)
+ ((? symbol? key) (symbol->string key))))
+
+ (define (write-pair pair)
+ (match pair
+ ((key . value)
+ (write-string (key->string key) port)
+ (display ":" port)
+ (write-json value port))))
+
+ (display "{" port)
+ (match alist
+ (() #f)
+ ((front ... end)
+ (for-each (lambda (pair)
+ (write-pair pair)
+ (display "," port))
+ front)
+ (write-pair end)))
+ (display "}" port))
+
+(define (write-array lst port)
+ "Write LST to PORT in JSON array format."
+ (display "[" port)
+ (match lst
+ (() #f)
+ ((front ... end)
+ (for-each (lambda (val)
+ (write-json val port)
+ (display "," port))
+ front)
+ (write-json end port)))
+ (display "]" port))
+
+(define (write-json exp port)
+ "Write EXP to PORT in JSON format."
+ (match exp
+ (#t (display "true" port))
+ (#f (display "false" port))
+ ;; Differentiate #nil from '().
+ ((and (? boolean? ) #nil) (display "null" port))
+ ((? string? s) (write-string s port))
+ ((? real? n) (display n port))
+ (('@ . alist) (write-object alist port))
+ ((vals ...) (write-array vals port))))
diff --git a/guix/build/node-build-system.scm b/guix/build/node-build-system.scm
new file mode 100644
index 0000000000..3c0ac2a12b
--- /dev/null
+++ b/guix/build/node-build-system.scm
@@ -0,0 +1,166 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2015 David Thompson <davet@gnu.org>
+;;; Copyright © 2016 Jelle Licht <jlicht@fsfe.org>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Guix is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (guix build node-build-system)
+ #:use-module ((guix build gnu-build-system) #:prefix gnu:)
+ #:use-module (guix build json)
+ #:use-module (guix build union)
+ #:use-module (guix build utils)
+ #:use-module (ice-9 match)
+ #:use-module (ice-9 popen)
+ #:use-module (ice-9 regex)
+ #:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-26)
+ #:export (%standard-phases
+ node-build))
+
+;; Commentary:
+;;
+;; Builder-side code of the standard Node/npm package build procedure.
+;;
+;; Code:
+
+(define* (read-package-data #:key (filename "package.json"))
+ (call-with-input-file filename
+ (lambda (port)
+ (read-json port))))
+
+(define* (build #:key inputs #:allow-other-keys)
+ (define (build-from-package-json? package-file)
+ (let* ((package-data (read-package-data #:filename package-file))
+ (scripts (assoc-ref package-data "scripts")))
+ (assoc-ref scripts "build")))
+ "Build a new node module using the appropriate build system."
+ ;; XXX: Develop a more robust heuristic, allow override
+ (cond ((file-exists? "gulpfile.js")
+ (invoke "gulp"))
+ ((file-exists? "gruntfile.js")
+ (invoke "grunt"))
+ ((file-exists? "Makefile")
+ (invoke "make"))
+ ((and (file-exists? "package.json")
+ (build-from-package-json? "package.json"))
+ (invoke "npm" "run" "build")))
+ #t)
+
+(define* (link-npm-dependencies #:key inputs #:allow-other-keys)
+ (define (inputs->node-inputs inputs)
+ "Filter the directory part from INPUTS."
+ (filter (lambda (input)
+ (match input
+ ((name . _) (node-package? name))))
+ inputs))
+ (define (inputs->directories inputs)
+ "Extract the directory part from INPUTS."
+ (match inputs
+ (((names . directories) ...)
+ directories)))
+ (define (make-node-path root)
+ (string-append root "/lib/node_modules/"))
+
+ (let ((input-node-directories (inputs->directories
+ (inputs->node-inputs inputs))))
+ (union-build "node_modules"
+ (map make-node-path input-node-directories))
+ #t))
+
+(define configure link-npm-dependencies)
+
+(define* (check #:key tests? #:allow-other-keys)
+ "Run 'npm test' if TESTS?"
+ (if tests?
+ ;; Should only be enabled once we know that there are tests
+ (invoke "npm" "test"))
+ #t)
+
+(define (node-package? name)
+ "Check if NAME correspond to the name of an Node package."
+ (string-prefix? "node-" name))
+
+(define* (install #:key outputs inputs #:allow-other-keys)
+ "Install the node module to the output store item. The module itself is
+installed in a subdirectory of @file{node_modules} and its runtime dependencies
+as defined by @file{package.json} are symlinked into a @file{node_modules}
+subdirectory of the module's directory. Additionally, binaries are installed in
+the @file{bin} directory."
+ (let* ((out (assoc-ref outputs "out"))
+ (target (string-append out "/lib"))
+ (binaries (string-append out "/bin"))
+ (data (read-package-data))
+ (modulename (assoc-ref data "name"))
+ (binary-configuration (match (assoc-ref data "bin")
+ (('@ configuration ...) configuration)
+ ((? string? configuration) configuration)
+ (#f #f)))
+ (dependencies (match (assoc-ref data "dependencies")
+ (('@ deps ...) deps)
+ (#f #f))))
+ (mkdir-p target)
+ (copy-recursively "." (string-append target "/node_modules/" modulename))
+ ;; Remove references to dependencies
+ (delete-file-recursively
+ (string-append target "/node_modules/" modulename "/node_modules"))
+ (cond
+ ((string? binary-configuration)
+ (begin
+ (mkdir-p binaries)
+ (symlink (string-append target "/node_modules/" modulename "/"
+ binary-configuration)
+ (string-append binaries "/" modulename))))
+ ((list? binary-configuration)
+ (for-each
+ (lambda (conf)
+ (match conf
+ ((key . value)
+ (begin
+ (mkdir-p (dirname (string-append binaries "/" key)))
+ (symlink (string-append target "/node_modules/" modulename "/"
+ value)
+ (string-append binaries "/" key))))))
+ binary-configuration))
+ (else
+ (symlink (string-append target "/node_modules/" modulename "/bin")
+ binaries)))
+ (when dependencies
+ (mkdir-p
+ (string-append target "/node_modules/" modulename "/node_modules"))
+ (for-each
+ (lambda (dependency)
+ (let ((dependency (car dependency)))
+ (symlink
+ (string-append (assoc-ref inputs (string-append "node-" dependency))
+ "/lib/node_modules/" dependency)
+ (string-append target "/node_modules/" modulename
+ "/node_modules/" dependency))))
+ dependencies))
+ #t))
+
+
+(define %standard-phases
+ (modify-phases gnu:%standard-phases
+ (replace 'configure configure)
+ (replace 'build build)
+ (replace 'install install)
+ (delete 'check)
+ (add-after 'install 'check check)
+ (delete 'strip)))
+
+(define* (node-build #:key inputs (phases %standard-phases)
+ #:allow-other-keys #:rest args)
+ (apply gnu:gnu-build #:inputs inputs #:phases phases args))
diff --git a/guix/build/syscalls.scm b/guix/build/syscalls.scm
index eb045cbd1c..3c84d3893f 100644
--- a/guix/build/syscalls.scm
+++ b/guix/build/syscalls.scm
@@ -48,13 +48,6 @@
MNT_EXPIRE
UMOUNT_NOFOLLOW
- AT_FDCWD
- AT_SYMLINK_NOFOLLOW
- AT_REMOVEDIR
- AT_SYMLINK_FOLLOW
- AT_NO_AUTOMOUNT
- AT_EMPTY_PATH
-
restart-on-EINTR
mount-points
swapon
@@ -686,12 +679,12 @@ mounted at FILE."
;; Flags for the *at command, notably the 'utime' procedure of libguile.
;; From <fcntl.h>.
-(define AT_FDCWD -100)
-(define AT_SYMLINK_NOFOLLOW #x100)
-(define AT_REMOVEDIR #x200)
-(define AT_SYMLINK_FOLLOW #x400)
-(define AT_NO_AUTOMOUNT #x800)
-(define AT_EMPTY_PATH #x1000)
+(define-as-needed AT_FDCWD -100)
+(define-as-needed AT_SYMLINK_NOFOLLOW #x100)
+(define-as-needed AT_REMOVEDIR #x200)
+(define-as-needed AT_SYMLINK_FOLLOW #x400)
+(define-as-needed AT_NO_AUTOMOUNT #x800)
+(define-as-needed AT_EMPTY_PATH #x1000)
(define-syntax BLKRRPART ;<sys/mount.h>
(identifier-syntax #x125F))
diff --git a/guix/channels.scm b/guix/channels.scm
index e6bb9b891b..bfe6963418 100644
--- a/guix/channels.scm
+++ b/guix/channels.scm
@@ -1,6 +1,7 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2018, 2019 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2018 Ricardo Wurmus <rekado@elephly.net>
+;;; Copyright © 2019 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -107,9 +108,10 @@
(checkout channel-instance-checkout))
(define-record-type <channel-metadata>
- (channel-metadata version dependencies)
+ (channel-metadata version directory dependencies)
channel-metadata?
(version channel-metadata-version)
+ (directory channel-metadata-directory)
(dependencies channel-metadata-dependencies))
(define (channel-reference channel)
@@ -119,18 +121,18 @@
(#f `(branch . ,(channel-branch channel)))
(commit `(commit . ,(channel-commit channel)))))
-(define (read-channel-metadata instance)
- "Return a channel-metadata record read from the channel INSTANCE's
-description file, or return #F if the channel instance does not include the
-file."
- (let* ((source (channel-instance-checkout instance))
- (meta-file (string-append source "/.guix-channel")))
+(define (read-channel-metadata-from-source source)
+ "Return a channel-metadata record read from channel's SOURCE/.guix-channel
+description file, or return #F if SOURCE/.guix-channel does not exist."
+ (let ((meta-file (string-append source "/.guix-channel")))
(and (file-exists? meta-file)
- (and-let* ((raw (call-with-input-file meta-file read))
- (version (and=> (assoc-ref raw 'version) first))
- (dependencies (or (assoc-ref raw 'dependencies) '())))
+ (let* ((raw (call-with-input-file meta-file read))
+ (version (and=> (assoc-ref raw 'version) first))
+ (directory (and=> (assoc-ref raw 'directory) first))
+ (dependencies (or (assoc-ref raw 'dependencies) '())))
(channel-metadata
version
+ directory
(map (lambda (item)
(let ((get (lambda* (key #:optional default)
(or (and=> (assoc-ref item key) first) default))))
@@ -144,12 +146,18 @@ file."
(commit (get 'commit))))))
dependencies))))))
+(define (read-channel-metadata instance)
+ "Return a channel-metadata record read from the channel INSTANCE's
+description file, or return #F if the channel instance does not include the
+file."
+ (read-channel-metadata-from-source (channel-instance-checkout instance)))
+
(define (channel-instance-dependencies instance)
"Return the list of channels that are declared as dependencies for the given
channel INSTANCE."
(match (read-channel-metadata instance)
(#f '())
- (($ <channel-metadata> version dependencies)
+ (($ <channel-metadata> version directory dependencies)
dependencies)))
(define* (latest-channel-instances store channels #:optional (previous-channels '()))
@@ -230,36 +238,39 @@ of COMMIT at URL. Use NAME as the channel name."
modules in SOURCE and that depend on DEPENDENCIES, a list of lowerable
objects. The assumption is that SOURCE contains package modules to be added
to '%package-module-path'."
- ;; FIXME: We should load, say SOURCE/.guix-channel.scm, which would allow
- ;; channel publishers to specify things such as the sub-directory where .scm
- ;; files live, files to exclude from the channel, preferred substitute URLs,
- ;; etc.
-
- (define build
- ;; This is code that we'll run in CORE, a Guix instance, with its own
- ;; modules and so on. That way, we make sure these modules are built for
- ;; the right Guile version, with the right dependencies, and that they get
- ;; to see the right (gnu packages …) modules.
- (with-extensions dependencies
- #~(begin
- (use-modules (guix build compile)
- (guix build utils)
- (srfi srfi-26))
-
- (define go
- (string-append #$output "/lib/guile/" (effective-version)
- "/site-ccache"))
- (define scm
- (string-append #$output "/share/guile/site/"
- (effective-version)))
- (compile-files #$source go
- (find-files #$source "\\.scm$"))
- (mkdir-p (dirname scm))
- (symlink #$source scm)
- scm)))
+ (let* ((metadata (read-channel-metadata-from-source source))
+ (directory (and=> metadata channel-metadata-directory)))
- (gexp->derivation-in-inferior name build core))
+ (define build
+ ;; This is code that we'll run in CORE, a Guix instance, with its own
+ ;; modules and so on. That way, we make sure these modules are built for
+ ;; the right Guile version, with the right dependencies, and that they get
+ ;; to see the right (gnu packages …) modules.
+ (with-extensions dependencies
+ #~(begin
+ (use-modules (guix build compile)
+ (guix build utils)
+ (srfi srfi-26))
+
+ (define go
+ (string-append #$output "/lib/guile/" (effective-version)
+ "/site-ccache"))
+ (define scm
+ (string-append #$output "/share/guile/site/"
+ (effective-version)))
+
+ (let* ((subdir (if #$directory
+ (string-append "/" #$directory)
+ ""))
+ (source (string-append #$source subdir)))
+ (compile-files source go (find-files source "\\.scm$"))
+ (mkdir-p (dirname scm))
+ (symlink (string-append #$source subdir) scm))
+
+ scm)))
+
+ (gexp->derivation-in-inferior name build core)))
(define* (build-from-source name source
#:key core verbose? commit
@@ -424,8 +435,9 @@ derivation."
;; "old style" (before commit 8a0d9bc8a3f153159d9e239a151c0fa98f1e12d8,
;; dated May 30, 2018) did not depend on "guix-command.drv".
(not (find (lambda (input)
- (string-suffix? "-guix-command.drv"
- (derivation-input-path input)))
+ (string=? "guix-command"
+ (derivation-name
+ (derivation-input-derivation input))))
(derivation-inputs drv))))
(define (channel-instances->manifest instances)
diff --git a/guix/derivations.scm b/guix/derivations.scm
index 731f1f698f..92d50503ce 100644
--- a/guix/derivations.scm
+++ b/guix/derivations.scm
@@ -36,6 +36,8 @@
#:use-module (guix memoization)
#:use-module (guix combinators)
#:use-module (guix deprecation)
+ #:use-module (guix diagnostics)
+ #:use-module (guix i18n)
#:use-module (guix monads)
#:use-module (gcrypt hash)
#:use-module (guix base32)
@@ -69,6 +71,7 @@
derivation-input-derivation
derivation-input-sub-derivations
derivation-input-output-paths
+ derivation-input-output-path
valid-derivation-input?
&derivation-error
@@ -219,6 +222,13 @@ download with a fixed hash (aka. `fetchurl')."
(map (cut derivation->output-path drv <>)
sub-drvs))))
+(define (derivation-input-output-path input)
+ "Return the output file name of INPUT. If INPUT has more than one outputs,
+an error is raised."
+ (match input
+ (($ <derivation-input> drv (output))
+ (derivation->output-path drv output))))
+
(define (valid-derivation-input? store input)
"Return true if INPUT is valid--i.e., if all the outputs it requests are in
the store."
@@ -705,16 +715,25 @@ name of each input with that input's hash."
;; character.
(sha256 (derivation->bytevector (derivation/masked-inputs drv)))))))
+
+(define (warn-about-derivation-deprecation name)
+ ;; TRANSLATORS: 'derivation' must not be translated; it refers to the
+ ;; 'derivation' procedure.
+ (warning (G_ "in '~a': deprecated 'derivation' calling convention used~%")
+ name))
+
(define* (derivation store name builder args
#:key
(system (%current-system)) (env-vars '())
- (inputs '()) (outputs '("out"))
+ (inputs '()) (sources '())
+ (outputs '("out"))
hash hash-algo recursive?
references-graphs
allowed-references disallowed-references
leaked-env-vars local-build?
(substitutable? #t)
- (properties '()))
+ (properties '())
+ (%deprecation-warning? #t))
"Build a derivation with the given arguments, and return the resulting
<derivation> object. When HASH and HASH-ALGO are given, a
fixed-output derivation is created---i.e., one whose result is known in
@@ -831,17 +850,28 @@ derivation. It is kept as-is, uninterpreted, in the derivation."
e
outputs)))
+ (define-syntax-rule (warn-deprecation name)
+ (when %deprecation-warning?
+ (warn-about-derivation-deprecation name)))
+
(define input->derivation-input
(match-lambda
+ ((? derivation-input? input)
+ input)
(((? derivation? drv))
+ (warn-deprecation name)
(make-derivation-input drv '("out")))
(((? derivation? drv) sub-drvs ...)
+ (warn-deprecation name)
(make-derivation-input drv sub-drvs))
- (_ #f)))
+ (_
+ (warn-deprecation name)
+ #f)))
(define input->source
(match-lambda
(((? string? input) . _)
+ (warn-deprecation name)
(if (direct-store-path? input)
input
(add-to-store store (basename input)
@@ -858,7 +888,8 @@ derivation. It is kept as-is, uninterpreted, in the derivation."
hash recursive?)))
(sort outputs string<?)))
(sources (sort (delete-duplicates
- (filter-map input->source inputs))
+ (append (filter-map input->source inputs)
+ sources))
string<?))
(inputs (sort (coalesce-duplicate-inputs
(filter-map input->derivation-input inputs))
@@ -929,13 +960,10 @@ recursively."
(define input->output-paths
(match-lambda
- (((? derivation? drv))
- (list (derivation->output-path drv)))
- (((? derivation? drv) sub-drvs ...)
- (map (cut derivation->output-path drv <>)
- sub-drvs))
- ((file)
- (list file))))
+ ((? derivation-input? input)
+ (derivation-input-output-paths input))
+ ((? string? file)
+ (list file))))
(let ((mapping (fold (lambda (pair result)
(match pair
@@ -954,11 +982,11 @@ recursively."
(($ <derivation-input> drv (sub-drvs ...))
(match (vhash-assoc (derivation-file-name drv) mapping)
((_ . (? derivation? replacement))
- (cons replacement sub-drvs))
- ((_ . replacement)
- (list replacement))
+ (derivation-input replacement sub-drvs))
+ ((_ . (? string? source))
+ source)
(#f
- (cons (loop drv) sub-drvs)))))))
+ (derivation-input (loop drv) sub-drvs)))))))
(let loop ((drv drv))
(let* ((inputs (map (cut rewritten-input <> loop)
@@ -997,7 +1025,8 @@ recursively."
. ,(substitute value initial
replacements))))
(derivation-builder-environment-vars drv))
- #:inputs (append (map list sources) inputs)
+ #:inputs (filter derivation-input? inputs)
+ #:sources (append sources (filter string? inputs))
#:outputs (derivation-output-names drv)
#:hash (match (derivation-outputs drv)
((($ <derivation-output> _ algo hash))
@@ -1318,6 +1347,10 @@ and PROPERTIES."
,@(if mod-dir `("-L" ,mod-dir) '())
,builder)
+ ;; 'build-expression->derivation' is somewhat deprecated so
+ ;; don't bother warning here.
+ #:%deprecation-warning? #f
+
#:system system
#:inputs `((,(or guile-for-build (%guile-for-build)))
diff --git a/guix/download.scm b/guix/download.scm
index 00afd2e032..47c8087732 100644
--- a/guix/download.scm
+++ b/guix/download.scm
@@ -436,8 +436,7 @@ download by itself using its own dependencies."
#:hash-algo hash-algo
#:hash hash
#:recursive? executable?
- #:inputs `((,mirrors)
- (,content-addressed-mirrors))
+ #:sources (list mirrors content-addressed-mirrors)
;; Honor the user's proxy and locale settings.
#:leaked-env-vars '("http_proxy" "https_proxy"
diff --git a/guix/gexp.scm b/guix/gexp.scm
index 186bce19a8..586aaa496e 100644
--- a/guix/gexp.scm
+++ b/guix/gexp.scm
@@ -85,6 +85,7 @@
lowered-gexp?
lowered-gexp-sexp
lowered-gexp-inputs
+ lowered-gexp-sources
lowered-gexp-guile
lowered-gexp-load-path
lowered-gexp-load-compiled-path
@@ -574,9 +575,9 @@ list."
(define* (lower-inputs inputs
#:key system target)
- "Turn any package from INPUTS into a derivation for SYSTEM; return the
-corresponding input list as a monadic value. When TARGET is true, use it as
-the cross-compilation target triplet."
+ "Turn any object from INPUTS into a derivation input for SYSTEM or a store
+item (a \"source\"); return the corresponding input list as a monadic value.
+When TARGET is true, use it as the cross-compilation target triplet."
(define (store-item? obj)
(and (string? obj) (store-path? obj)))
@@ -584,27 +585,30 @@ the cross-compilation target triplet."
(mapm %store-monad
(match-lambda
(((? struct? thing) sub-drv ...)
- (mlet %store-monad ((drv (lower-object
+ (mlet %store-monad ((obj (lower-object
thing system #:target target)))
- (return (apply gexp-input drv sub-drv))))
+ (return (match obj
+ ((? derivation? drv)
+ (let ((outputs (if (null? sub-drv)
+ '("out")
+ sub-drv)))
+ (derivation-input drv outputs)))
+ ((? store-item? item)
+ item)))))
(((? store-item? item))
- (return (gexp-input item)))
- (input
- (return (gexp-input input))))
+ (return item)))
inputs)))
(define* (lower-reference-graphs graphs #:key system target)
"Given GRAPHS, a list of (FILE-NAME INPUT ...) lists for use as a
#:reference-graphs argument, lower it such that each INPUT is replaced by the
-corresponding derivation."
+corresponding <derivation-input> or store item."
(match graphs
(((file-names . inputs) ...)
(mlet %store-monad ((inputs (lower-inputs inputs
#:system system
#:target target)))
- (return (map (lambda (file input)
- (cons file (gexp-input->tuple input)))
- file-names inputs))))))
+ (return (map cons file-names inputs))))))
(define* (lower-references lst #:key system target)
"Based on LST, a list of output names and packages, return a list of output
@@ -637,12 +641,14 @@ names and file names suitable for the #:allowed-references argument to
((force proc) system))))
;; Representation of a gexp instantiated for a given target and system.
+;; It's an intermediate representation between <gexp> and <derivation>.
(define-record-type <lowered-gexp>
- (lowered-gexp sexp inputs guile load-path load-compiled-path)
+ (lowered-gexp sexp inputs sources guile load-path load-compiled-path)
lowered-gexp?
(sexp lowered-gexp-sexp) ;sexp
- (inputs lowered-gexp-inputs) ;list of <gexp-input>
- (guile lowered-gexp-guile) ;<derivation> | #f
+ (inputs lowered-gexp-inputs) ;list of <derivation-input>
+ (sources lowered-gexp-sources) ;list of store items
+ (guile lowered-gexp-guile) ;<derivation-input> | #f
(load-path lowered-gexp-load-path) ;list of store items
(load-compiled-path lowered-gexp-load-compiled-path)) ;list of store items
@@ -737,26 +743,19 @@ derivations--e.g., code evaluated for its side effects."
(mbegin %store-monad
(set-grafting graft?) ;restore the initial setting
(return (lowered-gexp sexp
- `(,@(if modules
- (list (gexp-input modules))
+ `(,@(if (derivation? modules)
+ (list (derivation-input modules))
'())
,@(if compiled
- (list (gexp-input compiled))
+ (list (derivation-input compiled))
'())
- ,@(map gexp-input exts)
- ,@inputs)
- guile
+ ,@(map derivation-input exts)
+ ,@(filter derivation-input? inputs))
+ (filter string? (cons modules inputs))
+ (derivation-input guile '("out"))
load-path
load-compiled-path)))))
-(define (gexp-input->tuple input)
- "Given INPUT, a <gexp-input> record, return the corresponding input tuple
-suitable for the 'derivation' procedure."
- (match (gexp-input-output input)
- ("out" `(,(gexp-input-thing input)))
- (output `(,(gexp-input-thing input)
- ,(gexp-input-output input)))))
-
(define* (gexp->derivation name exp
#:key
system (target 'current)
@@ -821,13 +820,10 @@ The other arguments are as for 'derivation'."
(define (graphs-file-names graphs)
;; Return a list of (FILE-NAME . STORE-PATH) pairs made from GRAPHS.
(map (match-lambda
- ;; TODO: Remove 'derivation?' special cases.
- ((file-name (? derivation? drv))
- (cons file-name (derivation->output-path drv)))
- ((file-name (? derivation? drv) sub-drv)
- (cons file-name (derivation->output-path drv sub-drv)))
- ((file-name thing)
- (cons file-name thing)))
+ ((file-name . (? derivation-input? input))
+ (cons file-name (first (derivation-input-output-paths input))))
+ ((file-name . (? string? item))
+ (cons file-name item)))
graphs))
(define (add-modules exp modules)
@@ -882,7 +878,7 @@ The other arguments are as for 'derivation'."
(mbegin %store-monad
(set-grafting graft?) ;restore the initial setting
(raw-derivation name
- (string-append (derivation->output-path guile)
+ (string-append (derivation-input-output-path guile)
"/bin/guile")
`("--no-auto-compile"
,@(append-map (lambda (directory)
@@ -895,13 +891,23 @@ The other arguments are as for 'derivation'."
#:outputs outputs
#:env-vars env-vars
#:system system
- #:inputs `((,guile)
- (,builder)
- ,@(map gexp-input->tuple
- (lowered-gexp-inputs lowered))
+ #:inputs `(,guile
+ ,@(lowered-gexp-inputs lowered)
,@(match graphs
- (((_ . inputs) ...) inputs)
- (_ '())))
+ (((_ . inputs) ...)
+ (filter derivation-input? inputs))
+ (#f '())))
+ #:sources `(,builder
+ ,@(if (and (string? modules)
+ (store-path? modules))
+ (list modules)
+ '())
+ ,@(lowered-gexp-sources lowered)
+ ,@(match graphs
+ (((_ . inputs) ...)
+ (filter string? inputs))
+ (#f '())))
+
#:hash hash #:hash-algo hash-algo #:recursive? recursive?
#:references-graphs (and=> graphs graphs-file-names)
#:allowed-references allowed
diff --git a/guix/lint.scm b/guix/lint.scm
new file mode 100644
index 0000000000..2542a81a2d
--- /dev/null
+++ b/guix/lint.scm
@@ -0,0 +1,1231 @@
+;;; 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, 2017, 2018, 2019 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>
+;;; Copyright © 2017 Tobias Geerinckx-Rice <me@tobias.gr>
+;;; Copyright © 2017, 2018 Efraim Flashner <efraim@flashner.co.il>
+;;; Copyright © 2018, 2019 Arun Isaac <arunisaac@systemreboot.net>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Guix is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (guix lint)
+ #:use-module ((guix store) #:hide (close-connection))
+ #:use-module (guix base32)
+ #:use-module (guix diagnostics)
+ #:use-module (guix download)
+ #:use-module (guix ftp-client)
+ #:use-module (guix http-client)
+ #:use-module (guix packages)
+ #:use-module (guix i18n)
+ #:use-module (guix licenses)
+ #:use-module (guix records)
+ #:use-module (guix grafts)
+ #:use-module (guix upstream)
+ #:use-module (guix utils)
+ #:use-module (guix memoization)
+ #:use-module (guix scripts)
+ #:use-module ((guix ui) #:select (texi->plain-text fill-paragraph))
+ #: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 (ice-9 rdelim)
+ #:export (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
+
+ lint-warning
+ lint-warning?
+ lint-warning-package
+ lint-warning-message
+ lint-warning-message-text
+ lint-warning-message-data
+ lint-warning-location
+
+ %local-checkers
+ %network-dependent-checkers
+ %all-checkers
+
+ lint-checker
+ lint-checker?
+ lint-checker-name
+ lint-checker-description
+ lint-checker-check))
+
+
+;;;
+;;; Warnings
+;;;
+
+(define-record-type* <lint-warning>
+ 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 ...))))
+
+
+;;;
+;;; 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 (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
+ ;; <http://lists.gnu.org/archive/html/bug-womb/2014-11/msg00000.html>.
+ (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 <origin> 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 %local-checkers
+ (list
+ (lint-checker
+ (name 'description)
+ (description "Validate package descriptions")
+ (check check-description-style))
+ (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 '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 'mirror-url)
+ (description "Suggest 'mirror://' URLs")
+ (check check-mirror-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 'patch-file-names)
+ (description "Validate file names and availability of patches")
+ (check check-patch-file-names))
+ (lint-checker
+ (name 'formatting)
+ (description "Look for formatting issues in the source")
+ (check check-formatting))))
+
+(define %network-dependent-checkers
+ (list
+ (lint-checker
+ (name 'synopsis)
+ (description "Validate package synopses")
+ (check check-synopsis-style))
+ (lint-checker
+ (name 'gnu-description)
+ (description "Validate synopsis & description of GNU packages")
+ (check check-gnu-synopsis+description))
+ (lint-checker
+ (name 'home-page)
+ (description "Validate home-page URLs")
+ (check check-home-page))
+ (lint-checker
+ (name 'source)
+ (description "Validate source URLs")
+ (check check-source))
+ (lint-checker
+ (name 'github-url)
+ (description "Suggest GitHub URLs")
+ (check check-github-url))
+ (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))))
+
+(define %all-checkers
+ (append %local-checkers
+ %network-dependent-checkers))
diff --git a/guix/remote.scm b/guix/remote.scm
index e503c76167..5fecd954e9 100644
--- a/guix/remote.scm
+++ b/guix/remote.scm
@@ -46,7 +46,7 @@
(compose object->string object->string))
(apply open-remote-pipe* session OPEN_READ
- (string-append (derivation->output-path
+ (string-append (derivation-input-output-path
(lowered-gexp-guile lowered))
"/bin/guile")
"--no-auto-compile"
@@ -76,8 +76,14 @@ result to the current output port using the (guix repl) protocol."
(with-imported-modules (source-module-closure '((guix repl)))
#~(begin
(use-modules (guix repl))
- (send-repl-response '(primitive-load #$program)
+
+ ;; We use CURRENT-OUTPUT-PORT for REPL messages, so redirect PROGRAM's
+ ;; output to CURRENT-ERROR-PORT so that it does not interfere.
+ (send-repl-response '(with-output-to-port (current-error-port)
+ (lambda ()
+ (primitive-load #$program)))
(current-output-port))
+
(force-output))))
(define* (remote-eval exp session
@@ -95,40 +101,27 @@ remote store."
(remote -> (connect-to-remote-daemon session
socket-name)))
(define inputs
- (cons (gexp-input (lowered-gexp-guile lowered))
+ (cons (lowered-gexp-guile lowered)
(lowered-gexp-inputs lowered)))
- (define to-build
- (map (lambda (input)
- (if (derivation? (gexp-input-thing input))
- (cons (gexp-input-thing input)
- (gexp-input-output input))
- (gexp-input-thing input)))
- inputs))
+ (define sources
+ (lowered-gexp-sources lowered))
(if build-locally?
- (let ((to-send (map (lambda (input)
- (match (gexp-input-thing input)
- ((? derivation? drv)
- (derivation->output-path
- drv (gexp-input-output input)))
- ((? store-path? item)
- item)))
- inputs)))
+ (let ((to-send (append (append-map derivation-input-output-paths
+ inputs)
+ sources)))
(mbegin %store-monad
- (built-derivations to-build)
+ (built-derivations inputs)
((store-lift send-files) to-send remote #:recursive? #t)
(return (close-connection remote))
(return (%remote-eval lowered session))))
- (let ((to-send (map (lambda (input)
- (match (gexp-input-thing input)
- ((? derivation? drv)
- (derivation-file-name drv))
- ((? store-path? item)
- item)))
- inputs)))
+ (let ((to-send (append (map (compose derivation-file-name
+ derivation-input-derivation)
+ inputs)
+ sources)))
(mbegin %store-monad
((store-lift send-files) to-send remote #:recursive? #t)
- (return (build-derivations remote to-build))
+ (return (build-derivations remote inputs))
(return (close-connection remote))
(return (%remote-eval lowered session)))))))
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)))))
diff --git a/guix/self.scm b/guix/self.scm
index 249705fcee..c2476e8d43 100644
--- a/guix/self.scm
+++ b/guix/self.scm
@@ -917,7 +917,7 @@ Info manual."
(package-name "GNU Guix")
(package-version "0")
(bug-report-address "bug-guix@gnu.org")
- (home-page-url "https://gnu.org/s/guix"))
+ (home-page-url "https://guix.gnu.org"))
;; Hack so that Geiser is not confused.
(define defmod 'define-module)