diff options
author | Ludovic Courtès <ludo@gnu.org> | 2019-07-17 15:51:10 +0200 |
---|---|---|
committer | Ludovic Courtès <ludo@gnu.org> | 2019-07-17 15:51:10 +0200 |
commit | 64de896a71a9ba3091259834077d54c0146bdab6 (patch) | |
tree | da58cc584fcc42a2b04f692aa3b1ada4c8949f5e /guix | |
parent | 5247aab8d6a18a4081ab7caeddb4fc083bca1f6b (diff) | |
parent | 6bfcb729268e0d20c6ae78224aef0eaad2ee2e74 (diff) | |
download | gnu-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.scm | 2 | ||||
-rw-r--r-- | guix/build-system/node.scm | 135 | ||||
-rw-r--r-- | guix/build/cargo-build-system.scm | 12 | ||||
-rw-r--r-- | guix/build/compile.scm | 32 | ||||
-rw-r--r-- | guix/build/json.scm | 387 | ||||
-rw-r--r-- | guix/build/node-build-system.scm | 166 | ||||
-rw-r--r-- | guix/build/syscalls.scm | 19 | ||||
-rw-r--r-- | guix/channels.scm | 94 | ||||
-rw-r--r-- | guix/derivations.scm | 65 | ||||
-rw-r--r-- | guix/download.scm | 3 | ||||
-rw-r--r-- | guix/gexp.scm | 92 | ||||
-rw-r--r-- | guix/lint.scm | 1231 | ||||
-rw-r--r-- | guix/remote.scm | 47 | ||||
-rw-r--r-- | guix/scripts/lint.scm | 1178 | ||||
-rw-r--r-- | guix/scripts/publish.scm | 2 | ||||
-rw-r--r-- | guix/self.scm | 2 |
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) |