From e429566fbb6af2b65a144cc06902432bc87b9eae Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 12 Jul 2019 22:38:03 +0200 Subject: build: Use '-Wshadowed-toplevel' only when supported. * guix/build/compile.scm (supported-warning-type?): New procedure. (%warnings): Remove 'unsupported-warning', though removing it doesn't make any difference. Define 'optional', and use it to determine whether to include 'shadowed-toplevel'. --- guix/build/compile.scm | 17 ++++++++++++++--- 1 file changed, 14 insertions(+), 3 deletions(-) (limited to 'guix') diff --git a/guix/build/compile.scm b/guix/build/compile.scm index c8fe273f7e..29865f2f2e 100644 --- a/guix/build/compile.scm +++ b/guix/build/compile.scm @@ -18,6 +18,7 @@ ;;; along with GNU Guix. If not, see . (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." -- cgit v1.2.3 From 53f21642729e4786141c072dd835b04cb85dfe28 Mon Sep 17 00:00:00 2001 From: Jan Nieuwenhuizen Date: Sat, 13 Jul 2019 16:31:50 +0200 Subject: channels: Add optional directory to channel metadata. * guix/channels.scm (): Add directory slot. Update users. (read-channel-metadata-from-source): New function. (standard-module-derivation): Use it. * doc/guix.texi (Package Modules in a Subdirectory): New subsection. --- doc/guix.texi | 13 ++++++++ guix/channels.scm | 93 +++++++++++++++++++++++++++++++------------------------ 2 files changed, 65 insertions(+), 41 deletions(-) (limited to 'guix') diff --git a/doc/guix.texi b/doc/guix.texi index 5a8ad7ebda..458fca20af 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -3921,6 +3921,19 @@ For the sake of reliability and maintainability, you should avoid dependencies on channels that you don't control, and you should aim to keep the number of dependencies to a minimum. +@cindex subdirectory, channels +@subsection Package Modules in a Sub-directory + +As a channel author, you may want to keep your channel modules in a +sub-directory. If your modules are in the sub-directory @file{guix}, you must +add a meta-data file @file{.guix-channel} that contains: + +@lisp +(channel + (version 0) + (directory "guix")) +@end lisp + @subsection Replicating Guix @cindex pinning, channels diff --git a/guix/channels.scm b/guix/channels.scm index e6bb9b891b..615ff14565 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 ;;; Copyright © 2018 Ricardo Wurmus +;;; Copyright © 2019 Jan (janneke) Nieuwenhuizen ;;; ;;; This file is part of GNU Guix. ;;; @@ -107,9 +108,10 @@ (checkout channel-instance-checkout)) (define-record-type - (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 '()) - (($ version dependencies) + (($ 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))) - - (gexp->derivation-in-inferior name build core)) + + (let* ((metadata (read-channel-metadata-from-source source)) + (directory (and=> metadata channel-metadata-directory))) + + (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 -- cgit v1.2.3 From 09a1f92f61d1ab11d2cf9f7a0983f4fc9f436f57 Mon Sep 17 00:00:00 2001 From: Jelle Licht Date: Tue, 23 Aug 2016 05:23:55 +0200 Subject: build: Add node-build-system. * guix/build/node-build-system.scm: New file. * guix/build-system/node.scm: New file. * guix/build/json.scm: New file. * doc/guix.texi: Document it. * Makefile.am: Added new files. Co-Authored-By: Julien Lepiller --- Makefile.am | 3 + doc/guix.texi | 11 ++ guix/build-system/node.scm | 135 ++++++++++++++ guix/build/json.scm | 387 +++++++++++++++++++++++++++++++++++++++ guix/build/node-build-system.scm | 166 +++++++++++++++++ 5 files changed, 702 insertions(+) create mode 100644 guix/build-system/node.scm create mode 100644 guix/build/json.scm create mode 100644 guix/build/node-build-system.scm (limited to 'guix') diff --git a/Makefile.am b/Makefile.am index 82eda6042a..9839bf27cc 100644 --- a/Makefile.am +++ b/Makefile.am @@ -125,6 +125,7 @@ MODULES = \ guix/build-system/guile.scm \ guix/build-system/haskell.scm \ guix/build-system/linux-module.scm \ + guix/build-system/node.scm \ guix/build-system/perl.scm \ guix/build-system/python.scm \ guix/build-system/ocaml.scm \ @@ -170,6 +171,7 @@ MODULES = \ guix/build/gnu-build-system.scm \ guix/build/gnu-dist.scm \ guix/build/guile-build-system.scm \ + guix/build/node-build-system.scm \ guix/build/perl-build-system.scm \ guix/build/python-build-system.scm \ guix/build/ocaml-build-system.scm \ @@ -182,6 +184,7 @@ MODULES = \ guix/build/haskell-build-system.scm \ guix/build/linux-module-build-system.scm \ guix/build/store-copy.scm \ + guix/build/json.scm \ guix/build/utils.scm \ guix/build/union.scm \ guix/build/profiles.scm \ diff --git a/doc/guix.texi b/doc/guix.texi index 458fca20af..6ed77fe267 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -6346,6 +6346,17 @@ the module (in the "arguments" form of a package using the linux-module-build-system, use the key #:linux to specify it). @end defvr +@defvr {Scheme Variable} node-build-system +This variable is exported by @code{(guix build-system node)}. It +implements the build procedure used by @uref{http://nodejs.org, +Node.js}, which implements an approximation of the @code{npm install} +command, followed by an @code{npm test} command. + +Which Node.js package is used to interpret the @code{npm} commands can +be specified with the @code{#:node} parameter which defaults to +@code{node}. +@end defvr + Lastly, for packages that do not need anything as sophisticated, a ``trivial'' build system is provided. It is trivial in the sense that it provides basically no support: it does not pull any implicit 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 +;;; +;;; 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 . + +(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/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 +;;; Copyright © 2016 Jelle Licht +;;; +;;; 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 . + +(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)) -- cgit v1.2.3 From 8eb0ba532ebbebef23180e666e0607ea735f9c1a Mon Sep 17 00:00:00 2001 From: Julien Lepiller Date: Sun, 14 Jul 2019 14:50:21 +0200 Subject: guix: node-build-system: Use guile-json instead of a custom parser. * guix/build/json.scm: Remove file. * Makefile.am: Remove it. * guix/build/node-build-system.scm: Use (json parser) instead of (guix build json). * guix/build-system/node.scm: Idem. --- Makefile.am | 1 - guix/build-system/node.scm | 10 +- guix/build/json.scm | 387 --------------------------------------- guix/build/node-build-system.scm | 28 +-- 4 files changed, 20 insertions(+), 406 deletions(-) delete mode 100644 guix/build/json.scm (limited to 'guix') diff --git a/Makefile.am b/Makefile.am index 9839bf27cc..38f2d7e690 100644 --- a/Makefile.am +++ b/Makefile.am @@ -184,7 +184,6 @@ MODULES = \ guix/build/haskell-build-system.scm \ guix/build/linux-module-build-system.scm \ guix/build/store-copy.scm \ - guix/build/json.scm \ guix/build/utils.scm \ guix/build/union.scm \ guix/build/profiles.scm \ diff --git a/guix/build-system/node.scm b/guix/build-system/node.scm index 05c24c47d5..dad492dc95 100644 --- a/guix/build-system/node.scm +++ b/guix/build-system/node.scm @@ -18,7 +18,6 @@ (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) @@ -27,6 +26,7 @@ #:use-module (guix build-system) #:use-module (guix build-system gnu) #:use-module (ice-9 match) + #:use-module (json parser) #:export (npm-meta-uri %node-build-system-modules node-build @@ -40,8 +40,8 @@ registry." (define %node-build-system-modules ;; Build-side modules imported by default. `((guix build node-build-system) - (guix build json) (guix build union) + (json parser) ,@%gnu-build-system-modules)) ;; TODO: Might be not needed (define (default-node) @@ -88,9 +88,9 @@ registry." (guile #f) (imported-modules %node-build-system-modules) (modules '((guix build node-build-system) - (guix build json) - (guix build union) - (guix build utils)))) + (guix build union) + (guix build utils) + (json parser)))) "Build SOURCE using NODE and INPUTS." (define builder `(begin diff --git a/guix/build/json.scm b/guix/build/json.scm deleted file mode 100644 index 361ea76728..0000000000 --- a/guix/build/json.scm +++ /dev/null @@ -1,387 +0,0 @@ -;;;; 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 index 3c0ac2a12b..231e60488a 100644 --- a/guix/build/node-build-system.scm +++ b/guix/build/node-build-system.scm @@ -19,12 +19,12 @@ (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 (json parser) #:use-module (srfi srfi-1) #:use-module (srfi srfi-26) #:export (%standard-phases @@ -39,12 +39,12 @@ (define* (read-package-data #:key (filename "package.json")) (call-with-input-file filename (lambda (port) - (read-json port)))) + (json->scm 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"))) + (scripts (hash-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 @@ -103,13 +103,15 @@ the @file{bin} directory." (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) + (modulename (hash-ref data "name")) + (binary-configuration (match (hash-ref data "bin") + ((? hash-table? hash-table) + (hash-map->list cons hash-table)) + ((? string? configuration) configuration) + (#f #f))) + (dependencies (match (hash-ref data "dependencies") + ((? hash-table? hash-table) + (hash-map->list cons hash-table)) (#f #f)))) (mkdir-p target) (copy-recursively "." (string-append target "/node_modules/" modulename)) @@ -121,7 +123,7 @@ the @file{bin} directory." (begin (mkdir-p binaries) (symlink (string-append target "/node_modules/" modulename "/" - binary-configuration) + binary-configuration) (string-append binaries "/" modulename)))) ((list? binary-configuration) (for-each @@ -131,12 +133,12 @@ the @file{bin} directory." (begin (mkdir-p (dirname (string-append binaries "/" key))) (symlink (string-append target "/node_modules/" modulename "/" - value) + value) (string-append binaries "/" key)))))) binary-configuration)) (else (symlink (string-append target "/node_modules/" modulename "/bin") - binaries))) + binaries))) (when dependencies (mkdir-p (string-append target "/node_modules/" modulename "/node_modules")) -- cgit v1.2.3 From a4bb18921099b2ec8c1699e08a73ca0fa78d0486 Mon Sep 17 00:00:00 2001 From: Julien Lepiller Date: Sun, 14 Jul 2019 20:16:19 +0200 Subject: Revert "guix: node-build-system: Use guile-json instead of a custom parser." MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit The effect of this change was to import the (json parser) from the host side into the build side. The solution here would be to do the equivalent of ‘with-extensions’ for gexps. Since we don't use gexps for build systems just yet, revert this for now. This reverts commit 8eb0ba532ebbebef23180e666e0607ea735f9c1a. --- Makefile.am | 1 + guix/build-system/node.scm | 10 +- guix/build/json.scm | 387 +++++++++++++++++++++++++++++++++++++++ guix/build/node-build-system.scm | 28 ++- 4 files changed, 406 insertions(+), 20 deletions(-) create mode 100644 guix/build/json.scm (limited to 'guix') diff --git a/Makefile.am b/Makefile.am index 38f2d7e690..9839bf27cc 100644 --- a/Makefile.am +++ b/Makefile.am @@ -184,6 +184,7 @@ MODULES = \ guix/build/haskell-build-system.scm \ guix/build/linux-module-build-system.scm \ guix/build/store-copy.scm \ + guix/build/json.scm \ guix/build/utils.scm \ guix/build/union.scm \ guix/build/profiles.scm \ diff --git a/guix/build-system/node.scm b/guix/build-system/node.scm index dad492dc95..05c24c47d5 100644 --- a/guix/build-system/node.scm +++ b/guix/build-system/node.scm @@ -18,6 +18,7 @@ (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) @@ -26,7 +27,6 @@ #:use-module (guix build-system) #:use-module (guix build-system gnu) #:use-module (ice-9 match) - #:use-module (json parser) #:export (npm-meta-uri %node-build-system-modules node-build @@ -40,8 +40,8 @@ registry." (define %node-build-system-modules ;; Build-side modules imported by default. `((guix build node-build-system) + (guix build json) (guix build union) - (json parser) ,@%gnu-build-system-modules)) ;; TODO: Might be not needed (define (default-node) @@ -88,9 +88,9 @@ registry." (guile #f) (imported-modules %node-build-system-modules) (modules '((guix build node-build-system) - (guix build union) - (guix build utils) - (json parser)))) + (guix build json) + (guix build union) + (guix build utils)))) "Build SOURCE using NODE and INPUTS." (define builder `(begin 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 index 231e60488a..3c0ac2a12b 100644 --- a/guix/build/node-build-system.scm +++ b/guix/build/node-build-system.scm @@ -19,12 +19,12 @@ (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 (json parser) #:use-module (srfi srfi-1) #:use-module (srfi srfi-26) #:export (%standard-phases @@ -39,12 +39,12 @@ (define* (read-package-data #:key (filename "package.json")) (call-with-input-file filename (lambda (port) - (json->scm 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 (hash-ref package-data "scripts"))) + (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 @@ -103,15 +103,13 @@ the @file{bin} directory." (target (string-append out "/lib")) (binaries (string-append out "/bin")) (data (read-package-data)) - (modulename (hash-ref data "name")) - (binary-configuration (match (hash-ref data "bin") - ((? hash-table? hash-table) - (hash-map->list cons hash-table)) - ((? string? configuration) configuration) - (#f #f))) - (dependencies (match (hash-ref data "dependencies") - ((? hash-table? hash-table) - (hash-map->list cons hash-table)) + (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)) @@ -123,7 +121,7 @@ the @file{bin} directory." (begin (mkdir-p binaries) (symlink (string-append target "/node_modules/" modulename "/" - binary-configuration) + binary-configuration) (string-append binaries "/" modulename)))) ((list? binary-configuration) (for-each @@ -133,12 +131,12 @@ the @file{bin} directory." (begin (mkdir-p (dirname (string-append binaries "/" key))) (symlink (string-append target "/node_modules/" modulename "/" - value) + value) (string-append binaries "/" key)))))) binary-configuration)) (else (symlink (string-append target "/node_modules/" modulename "/bin") - binaries))) + binaries))) (when dependencies (mkdir-p (string-append target "/node_modules/" modulename "/node_modules")) -- cgit v1.2.3 From 38302bd9392cc9518b04e2726cf6a38ee75922cc Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sun, 14 Jul 2019 17:07:09 +0200 Subject: compile: Report the name of the file that cannot be compiled. Fixes . Reported by Robert Vollmert . * guix/build/compile.scm (call/exit-on-exception): Add 'file' parameter and honor it. (exit-on-exception): Likewise. (compile-files): Pass FILE to 'exit-on-exception'. --- guix/build/compile.scm | 15 ++++++++++----- 1 file changed, 10 insertions(+), 5 deletions(-) (limited to 'guix') diff --git a/guix/build/compile.scm b/guix/build/compile.scm index 29865f2f2e..c127456fd0 100644 --- a/guix/build/compile.scm +++ b/guix/build/compile.scm @@ -129,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) @@ -141,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 @@ -173,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))) -- cgit v1.2.3 From 456c7ade095cce96f47389c37a4fe3b0390047fd Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 15 Jul 2019 09:56:27 +0200 Subject: syscalls: Use 'define-as-needed' for 'AT_' constants introduced in Guile 2.2.5. * guix/build/syscalls.scm (AT_FDCWD, AT_SYMLINK_NOFOLLOW, AT_REMOVEDIR) (AT_SYMLINK_FOLLOW, AT_NO_AUTOMOUNT, AT_EMPTY_PATH): Define using 'define-as-needed'. --- guix/build/syscalls.scm | 19 ++++++------------- 1 file changed, 6 insertions(+), 13 deletions(-) (limited to 'guix') 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 . -(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 ; (identifier-syntax #x125F)) -- cgit v1.2.3 From 4daf89d619be788cf5a71867ad674cd5ff6e31fe Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 8 Jul 2019 18:39:20 +0200 Subject: derivations: 'derivation' primitive accepts and #:sources. This brings us closer to the data type. * guix/derivations.scm (derivation): Add #:sources parameter. [input->derivation-input]: Add clause for 'derivation-input?'. Honor SOURCES. --- guix/derivations.scm | 8 ++++++-- 1 file changed, 6 insertions(+), 2 deletions(-) (limited to 'guix') diff --git a/guix/derivations.scm b/guix/derivations.scm index 731f1f698f..bd0af320c4 100644 --- a/guix/derivations.scm +++ b/guix/derivations.scm @@ -708,7 +708,8 @@ name of each input with that input's hash." (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 @@ -833,6 +834,8 @@ derivation. It is kept as-is, uninterpreted, in the derivation." (define input->derivation-input (match-lambda + ((? derivation-input? input) + input) (((? derivation? drv)) (make-derivation-input drv '("out"))) (((? derivation? drv) sub-drvs ...) @@ -858,7 +861,8 @@ derivation. It is kept as-is, uninterpreted, in the derivation." hash recursive?))) (sort outputs stringsource inputs)) + (append (filter-map input->source inputs) + sources)) stringderivation-input inputs)) -- cgit v1.2.3 From 386857748097619b3b75a7bf93677b6aa742d03c Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 9 Jul 2019 23:05:01 +0200 Subject: gexp: separates sources from derivation inputs. * guix/gexp.scm (lower-inputs): Return either records or store items. (lower-reference-graphs): Return file/input pairs. ()[sources]: New field. (lower-gexp): Adjust accordingly. (gexp->input-tuple): Remove. (gexp->derivation)[graphs-file-names]: Handle only the 'derivation-input?' and 'string?' cases. Pass #:sources to 'raw-derivation'; ensure #:inputs contains only records. * guix/remote.scm (remote-eval): Adjust to the new interface. * tests/gexp.scm ("lower-gexp"): Adjust to expect records instead of --- guix/gexp.scm | 86 ++++++++++++++++++++++++++++++--------------------------- guix/remote.scm | 36 ++++++++---------------- tests/gexp.scm | 5 ++-- 3 files changed, 60 insertions(+), 67 deletions(-) (limited to 'guix') diff --git a/guix/gexp.scm b/guix/gexp.scm index ce48d8d001..52643bd684 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 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,11 +641,13 @@ 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 and . (define-record-type - (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 + (inputs lowered-gexp-inputs) ;list of + (sources lowered-gexp-sources) ;list of store items (guile lowered-gexp-guile) ; | #f (load-path lowered-gexp-load-path) ;list of store items (load-compiled-path lowered-gexp-load-compiled-path)) ;list of store items @@ -740,26 +746,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) + ,@(map derivation-input exts) + ,@(filter derivation-input? inputs)) + (filter string? (cons modules inputs)) guile load-path load-compiled-path))))) -(define (gexp-input->tuple input) - "Given INPUT, a 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) @@ -830,13 +829,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) @@ -906,13 +902,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 `(,(derivation-input guile '("out")) + ,@(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/remote.scm b/guix/remote.scm index e503c76167..52ced16871 100644 --- a/guix/remote.scm +++ b/guix/remote.scm @@ -95,40 +95,26 @@ remote store." (remote -> (connect-to-remote-daemon session socket-name))) (define inputs - (cons (gexp-input (lowered-gexp-guile lowered)) + (cons (derivation-input (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 (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/tests/gexp.scm b/tests/gexp.scm index 23904fce2e..a1f79e3435 100644 --- a/tests/gexp.scm +++ b/tests/gexp.scm @@ -849,8 +849,9 @@ #:effective-version "2.0"))) (define (matching-input drv output) (lambda (input) - (and (eq? (gexp-input-thing input) drv) - (string=? (gexp-input-output input) output)))) + (and (eq? (derivation-input-derivation input) drv) + (equal? (derivation-input-sub-derivations input) + (list output))))) (mbegin %store-monad (return (and (find (matching-input extension-drv "out") -- cgit v1.2.3 From 02237f13ee0a423dce04f14538e9f765b8dc15da Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 9 Jul 2019 23:22:48 +0200 Subject: download: Use the new 'derivation' calling convention. * guix/download.scm (built-in-download): Pass MIRRORS and CONTENT-ADDRESSED-MIRRORS as #:sources, not #:inputs. --- guix/download.scm | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) (limited to 'guix') diff --git a/guix/download.scm b/guix/download.scm index fe680be4a2..b24aaa0a86 100644 --- a/guix/download.scm +++ b/guix/download.scm @@ -432,8 +432,7 @@ download by itself using its own dependencies." #:system system #:hash-algo hash-algo #:hash hash - #: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" -- cgit v1.2.3 From d1458321518b07dec045deddc2e635c1a69b9e93 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 9 Jul 2019 23:51:44 +0200 Subject: derivations: 'map-derivation' uses the new 'derivation' calling convention. * guix/derivations.scm (map-derivation)[input->output-paths]: Adjust to deal with an argument that's either 'derivation-input?' or a string. [rewritten-input]: Return a or a string. Pass #:inputs and #:sources to 'derivation'. --- guix/derivations.scm | 22 ++++++++++------------ 1 file changed, 10 insertions(+), 12 deletions(-) (limited to 'guix') diff --git a/guix/derivations.scm b/guix/derivations.scm index bd0af320c4..a18478502d 100644 --- a/guix/derivations.scm +++ b/guix/derivations.scm @@ -933,13 +933,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 @@ -958,11 +955,11 @@ recursively." (($ 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) @@ -1001,7 +998,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) ((($ _ algo hash)) -- cgit v1.2.3 From 93c2a0073945e8c3967cdb0e250d3341f7dcac71 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 10 Jul 2019 18:18:19 +0200 Subject: derivations: Deprecate the previous calling convention. We will eventually require #:inputs to be a list of ; store items will have to be passed as #:sources, already interned. * guix/derivations.scm (warn-about-derivation-deprecation): New procedure. (derivation): Add #:%deprecation-warning? parameter. [warn-deprecation]: New macro. [input->derivation-input, input->source]: Use it. (build-expression->derivation): Pass #:%deprecation-warning?. * po/guix/POTFILES.in: Add guix/derivations.scm. --- guix/derivations.scm | 27 +++++++++++++++++++++++++-- po/guix/POTFILES.in | 1 + 2 files changed, 26 insertions(+), 2 deletions(-) (limited to 'guix') diff --git a/guix/derivations.scm b/guix/derivations.scm index a18478502d..23d058e832 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) @@ -705,6 +707,13 @@ 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 '()) @@ -715,7 +724,8 @@ name of each input with that input's hash." 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 object. When HASH and HASH-ALGO are given, a fixed-output derivation is created---i.e., one whose result is known in @@ -832,19 +842,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) @@ -1320,6 +1339,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/po/guix/POTFILES.in b/po/guix/POTFILES.in index f5fc4956b4..ad06ebce95 100644 --- a/po/guix/POTFILES.in +++ b/po/guix/POTFILES.in @@ -80,6 +80,7 @@ guix/channels.scm guix/profiles.scm guix/git.scm guix/deprecation.scm +guix/derivations.scm gnu/build/bootloader.scm nix/nix-daemon/guix-daemon.cc -- cgit v1.2.3 From b9373e262730578ba6c3805ffe44900f10bc655c Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 10 Jul 2019 18:39:25 +0200 Subject: gexp: 'lowered-gexp-guile' now returns a . * guix/derivations.scm (derivation-input-output-path): New procedure. * guix/gexp.scm (lower-gexp): Wrap GUILE in a . (gexp->derivation): Adjust accordingly. * guix/remote.scm (remote-pipe-for-gexp, remote-eval): Adjust accordingly. * tests/gexp.scm ("lower-gexp"): Adjust accordingly. --- guix/derivations.scm | 8 ++++++++ guix/gexp.scm | 8 ++++---- guix/remote.scm | 4 ++-- tests/gexp.scm | 3 ++- 4 files changed, 16 insertions(+), 7 deletions(-) (limited to 'guix') diff --git a/guix/derivations.scm b/guix/derivations.scm index 23d058e832..92d50503ce 100644 --- a/guix/derivations.scm +++ b/guix/derivations.scm @@ -71,6 +71,7 @@ derivation-input-derivation derivation-input-sub-derivations derivation-input-output-paths + derivation-input-output-path valid-derivation-input? &derivation-error @@ -221,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 + (($ 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." diff --git a/guix/gexp.scm b/guix/gexp.scm index 52643bd684..eef308b000 100644 --- a/guix/gexp.scm +++ b/guix/gexp.scm @@ -648,7 +648,7 @@ names and file names suitable for the #:allowed-references argument to (sexp lowered-gexp-sexp) ;sexp (inputs lowered-gexp-inputs) ;list of (sources lowered-gexp-sources) ;list of store items - (guile lowered-gexp-guile) ; | #f + (guile lowered-gexp-guile) ; | #f (load-path lowered-gexp-load-path) ;list of store items (load-compiled-path lowered-gexp-load-compiled-path)) ;list of store items @@ -755,7 +755,7 @@ derivations--e.g., code evaluated for its side effects." ,@(map derivation-input exts) ,@(filter derivation-input? inputs)) (filter string? (cons modules inputs)) - guile + (derivation-input guile '("out")) load-path load-compiled-path))))) @@ -889,7 +889,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) @@ -902,7 +902,7 @@ The other arguments are as for 'derivation'." #:outputs outputs #:env-vars env-vars #:system system - #:inputs `(,(derivation-input guile '("out")) + #:inputs `(,guile ,@(lowered-gexp-inputs lowered) ,@(match graphs (((_ . inputs) ...) diff --git a/guix/remote.scm b/guix/remote.scm index 52ced16871..d49ee91b38 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" @@ -95,7 +95,7 @@ remote store." (remote -> (connect-to-remote-daemon session socket-name))) (define inputs - (cons (derivation-input (lowered-gexp-guile lowered)) + (cons (lowered-gexp-guile lowered) (lowered-gexp-inputs lowered))) (define sources diff --git a/tests/gexp.scm b/tests/gexp.scm index a1f79e3435..460afe7f59 100644 --- a/tests/gexp.scm +++ b/tests/gexp.scm @@ -868,7 +868,8 @@ "/lib/guile/2.0/site-ccache") (lowered-gexp-load-compiled-path lexp)) (= 2 (length (lowered-gexp-load-compiled-path lexp))) - (eq? (lowered-gexp-guile lexp) (%guile-for-build))))))) + (eq? (derivation-input-derivation (lowered-gexp-guile lexp)) + (%guile-for-build))))))) (test-assertm "gexp->derivation #:references-graphs" (mlet* %store-monad -- cgit v1.2.3 From 9af75a26308475f5fc9cf1c13bb0374b5a3345a6 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 10 Jul 2019 18:51:56 +0200 Subject: channels: Avoid use of 'derivation-input-path'. * guix/channels.scm (old-style-guix?): Use 'derivation-name' rather than 'derivation-input-path'. --- guix/channels.scm | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) (limited to 'guix') diff --git a/guix/channels.scm b/guix/channels.scm index 615ff14565..bfe6963418 100644 --- a/guix/channels.scm +++ b/guix/channels.scm @@ -435,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) -- cgit v1.2.3 From 5db07b971d5729d349152a4d7ddab80a235ac0a0 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 15 Jul 2019 16:02:44 +0200 Subject: remote: Fix type error in the list of store items to send. Fixes a regression introduced in 386857748097619b3b75a7bf93677b6aa742d03c. * guix/remote.scm (remote-eval): Use 'append-map', not 'map', for 'derivation-input-output-paths'. --- guix/remote.scm | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/remote.scm b/guix/remote.scm index d49ee91b38..0959025963 100644 --- a/guix/remote.scm +++ b/guix/remote.scm @@ -102,7 +102,8 @@ remote store." (lowered-gexp-sources lowered)) (if build-locally? - (let ((to-send (append (map derivation-input-output-paths inputs) + (let ((to-send (append (append-map derivation-input-output-paths + inputs) sources))) (mbegin %store-monad (built-derivations inputs) -- cgit v1.2.3 From 6f8eb9f1d8bc8660349658602698db36965bba5d Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 15 Jul 2019 17:58:01 +0200 Subject: remote: Make sure the user doesn't mess up with the REPL protocol. Reported by zerodaysfordays@sdf.lonestar.org (Jakob L. Kreuze). * guix/remote.scm (trampoline): Wrap 'primitive-load' in 'with-output-to-port'. --- guix/remote.scm | 8 +++++++- 1 file changed, 7 insertions(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/remote.scm b/guix/remote.scm index 0959025963..5fecd954e9 100644 --- a/guix/remote.scm +++ b/guix/remote.scm @@ -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 -- cgit v1.2.3 From 50fc2384feb3bb2677d074f8f0deb5ae3c56b4d8 Mon Sep 17 00:00:00 2001 From: Christopher Baines Date: Mon, 6 May 2019 19:00:58 +0100 Subject: scripts: lint: Handle warnings with a record type. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Rather than emiting warnings directly to a port, have the checkers return the warning or warnings. This makes it easier to use the warnings in different ways, for example, loading the data in to a database, as you can work with the records directly, rather than having to parse the output to determine the package and location. * guix/scripts/lint.scm (): New record type. (lint-warning): New macro. (lint-warning?, lint-warning-package, lint-warning-message, lint-warning-location, package-file, make-warning): New procedures. (call-with-accumulated-warnings, with-accumulated-warnings): Remove. (emit-warning): Rename to emit-warnings, and switch to displaying multiple warnings. (check-description-style)[check-not-empty-description, check-texinfo-markup, check-trademarks, check-quotes, check-proper-start, check-end-of-sentence-space]: Switch to generating a list of warnings, and using make-warning, rather than emit-warning. (check-inputs-should-be-native, check-inputs-should-not-be-an-input-at-all): Switch to generating a list of warnings, and using make-warning, rather than emit-warning. (check-synopsis): Switch to generating a list of warnings, and using make-warning, rather than emit-warning. [check-not-empty]: Remove, this is handled in the match clause to avoid other warnings being emitted. [check-final-period, check-start-article, check-synopsis-length, check-proper-start, check-start-with-package-name, check-texinfo-markup]: Switch to generating a list of warnings, and using make-warning, rather than emit-warning. [checks]: Remove check-not-empty. (validate-uri, check-home-page, check-patch-file-names, check-gnu-synopsis+description): Switch to generating a list of warnings, and using make-warning, rather than emit-warning. (check-source): Switch to generating a list of warnings, and using make-warning, rather than emit-warning. [try-uris]: Remove. [warnings-for-uris]: New procedure, replacing try-uris. (check-source-file-name, check-source-unstable-tarball, check-mirror-url, check-github-url, check-derivation, check-vulnerabilities, check-for-updates, report-tabulations, report-trailing-white-space, report-long-line, report-lone-parentheses, report-formatting-issues, check-formatting): Switch to generating a list of warnings, and using make-warning, rather than emit-warning. (run-checkers): Call emit-warnings on the warnings returned from the checker. * tests/lint.scm (string-match-or-error, single-lint-warning-message): New procedures. (call-with-warnings, with-warnings): Remove. ("description: not a string", "description: not empty", "description: invalid Texinfo markup", "description: does not start with an upper-case letter", "description: may start with a digit", "description: may start with lower-case package name", "description: two spaces after end of sentence", "description: end-of-sentence detection with abbreviations", "description: may not contain trademark signs: ™", "description: may not contain trademark signs: ®", "description: suggest ornament instead of quotes", "synopsis: not a string", "synopsis: not empty", "synopsis: valid Texinfo markup", "synopsis: does not start with an upper-case letter", "synopsis: may start with a digit", "synopsis: ends with a period", "synopsis: ends with 'etc.'", "synopsis: starts with 'A'", "synopsis: starts with 'a'", "synopsis: starts with 'an'", "synopsis: too long", "synopsis: start with package name", "synopsis: start with package name prefix", "synopsis: start with abbreviation", "inputs: pkg-config is probably a native input", "inputs: glib:bin is probably a native input", "inputs: python-setuptools should not be an input at all (input)", "inputs: python-setuptools should not be an input at all (native-input)", "inputs: python-setuptools should not be an input at all (propagated-input)", "patches: file names", "patches: file name too long", "patches: not found", "derivation: invalid arguments", "license: invalid license", "home-page: wrong home-page", "home-page: invalid URI", "home-page: host not found", "home-page: Connection refused", "home-page: 200", "home-page: 200 but short length", "home-page: 404", "home-page: 301, invalid", "home-page: 301 -> 200", "home-page: 301 -> 404", "source-file-name", "source-file-name: v prefix", "source-file-name: bad checkout", "source-file-name: good checkout", "source-file-name: valid", "source-unstable-tarball", "source-unstable-tarball: source #f", "source-unstable-tarball: valid", "source-unstable-tarball: package named archive", "source-unstable-tarball: not-github", "source-unstable-tarball: git-fetch", "source: 200", "source: 200 but short length", "source: 404", "source: 301 -> 200", "source: 301 -> 404", "mirror-url", "mirror-url: one suggestion", "github-url", "github-url: one suggestion", "github-url: already the correct github url", "cve", "cve: one vulnerability", "cve: one patched vulnerability", "cve: known safe from vulnerability", "cve: vulnerability fixed in replacement version", "cve: patched vulnerability in replacement", "formatting: lonely parentheses", "formatting: alright"): Change test-assert to test-equal, and adjust to work with the changes above. ("formatting: tabulation", "formatting: trailing white space", "formatting: long line"): Use string-match-or-error rather than string-contains. --- guix/scripts/lint.scm | 757 ++++++++++++++------------ tests/lint.scm | 1453 +++++++++++++++++++++++-------------------------- 2 files changed, 1102 insertions(+), 1108 deletions(-) (limited to 'guix') diff --git a/guix/scripts/lint.scm b/guix/scripts/lint.scm index dc338a1d7b..1b08068669 100644 --- a/guix/scripts/lint.scm +++ b/guix/scripts/lint.scm @@ -84,6 +84,12 @@ check-formatting run-checkers + lint-warning + lint-warning? + lint-warning-package + lint-warning-message + lint-warning-location + %checkers lint-checker lint-checker? @@ -93,42 +99,48 @@ ;;; -;;; Helpers +;;; Warnings ;;; -(define* (emit-warning package message #:optional field) + +(define-record-type* + lint-warning make-lint-warning + lint-warning? + (package lint-warning-package) + (message lint-warning-message) + (location lint-warning-location + (default #f))) + +(define (package-file package) + (location-file + (package-location package))) + +(define* (make-warning package message + #:key field location) + (make-lint-warning + package + message + (or location + (package-field-location package field) + (package-location package)))) + +(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 ...))) + (for-each + (match-lambda + (($ package message loc) + (format (guix-warning-port) "~a: ~a@~a: ~a~%" + (location->string loc) + (package-name package) (package-version package) + message))) + warnings)) ;;; ;;; Checkers ;;; + (define-record-type* lint-checker make-lint-checker lint-checker? @@ -163,10 +175,12 @@ monad." (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))) + (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 @@ -174,39 +188,44 @@ 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 + (make-warning package (G_ "Texinfo markup in description is invalid") - 'description) - #f))) + #: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) - (emit-warning package - (format #f (G_ "description should not contain ~ + (list + (make-warning package + (format #f (G_ "description should not contain ~ trademark sign '~a' at ~d") - (string-ref description index) index) - 'description)) - (else #t))) + (string-ref description index) index) + #:field 'description))) + (else '()))) (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))) + (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) - (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))) + (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." @@ -219,28 +238,33 @@ trademark sign '~a' at ~d") (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 ~ + (if (null? infractions) + '() + (list + (make-warning package + (format #f (G_ "sentences in description should be followed ~ by two spaces; possible infraction~p at ~{~a~^, ~}") - (length infractions) - infractions) - 'description)))) + (length infractions) + infractions) + #:field '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)))) + (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 + (format #f (G_ "invalid description: ~s") description) + #:field 'description))))) (define (package-input-intersection inputs-to-check input-names) "Return the intersection between INPUTS-TO-CHECK, the list of input tuples @@ -281,13 +305,13 @@ of a package, and INPUT-NAMES, a list of package specifications such as "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)))) + (map (lambda (input) + (make-warning + package + (format #f (G_ "'~a' should probably be a native input") + 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 @@ -296,14 +320,15 @@ of a package, and INPUT-NAMES, a list of package specifications such as "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)))) + (map (lambda (input) + (make-warning + package + (format #f + (G_ "'~a' should probably not be an input at all") + 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 @@ -314,66 +339,71 @@ line." (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))) + (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 ;; . (if (false-if-exception (gnu-package? package)) - (const #t) + (const '()) (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 \ + (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") - 'synopsis))))) + #:field 'synopsis)) + '())))) (define (check-synopsis-length synopsis) - (when (>= (string-length synopsis) 80) - (emit-warning package - (G_ "synopsis should be less than 80 characters long") - '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) - (unless (properly-starts-sentence? synopsis) - (emit-warning package - (G_ "synopsis should start with an upper-case letter or digit") - '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) - (when (and (regexp-exec (package-name-regexp package) synopsis) + (if (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))) + (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 () + (texi->plain-text synopsis) + '()) (lambda (keys . args) - (emit-warning package - (G_ "Texinfo markup in synopsis is invalid") - 'synopsis) - #f))) + (list + (make-warning package + (G_ "Texinfo markup in synopsis is invalid") + #:field 'synopsis))))) (define checks - (list check-not-empty - check-proper-start + (list check-proper-start check-final-period check-start-article check-start-with-package-name @@ -381,13 +411,20 @@ markup is valid return a plain-text version of SYNOPSIS, otherwise #f." check-texinfo-markup)) (match (package-synopsis package) + ("" + (list + (make-warning package + (G_ "synopsis should not be empty") + #:field 'synopsis))) ((? string? synopsis) - (for-each (lambda (proc) - (proc synopsis)) - checks)) + (append-map + (lambda (proc) + (proc synopsis)) + checks)) (invalid - (emit-warning package (format #f (G_ "invalid synopsis: ~s") invalid) - 'synopsis)))) + (list + (make-warning package (format #f (G_ "invalid synopsis: ~s") invalid) + #:field 'synopsis))))) (define* (probe-uri uri #:key timeout) "Probe URI, a URI object, and return two values: a symbol denoting the @@ -489,8 +526,8 @@ for connections to complete; when TIMEOUT is #f, wait as long as needed." '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." + "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 @@ -502,71 +539,66 @@ warning for PACKAGE mentionning the FIELD." ;; 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 \ + (make-warning package + (format #f + (G_ "URI ~a returned \ suspiciously small file (~a bytes)") - (uri->string uri) - length)) - #f))) + (uri->string uri) + length) + #:field field))) (_ #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 \ + (make-warning package + (format #f (G_ "permanent redirect from ~a to ~a") + (uri->string uri) + (uri->string + (response-location argument))) + #:field field) + (make-warning package + (format #f (G_ "invalid permanent redirect \ from ~a") - (uri->string uri))) - #f))) + (uri->string uri)) + #:field field))) (else - (emit-warning package + (make-warning package (format #f (G_ "URI ~a not reachable: ~a (~s)") (uri->string uri) (response-code argument) (response-reason-phrase argument)) - field) - #f))) + #:field field)))) ((ftp-response) (match argument (('ok) #t) (('error port command code message) - (emit-warning package + (make-warning package (format #f (G_ "URI ~a not reachable: ~a (~s)") (uri->string uri) - code (string-trim-both message))) - #f))) + code (string-trim-both message)) + #:field field)))) ((getaddrinfo-error) - (emit-warning package + (make-warning package (format #f (G_ "URI ~a domain not found: ~a") (uri->string uri) (gai-strerror (car argument))) - field) - #f) + #:field field)) ((system-error) - (emit-warning package + (make-warning package (format #f (G_ "URI ~a unreachable: ~a") (uri->string uri) (strerror (system-error-errno (cons status argument)))) - field) - #f) + #:field field)) ((tls-certificate-error) - (emit-warning package + (make-warning package (format #f (G_ "TLS certificate error: ~a") - (tls-certificate-error-string argument)))) + (tls-certificate-error-string argument)) + #:field field)) ((invalid-http-response gnutls-error) ;; Probably a misbehaving server; ignore. #f) @@ -581,17 +613,23 @@ from ~a") (let ((uri (and=> (package-home-page package) string->uri))) (cond ((uri? uri) - (validate-uri uri package 'home-page)) + (match (validate-uri uri package 'home-page) + ((and (? lint-warning? warning) warning) + (list warning)) + (_ '()))) ((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))) + (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 - (emit-warning package (format #f (G_ "invalid home page URL: ~s") - (package-home-page package)) - 'home-page))))) + (list + (make-warning package (format #f (G_ "invalid home page URL: ~s") + (package-home-page package)) + #:field 'home-page)))))) (define %distro-directory (mlambda () @@ -601,42 +639,47 @@ from ~a") "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))) + (list + (make-warning package (condition-message c) + #:field '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 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 + (append + (if (every (match-lambda ;patch starts with package name? ((? 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)))) + (and=> (string-contains (basename patch) + (package-name package)) + zero?)) + (_ #f)) ;must be an 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 + (format #f (G_ "~a: file name is too long") + (basename patch)) + #:field 'patch-file-names) + #f)) + (_ #f)) + patches))))) (define (escape-quotes str) "Replace any quote character in STR by an escaped quote character." @@ -663,32 +706,35 @@ descriptions maintained upstream." (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))))))) + (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 + (format #f (G_ "proposed synopsis: ~s~%") + 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 + (format #f + (G_ "proposed description:~% \"~a\"~%") + (fill-paragraph (escape-quotes upstream) 77 7)) + #:field 'description)) + '())))))) (define (origin-uris origin) "Return the list of URIs (strings) for ORIGIN." @@ -701,38 +747,35 @@ descriptions maintained upstream." (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)) - '())) + (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))) - (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))))))))) + (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." @@ -748,27 +791,32 @@ descriptions maintained upstream." (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)))) + (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) - (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))) + (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))) - (when (and (origin? origin) - (eqv? (origin-method origin) url-fetch)) - (let ((uris (origin-uris origin))) - (for-each check-source-uri uris))))) + (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://'." @@ -776,24 +824,25 @@ descriptions maintained upstream." (let loop ((mirrors %mirrors)) (match mirrors (() - #t) + #f) (((mirror-id mirror-urls ...) rest ...) (match (find (cut string-prefix? <> uri) mirror-urls) (#f (loop rest)) (prefix - (emit-warning package + (make-warning package (format #f (G_ "URL should be \ 'mirror://~a/~a'") mirror-id (string-drop uri (string-length prefix))) - 'source))))))) + #:field '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))))) + (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." @@ -817,18 +866,20 @@ descriptions maintained upstream." (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))))) + (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 + (format #f (G_ "URL should be '~a'") github-uri) + #:field 'source))))) + (origin-uris origin)) + '()))) (define (check-derivation package) "Emit a warning if we fail to compile PACKAGE to a derivation." @@ -836,12 +887,12 @@ descriptions maintained upstream." (catch #t (lambda () (guard (c ((store-protocol-error? c) - (emit-warning package + (make-warning package (format #f (G_ "failed to create ~a derivation: ~a") system (store-protocol-error-message c)))) ((message-condition? c) - (emit-warning package + (make-warning package (format #f (G_ "failed to create ~a derivation: ~a") system (condition-message c))))) @@ -858,21 +909,23 @@ descriptions maintained upstream." (package-derivation store replacement system #:graft? #f))))))) (lambda args - (emit-warning package + (make-warning package (format #f (G_ "failed to create ~a derivation: ~s") system args))))) - (for-each try (package-supported-systems package))) + (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?) ...)) - #t) + '()) (x - (emit-warning package (G_ "invalid license field") - 'license)))) + (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, @@ -932,7 +985,7 @@ the NIST server non-fatal." (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) @@ -943,11 +996,14 @@ the NIST server non-fatal." (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) - ", "))))))))) + (if (null? unpatched) + '() + (list + (make-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." @@ -957,12 +1013,15 @@ the NIST server non-fatal." #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 + (if (version>? (upstream-source-version source) + (package-version package)) + (list + (make-warning package + (format #f (G_ "can be upgraded to ~a") + (upstream-source-version source)) + #:field 'version)) + '())) + (#f '()))) ; cannot find newer upstream release ;;; @@ -974,18 +1033,26 @@ the NIST server non-fatal." (match (string-index line #\tab) (#f #t) (index - (emit-warning package + (make-warning package (format #f (G_ "tabulation on line ~a, column ~a") - line-number index))))) + 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))) - (emit-warning package + (make-warning package (format #f (G_ "trailing white space on line ~a") - line-number)))) + 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." @@ -993,9 +1060,13 @@ the NIST server non-fatal." ;; 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 + (make-warning package (format #f (G_ "line ~a is way too long (~a characters)") - line-number (string-length line))))) + line-number (string-length line)) + #:location + (location (package-file package) + line-number + 0)))) (define %hanging-paren-rx (make-regexp "^[[:blank:]]*[()]+[[:blank:]]*$")) @@ -1003,11 +1074,15 @@ the NIST server non-fatal." (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 + (make-warning package (format #f - (G_ "line ~a: parentheses feel lonely, \ + (G_ "parentheses feel lonely, \ move to the previous or next line") - line-number)))) + line-number) + #:location + (location (package-file package) + line-number + 0)))) (define %formatting-reporters ;; List of procedures that report formatting issues. These are not separate @@ -1040,31 +1115,40 @@ them for PACKAGE." (call-with-input-file file (lambda (port) (let loop ((line-number 1) - (last-line #f)) + (last-line #f) + (warnings '())) (let ((line (read-line port))) - (or (eof-object? line) - (and last-line (> line-number last-line)) + (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))) - (begin - (unless (< line-number starting-line) - (for-each (lambda (report) - (report package line line-number)) - reporters)) - (loop (+ 1 line-number) last-line))))))))) + (+ 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))) - (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))))))) + (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)))) + '()))) ;;; @@ -1155,7 +1239,8 @@ 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") diff --git a/tests/lint.scm b/tests/lint.scm index dc2b17aeec..d8b2ca54cd 100644 --- a/tests/lint.scm +++ b/tests/lint.scm @@ -44,7 +44,12 @@ #:use-module (web server http) #:use-module (web response) #:use-module (ice-9 match) + #:use-module (ice-9 regex) + #:use-module (ice-9 getopt-long) + #:use-module (ice-9 pretty-print) + #:use-module (srfi srfi-1) #:use-module (srfi srfi-9 gnu) + #:use-module (srfi srfi-26) #:use-module (srfi srfi-64)) ;; Test the linter. @@ -60,781 +65,696 @@ (define %long-string (make-string 2000 #\a)) +(define (string-match-or-error pattern str) + (or (string-match pattern str) + (error str "did not match" pattern))) + +(define single-lint-warning-message + (match-lambda + (((and (? lint-warning?) warning)) + (lint-warning-message warning)))) + (test-begin "lint") -(define (call-with-warnings thunk) - (let ((port (open-output-string))) - (parameterize ((guix-warning-port port)) - (thunk)) - (get-output-string port))) - -(define-syntax-rule (with-warnings body ...) - (call-with-warnings (lambda () body ...))) - -(test-assert "description: not a string" - (->bool - (string-contains (with-warnings - (let ((pkg (dummy-package "x" - (description 'foobar)))) - (check-description-style pkg))) - "invalid description"))) - -(test-assert "description: not empty" - (->bool - (string-contains (with-warnings - (let ((pkg (dummy-package "x" - (description "")))) - (check-description-style pkg))) - "description should not be empty"))) - -(test-assert "description: valid Texinfo markup" - (->bool - (string-contains - (with-warnings - (check-description-style (dummy-package "x" (description "f{oo}b@r")))) - "Texinfo markup in description is invalid"))) - -(test-assert "description: does not start with an upper-case letter" - (->bool - (string-contains (with-warnings - (let ((pkg (dummy-package "x" - (description "bad description.")))) - (check-description-style pkg))) - "description should start with an upper-case letter"))) - -(test-assert "description: may start with a digit" - (string-null? - (with-warnings - (let ((pkg (dummy-package "x" - (description "2-component library.")))) - (check-description-style pkg))))) - -(test-assert "description: may start with lower-case package name" - (string-null? - (with-warnings - (let ((pkg (dummy-package "x" - (description "x is a dummy package.")))) - (check-description-style pkg))))) - -(test-assert "description: two spaces after end of sentence" - (->bool - (string-contains (with-warnings - (let ((pkg (dummy-package "x" - (description "Bad. Quite bad.")))) - (check-description-style pkg))) - "sentences in description should be followed by two spaces"))) - -(test-assert "description: end-of-sentence detection with abbreviations" - (string-null? - (with-warnings - (let ((pkg (dummy-package "x" - (description - "E.g. Foo, i.e. Bar resp. Baz (a.k.a. DVD).")))) - (check-description-style pkg))))) - -(test-assert "description: may not contain trademark signs" - (and (->bool - (string-contains (with-warnings - (let ((pkg (dummy-package "x" - (description "Does The Right Thing™")))) - (check-description-style pkg))) - "should not contain trademark sign")) - (->bool - (string-contains (with-warnings - (let ((pkg (dummy-package "x" - (description "Works with Format®")))) - (check-description-style pkg))) - "should not contain trademark sign")))) - -(test-assert "description: suggest ornament instead of quotes" - (->bool - (string-contains (with-warnings - (let ((pkg (dummy-package "x" - (description "This is a 'quoted' thing.")))) - (check-description-style pkg))) - "use @code"))) - -(test-assert "synopsis: not a string" - (->bool - (string-contains (with-warnings - (let ((pkg (dummy-package "x" - (synopsis #f)))) - (check-synopsis-style pkg))) - "invalid synopsis"))) - -(test-assert "synopsis: not empty" - (->bool - (string-contains (with-warnings - (let ((pkg (dummy-package "x" - (synopsis "")))) - (check-synopsis-style pkg))) - "synopsis should not be empty"))) - -(test-assert "synopsis: valid Texinfo markup" - (->bool - (string-contains - (with-warnings - (check-synopsis-style (dummy-package "x" (synopsis "Bad $@ texinfo")))) - "Texinfo markup in synopsis is invalid"))) - -(test-assert "synopsis: does not start with an upper-case letter" - (->bool - (string-contains (with-warnings - (let ((pkg (dummy-package "x" - (synopsis "bad synopsis.")))) - (check-synopsis-style pkg))) - "synopsis should start with an upper-case letter"))) - -(test-assert "synopsis: may start with a digit" - (string-null? - (with-warnings - (let ((pkg (dummy-package "x" - (synopsis "5-dimensional frobnicator")))) - (check-synopsis-style pkg))))) - -(test-assert "synopsis: ends with a period" - (->bool - (string-contains (with-warnings - (let ((pkg (dummy-package "x" - (synopsis "Bad synopsis.")))) - (check-synopsis-style pkg))) - "no period allowed at the end of the synopsis"))) - -(test-assert "synopsis: ends with 'etc.'" - (string-null? (with-warnings - (let ((pkg (dummy-package "x" - (synopsis "Foo, bar, etc.")))) - (check-synopsis-style pkg))))) - -(test-assert "synopsis: starts with 'A'" - (->bool - (string-contains (with-warnings - (let ((pkg (dummy-package "x" - (synopsis "A bad synopŝis")))) - (check-synopsis-style pkg))) - "no article allowed at the beginning of the synopsis"))) - -(test-assert "synopsis: starts with 'An'" - (->bool - (string-contains (with-warnings - (let ((pkg (dummy-package "x" - (synopsis "An awful synopsis")))) - (check-synopsis-style pkg))) - "no article allowed at the beginning of the synopsis"))) - -(test-assert "synopsis: starts with 'a'" - (->bool - (string-contains (with-warnings - (let ((pkg (dummy-package "x" - (synopsis "a bad synopsis")))) - (check-synopsis-style pkg))) - "no article allowed at the beginning of the synopsis"))) - -(test-assert "synopsis: starts with 'an'" - (->bool - (string-contains (with-warnings - (let ((pkg (dummy-package "x" - (synopsis "an awful synopsis")))) - (check-synopsis-style pkg))) - "no article allowed at the beginning of the synopsis"))) - -(test-assert "synopsis: too long" - (->bool - (string-contains (with-warnings - (let ((pkg (dummy-package "x" - (synopsis (make-string 80 #\x))))) - (check-synopsis-style pkg))) - "synopsis should be less than 80 characters long"))) - -(test-assert "synopsis: start with package name" - (->bool - (string-contains (with-warnings - (let ((pkg (dummy-package "x" - (name "foo") - (synopsis "foo, a nice package")))) - (check-synopsis-style pkg))) - "synopsis should not start with the package name"))) - -(test-assert "synopsis: start with package name prefix" - (string-null? - (with-warnings - (let ((pkg (dummy-package "arb" - (synopsis "Arbitrary precision")))) - (check-synopsis-style pkg))))) - -(test-assert "synopsis: start with abbreviation" - (string-null? - (with-warnings - (let ((pkg (dummy-package "uucp" - ;; Same problem with "APL interpreter", etc. - (synopsis "UUCP implementation") - (description "Imagine this is Taylor UUCP.")))) - (check-synopsis-style pkg))))) - -(test-assert "inputs: pkg-config is probably a native input" - (->bool - (string-contains - (with-warnings - (let ((pkg (dummy-package "x" - (inputs `(("pkg-config" ,pkg-config)))))) - (check-inputs-should-be-native pkg))) - "'pkg-config' should probably be a native input"))) - -(test-assert "inputs: glib:bin is probably a native input" - (->bool - (string-contains - (with-warnings - (let ((pkg (dummy-package "x" - (inputs `(("glib" ,glib "bin")))))) - (check-inputs-should-be-native pkg))) - "'glib:bin' should probably be a native input"))) - -(test-assert +(test-equal "description: not a string" + "invalid description: foobar" + (single-lint-warning-message + (check-description-style + (dummy-package "x" (description 'foobar))))) + +(test-equal "description: not empty" + "description should not be empty" + (single-lint-warning-message + (check-description-style + (dummy-package "x" (description ""))))) + +(test-equal "description: invalid Texinfo markup" + "Texinfo markup in description is invalid" + (single-lint-warning-message + (check-description-style + (dummy-package "x" (description "f{oo}b@r"))))) + +(test-equal "description: does not start with an upper-case letter" + "description should start with an upper-case letter or digit" + (single-lint-warning-message + (let ((pkg (dummy-package "x" + (description "bad description.")))) + (check-description-style pkg)))) + +(test-equal "description: may start with a digit" + '() + (let ((pkg (dummy-package "x" + (description "2-component library.")))) + (check-description-style pkg))) + +(test-equal "description: may start with lower-case package name" + '() + (let ((pkg (dummy-package "x" + (description "x is a dummy package.")))) + (check-description-style pkg))) + +(test-equal "description: two spaces after end of sentence" + "sentences in description should be followed by two spaces; possible infraction at 3" + (single-lint-warning-message + (let ((pkg (dummy-package "x" + (description "Bad. Quite bad.")))) + (check-description-style pkg)))) + +(test-equal "description: end-of-sentence detection with abbreviations" + '() + (let ((pkg (dummy-package "x" + (description + "E.g. Foo, i.e. Bar resp. Baz (a.k.a. DVD).")))) + (check-description-style pkg))) + +(test-equal "description: may not contain trademark signs: ™" + "description should not contain trademark sign '™' at 20" + (single-lint-warning-message + (let ((pkg (dummy-package "x" + (description "Does The Right Thing™")))) + (check-description-style pkg)))) + +(test-equal "description: may not contain trademark signs: ®" + "description should not contain trademark sign '®' at 17" + (single-lint-warning-message + (let ((pkg (dummy-package "x" + (description "Works with Format®")))) + (check-description-style pkg)))) + +(test-equal "description: suggest ornament instead of quotes" + "use @code or similar ornament instead of quotes" + (single-lint-warning-message + (let ((pkg (dummy-package "x" + (description "This is a 'quoted' thing.")))) + (check-description-style pkg)))) + +(test-equal "synopsis: not a string" + "invalid synopsis: #f" + (single-lint-warning-message + (let ((pkg (dummy-package "x" + (synopsis #f)))) + (check-synopsis-style pkg)))) + +(test-equal "synopsis: not empty" + "synopsis should not be empty" + (single-lint-warning-message + (let ((pkg (dummy-package "x" + (synopsis "")))) + (check-synopsis-style pkg)))) + +(test-equal "synopsis: valid Texinfo markup" + "Texinfo markup in synopsis is invalid" + (single-lint-warning-message + (check-synopsis-style + (dummy-package "x" (synopsis "Bad $@ texinfo"))))) + +(test-equal "synopsis: does not start with an upper-case letter" + "synopsis should start with an upper-case letter or digit" + (single-lint-warning-message + (let ((pkg (dummy-package "x" + (synopsis "bad synopsis")))) + (check-synopsis-style pkg)))) + +(test-equal "synopsis: may start with a digit" + '() + (let ((pkg (dummy-package "x" + (synopsis "5-dimensional frobnicator")))) + (check-synopsis-style pkg))) + +(test-equal "synopsis: ends with a period" + "no period allowed at the end of the synopsis" + (single-lint-warning-message + (let ((pkg (dummy-package "x" + (synopsis "Bad synopsis.")))) + (check-synopsis-style pkg)))) + +(test-equal "synopsis: ends with 'etc.'" + '() + (let ((pkg (dummy-package "x" + (synopsis "Foo, bar, etc.")))) + (check-synopsis-style pkg))) + +(test-equal "synopsis: starts with 'A'" + "no article allowed at the beginning of the synopsis" + (single-lint-warning-message + (let ((pkg (dummy-package "x" + (synopsis "A bad synopŝis")))) + (check-synopsis-style pkg)))) + +(test-equal "synopsis: starts with 'An'" + "no article allowed at the beginning of the synopsis" + (single-lint-warning-message + (let ((pkg (dummy-package "x" + (synopsis "An awful synopsis")))) + (check-synopsis-style pkg)))) + +(test-equal "synopsis: starts with 'a'" + '("no article allowed at the beginning of the synopsis" + "synopsis should start with an upper-case letter or digit") + (sort + (map + lint-warning-message + (let ((pkg (dummy-package "x" + (synopsis "a bad synopsis")))) + (check-synopsis-style pkg))) + stringbool - (string-contains - (with-warnings - (let ((pkg (dummy-package "x" - (inputs `(("python-setuptools" ,python-setuptools)))))) - (check-inputs-should-not-be-an-input-at-all pkg))) - "'python-setuptools' should probably not be an input at all"))) - -(test-assert + "'python-setuptools' should probably not be an input at all" + (single-lint-warning-message + (let ((pkg (dummy-package "x" + (inputs `(("python-setuptools" + ,python-setuptools)))))) + (check-inputs-should-not-be-an-input-at-all pkg)))) + +(test-equal "inputs: python-setuptools should not be an input at all (native-input)" - (->bool - (string-contains - (with-warnings - (let ((pkg (dummy-package "x" - (native-inputs - `(("python-setuptools" ,python-setuptools)))))) - (check-inputs-should-not-be-an-input-at-all pkg))) - "'python-setuptools' should probably not be an input at all"))) - -(test-assert + "'python-setuptools' should probably not be an input at all" + (single-lint-warning-message + (let ((pkg (dummy-package "x" + (native-inputs + `(("python-setuptools" + ,python-setuptools)))))) + (check-inputs-should-not-be-an-input-at-all pkg)))) + +(test-equal "inputs: python-setuptools should not be an input at all (propagated-input)" - (->bool - (string-contains - (with-warnings - (let ((pkg (dummy-package "x" - (propagated-inputs - `(("python-setuptools" ,python-setuptools)))))) - (check-inputs-should-not-be-an-input-at-all pkg))) - "'python-setuptools' should probably not be an input at all"))) - -(test-assert "patches: file names" - (->bool - (string-contains - (with-warnings - (let ((pkg (dummy-package "x" - (source - (dummy-origin - (patches (list "/path/to/y.patch"))))))) - (check-patch-file-names pkg))) - "file names of patches should start with the package name"))) - -(test-assert "patches: file name too long" - (->bool - (string-contains - (with-warnings - (let ((pkg (dummy-package "x" - (source - (dummy-origin - (patches (list (string-append "x-" - (make-string 100 #\a) - ".patch")))))))) - (check-patch-file-names pkg))) - "file name is too long"))) - -(test-assert "patches: not found" - (->bool - (string-contains - (with-warnings - (let ((pkg (dummy-package "x" - (source - (dummy-origin - (patches - (list (search-patch "this-patch-does-not-exist!")))))))) - (check-patch-file-names pkg))) - "patch not found"))) - -(test-assert "derivation: invalid arguments" - (->bool - (string-contains - (with-warnings - (let ((pkg (dummy-package "x" - (arguments - '(#:imported-modules (invalid-module)))))) - (check-derivation pkg))) - "failed to create"))) - -(test-assert "license: invalid license" - (string-contains - (with-warnings - (check-license (dummy-package "x" (license #f)))) - "invalid license")) - -(test-assert "home-page: wrong home-page" - (->bool - (string-contains - (with-warnings - (let ((pkg (package - (inherit (dummy-package "x")) - (home-page #f)))) - (check-home-page pkg))) - "invalid"))) - -(test-assert "home-page: invalid URI" - (->bool - (string-contains - (with-warnings - (let ((pkg (package - (inherit (dummy-package "x")) - (home-page "foobar")))) - (check-home-page pkg))) - "invalid home page URL"))) - -(test-assert "home-page: host not found" - (->bool - (string-contains - (with-warnings - (let ((pkg (package - (inherit (dummy-package "x")) - (home-page "http://does-not-exist")))) - (check-home-page pkg))) - "domain not found"))) + "'python-setuptools' should probably not be an input at all" + (single-lint-warning-message + (let ((pkg (dummy-package "x" + (propagated-inputs + `(("python-setuptools" ,python-setuptools)))))) + (check-inputs-should-not-be-an-input-at-all pkg)))) + +(test-equal "patches: file names" + "file names of patches should start with the package name" + (single-lint-warning-message + (let ((pkg (dummy-package "x" + (source + (dummy-origin + (patches (list "/path/to/y.patch"))))))) + (check-patch-file-names pkg)))) + +(test-equal "patches: file name too long" + (string-append "x-" + (make-string 100 #\a) + ".patch: file name is too long") + (single-lint-warning-message + (let ((pkg (dummy-package + "x" + (source + (dummy-origin + (patches (list (string-append "x-" + (make-string 100 #\a) + ".patch")))))))) + (check-patch-file-names pkg)))) + +(test-equal "patches: not found" + "this-patch-does-not-exist!: patch not found" + (single-lint-warning-message + (let ((pkg (dummy-package + "x" + (source + (dummy-origin + (patches + (list (search-patch "this-patch-does-not-exist!")))))))) + (check-patch-file-names pkg)))) + +(test-equal "derivation: invalid arguments" + "failed to create x86_64-linux derivation: (wrong-type-arg \"map\" \"Wrong type argument: ~S\" (invalid-module) ())" + (match (let ((pkg (dummy-package "x" + (arguments + '(#:imported-modules (invalid-module)))))) + (check-derivation pkg)) + (((and (? lint-warning?) first-warning) others ...) + (lint-warning-message first-warning)))) + +(test-equal "license: invalid license" + "invalid license field" + (single-lint-warning-message + (check-license (dummy-package "x" (license #f))))) + +(test-equal "home-page: wrong home-page" + "invalid value for home page" + (let ((pkg (package + (inherit (dummy-package "x")) + (home-page #f)))) + (single-lint-warning-message + (check-home-page pkg)))) + +(test-equal "home-page: invalid URI" + "invalid home page URL: \"foobar\"" + (let ((pkg (package + (inherit (dummy-package "x")) + (home-page "foobar")))) + (single-lint-warning-message + (check-home-page pkg)))) + +(test-equal "home-page: host not found" + "URI http://does-not-exist domain not found: Name or service not known" + (let ((pkg (package + (inherit (dummy-package "x")) + (home-page "http://does-not-exist")))) + (single-lint-warning-message + (check-home-page pkg)))) (test-skip (if (http-server-can-listen?) 0 1)) -(test-assert "home-page: Connection refused" - (->bool - (string-contains - (with-warnings - (let ((pkg (package - (inherit (dummy-package "x")) - (home-page (%local-url))))) - (check-home-page pkg))) - "Connection refused"))) +(test-equal "home-page: Connection refused" + "URI http://localhost:9999/foo/bar unreachable: Connection refused" + (let ((pkg (package + (inherit (dummy-package "x")) + (home-page (%local-url))))) + (single-lint-warning-message + (check-home-page pkg)))) (test-skip (if (http-server-can-listen?) 0 1)) (test-equal "home-page: 200" - "" - (with-warnings - (with-http-server 200 %long-string - (let ((pkg (package - (inherit (dummy-package "x")) - (home-page (%local-url))))) - (check-home-page pkg))))) + '() + (with-http-server 200 %long-string + (let ((pkg (package + (inherit (dummy-package "x")) + (home-page (%local-url))))) + (check-home-page pkg)))) (test-skip (if (http-server-can-listen?) 0 1)) -(test-assert "home-page: 200 but short length" - (->bool - (string-contains - (with-warnings - (with-http-server 200 "This is too small." - (let ((pkg (package - (inherit (dummy-package "x")) - (home-page (%local-url))))) - (check-home-page pkg)))) - "suspiciously small"))) +(test-equal "home-page: 200 but short length" + "URI http://localhost:9999/foo/bar returned suspiciously small file (18 bytes)" + (with-http-server 200 "This is too small." + (let ((pkg (package + (inherit (dummy-package "x")) + (home-page (%local-url))))) + + (single-lint-warning-message + (check-home-page pkg))))) (test-skip (if (http-server-can-listen?) 0 1)) -(test-assert "home-page: 404" - (->bool - (string-contains - (with-warnings - (with-http-server 404 %long-string - (let ((pkg (package - (inherit (dummy-package "x")) - (home-page (%local-url))))) - (check-home-page pkg)))) - "not reachable: 404"))) +(test-equal "home-page: 404" + "URI http://localhost:9999/foo/bar not reachable: 404 (\"Such is life\")" + (with-http-server 404 %long-string + (let ((pkg (package + (inherit (dummy-package "x")) + (home-page (%local-url))))) + (single-lint-warning-message + (check-home-page pkg))))) (test-skip (if (http-server-can-listen?) 0 1)) -(test-assert "home-page: 301, invalid" - (->bool - (string-contains - (with-warnings - (with-http-server 301 %long-string - (let ((pkg (package - (inherit (dummy-package "x")) - (home-page (%local-url))))) - (check-home-page pkg)))) - "invalid permanent redirect"))) +(test-equal "home-page: 301, invalid" + "invalid permanent redirect from http://localhost:9999/foo/bar" + (with-http-server 301 %long-string + (let ((pkg (package + (inherit (dummy-package "x")) + (home-page (%local-url))))) + (single-lint-warning-message + (check-home-page pkg))))) (test-skip (if (http-server-can-listen?) 0 1)) -(test-assert "home-page: 301 -> 200" - (->bool - (string-contains - (with-warnings - (with-http-server 200 %long-string - (let ((initial-url (%local-url))) - (parameterize ((%http-server-port (+ 1 (%http-server-port)))) - (with-http-server (301 `((location - . ,(string->uri initial-url)))) - "" - (let ((pkg (package - (inherit (dummy-package "x")) - (home-page (%local-url))))) - (check-home-page pkg))))))) - "permanent redirect"))) +(test-equal "home-page: 301 -> 200" + "permanent redirect from http://localhost:10000/foo/bar to http://localhost:9999/foo/bar" + (with-http-server 200 %long-string + (let ((initial-url (%local-url))) + (parameterize ((%http-server-port (+ 1 (%http-server-port)))) + (with-http-server (301 `((location + . ,(string->uri initial-url)))) + "" + (let ((pkg (package + (inherit (dummy-package "x")) + (home-page (%local-url))))) + (single-lint-warning-message + (check-home-page pkg)))))))) (test-skip (if (http-server-can-listen?) 0 1)) -(test-assert "home-page: 301 -> 404" - (->bool - (string-contains - (with-warnings - (with-http-server 404 "booh!" - (let ((initial-url (%local-url))) - (parameterize ((%http-server-port (+ 1 (%http-server-port)))) - (with-http-server (301 `((location - . ,(string->uri initial-url)))) - "" - (let ((pkg (package - (inherit (dummy-package "x")) - (home-page (%local-url))))) - (check-home-page pkg))))))) - "not reachable: 404"))) - -(test-assert "source-file-name" - (->bool - (string-contains - (with-warnings - (let ((pkg (dummy-package "x" - (version "3.2.1") - (source - (origin - (method url-fetch) - (uri "http://www.example.com/3.2.1.tar.gz") - (sha256 %null-sha256)))))) - (check-source-file-name pkg))) - "file name should contain the package name"))) - -(test-assert "source-file-name: v prefix" - (->bool - (string-contains - (with-warnings - (let ((pkg (dummy-package "x" - (version "3.2.1") - (source - (origin - (method url-fetch) - (uri "http://www.example.com/v3.2.1.tar.gz") - (sha256 %null-sha256)))))) - (check-source-file-name pkg))) - "file name should contain the package name"))) - -(test-assert "source-file-name: bad checkout" - (->bool - (string-contains - (with-warnings - (let ((pkg (dummy-package "x" - (version "3.2.1") - (source - (origin - (method git-fetch) - (uri (git-reference - (url "http://www.example.com/x.git") - (commit "0"))) - (sha256 %null-sha256)))))) - (check-source-file-name pkg))) - "file name should contain the package name"))) - -(test-assert "source-file-name: good checkout" - (not - (->bool - (string-contains - (with-warnings - (let ((pkg (dummy-package "x" - (version "3.2.1") - (source - (origin - (method git-fetch) - (uri (git-reference - (url "http://git.example.com/x.git") - (commit "0"))) - (file-name (string-append "x-" version)) - (sha256 %null-sha256)))))) - (check-source-file-name pkg))) - "file name should contain the package name")))) - -(test-assert "source-file-name: valid" - (not - (->bool - (string-contains - (with-warnings - (let ((pkg (dummy-package "x" - (version "3.2.1") - (source - (origin - (method url-fetch) - (uri "http://www.example.com/x-3.2.1.tar.gz") - (sha256 %null-sha256)))))) - (check-source-file-name pkg))) - "file name should contain the package name")))) - -(test-assert "source-unstable-tarball" - (string-contains - (with-warnings - (let ((pkg (dummy-package "x" - (source - (origin - (method url-fetch) - (uri "https://github.com/example/example/archive/v0.0.tar.gz") - (sha256 %null-sha256)))))) - (check-source-unstable-tarball pkg))) - "source URI should not be an autogenerated tarball")) - -(test-assert "source-unstable-tarball: source #f" - (not - (->bool - (string-contains - (with-warnings - (let ((pkg (dummy-package "x" - (source #f)))) - (check-source-unstable-tarball pkg))) - "source URI should not be an autogenerated tarball")))) - -(test-assert "source-unstable-tarball: valid" - (not - (->bool - (string-contains - (with-warnings - (let ((pkg (dummy-package "x" - (source - (origin - (method url-fetch) - (uri "https://github.com/example/example/releases/download/x-0.0/x-0.0.tar.gz") - (sha256 %null-sha256)))))) - (check-source-unstable-tarball pkg))) - "source URI should not be an autogenerated tarball")))) - -(test-assert "source-unstable-tarball: package named archive" - (not - (->bool - (string-contains - (with-warnings - (let ((pkg (dummy-package "x" - (source - (origin - (method url-fetch) - (uri "https://github.com/example/archive/releases/download/x-0.0/x-0.0.tar.gz") - (sha256 %null-sha256)))))) - (check-source-unstable-tarball pkg))) - "source URI should not be an autogenerated tarball")))) - -(test-assert "source-unstable-tarball: not-github" - (not - (->bool - (string-contains - (with-warnings - (let ((pkg (dummy-package "x" - (source - (origin - (method url-fetch) - (uri "https://bitbucket.org/archive/example/download/x-0.0.tar.gz") - (sha256 %null-sha256)))))) - (check-source-unstable-tarball pkg))) - "source URI should not be an autogenerated tarball")))) - -(test-assert "source-unstable-tarball: git-fetch" - (not - (->bool - (string-contains - (with-warnings - (let ((pkg (dummy-package "x" - (source - (origin - (method git-fetch) - (uri (git-reference - (url "https://github.com/archive/example.git") - (commit "0"))) - (sha256 %null-sha256)))))) - (check-source-unstable-tarball pkg))) - "source URI should not be an autogenerated tarball")))) +(test-equal "home-page: 301 -> 404" + "URI http://localhost:10000/foo/bar not reachable: 404 (\"Such is life\")" + (with-http-server 404 "booh!" + (let ((initial-url (%local-url))) + (parameterize ((%http-server-port (+ 1 (%http-server-port)))) + (with-http-server (301 `((location + . ,(string->uri initial-url)))) + "" + (let ((pkg (package + (inherit (dummy-package "x")) + (home-page (%local-url))))) + (single-lint-warning-message + (check-home-page pkg)))))))) + + +(test-equal "source-file-name" + "the source file name should contain the package name" + (let ((pkg (dummy-package "x" + (version "3.2.1") + (source + (origin + (method url-fetch) + (uri "http://www.example.com/3.2.1.tar.gz") + (sha256 %null-sha256)))))) + (single-lint-warning-message + (check-source-file-name pkg)))) + +(test-equal "source-file-name: v prefix" + "the source file name should contain the package name" + (let ((pkg (dummy-package "x" + (version "3.2.1") + (source + (origin + (method url-fetch) + (uri "http://www.example.com/v3.2.1.tar.gz") + (sha256 %null-sha256)))))) + (single-lint-warning-message + (check-source-file-name pkg)))) + +(test-equal "source-file-name: bad checkout" + "the source file name should contain the package name" + (let ((pkg (dummy-package "x" + (version "3.2.1") + (source + (origin + (method git-fetch) + (uri (git-reference + (url "http://www.example.com/x.git") + (commit "0"))) + (sha256 %null-sha256)))))) + (single-lint-warning-message + (check-source-file-name pkg)))) + +(test-equal "source-file-name: good checkout" + '() + (let ((pkg (dummy-package "x" + (version "3.2.1") + (source + (origin + (method git-fetch) + (uri (git-reference + (url "http://git.example.com/x.git") + (commit "0"))) + (file-name (string-append "x-" version)) + (sha256 %null-sha256)))))) + (check-source-file-name pkg))) + +(test-equal "source-file-name: valid" + '() + (let ((pkg (dummy-package "x" + (version "3.2.1") + (source + (origin + (method url-fetch) + (uri "http://www.example.com/x-3.2.1.tar.gz") + (sha256 %null-sha256)))))) + (check-source-file-name pkg))) -(test-skip (if (http-server-can-listen?) 0 1)) -(test-equal "source: 200" - "" - (with-warnings - (with-http-server 200 %long-string - (let ((pkg (package - (inherit (dummy-package "x")) - (source (origin - (method url-fetch) - (uri (%local-url)) - (sha256 %null-sha256)))))) - (check-source pkg))))) +(test-equal "source-unstable-tarball" + "the source URI should not be an autogenerated tarball" + (let ((pkg (dummy-package "x" + (source + (origin + (method url-fetch) + (uri "https://github.com/example/example/archive/v0.0.tar.gz") + (sha256 %null-sha256)))))) + (single-lint-warning-message + (check-source-unstable-tarball pkg)))) + +(test-equal "source-unstable-tarball: source #f" + '() + (let ((pkg (dummy-package "x" + (source #f)))) + (check-source-unstable-tarball pkg))) + +(test-equal "source-unstable-tarball: valid" + '() + (let ((pkg (dummy-package "x" + (source + (origin + (method url-fetch) + (uri "https://github.com/example/example/releases/download/x-0.0/x-0.0.tar.gz") + (sha256 %null-sha256)))))) + (check-source-unstable-tarball pkg))) -(test-skip (if (http-server-can-listen?) 0 1)) -(test-assert "source: 200 but short length" - (->bool - (string-contains - (with-warnings - (with-http-server 200 "This is too small." - (let ((pkg (package - (inherit (dummy-package "x")) - (source (origin +(test-equal "source-unstable-tarball: package named archive" + '() + (let ((pkg (dummy-package "x" + (source + (origin (method url-fetch) - (uri (%local-url)) + (uri "https://github.com/example/archive/releases/download/x-0.0/x-0.0.tar.gz") (sha256 %null-sha256)))))) - (check-source pkg)))) - "suspiciously small"))) + (check-source-unstable-tarball pkg))) -(test-skip (if (http-server-can-listen?) 0 1)) -(test-assert "source: 404" - (->bool - (string-contains - (with-warnings - (with-http-server 404 %long-string - (let ((pkg (package - (inherit (dummy-package "x")) - (source (origin +(test-equal "source-unstable-tarball: not-github" + '() + (let ((pkg (dummy-package "x" + (source + (origin (method url-fetch) - (uri (%local-url)) + (uri "https://bitbucket.org/archive/example/download/x-0.0.tar.gz") (sha256 %null-sha256)))))) - (check-source pkg)))) - "not reachable: 404"))) + (check-source-unstable-tarball pkg))) + +(test-equal "source-unstable-tarball: git-fetch" + '() + (let ((pkg (dummy-package "x" + (source + (origin + (method git-fetch) + (uri (git-reference + (url "https://github.com/archive/example.git") + (commit "0"))) + (sha256 %null-sha256)))))) + (check-source-unstable-tarball pkg))) + +(test-skip (if (http-server-can-listen?) 0 1)) +(test-equal "source: 200" + '() + (with-http-server 200 %long-string + (let ((pkg (package + (inherit (dummy-package "x")) + (source (origin + (method url-fetch) + (uri (%local-url)) + (sha256 %null-sha256)))))) + (check-source pkg)))) + +(test-skip (if (http-server-can-listen?) 0 1)) +(test-equal "source: 200 but short length" + "URI http://localhost:9999/foo/bar returned suspiciously small file (18 bytes)" + (with-http-server 200 "This is too small." + (let ((pkg (package + (inherit (dummy-package "x")) + (source (origin + (method url-fetch) + (uri (%local-url)) + (sha256 %null-sha256)))))) + (match (check-source pkg) + ((first-warning ; All source URIs are unreachable + (and (? lint-warning?) second-warning)) + (lint-warning-message second-warning)))))) + +(test-skip (if (http-server-can-listen?) 0 1)) +(test-equal "source: 404" + "URI http://localhost:9999/foo/bar not reachable: 404 (\"Such is life\")" + (with-http-server 404 %long-string + (let ((pkg (package + (inherit (dummy-package "x")) + (source (origin + (method url-fetch) + (uri (%local-url)) + (sha256 %null-sha256)))))) + (match (check-source pkg) + ((first-warning ; All source URIs are unreachable + (and (? lint-warning?) second-warning)) + (lint-warning-message second-warning)))))) (test-skip (if (http-server-can-listen?) 0 1)) (test-equal "source: 301 -> 200" - "" - (with-warnings - (with-http-server 200 %long-string - (let ((initial-url (%local-url))) - (parameterize ((%http-server-port (+ 1 (%http-server-port)))) - (with-http-server (301 `((location . ,(string->uri initial-url)))) - "" - (let ((pkg (package - (inherit (dummy-package "x")) - (source (origin - (method url-fetch) - (uri (%local-url)) - (sha256 %null-sha256)))))) - (check-source pkg)))))))) + "permanent redirect from http://localhost:10000/foo/bar to http://localhost:9999/foo/bar" + (with-http-server 200 %long-string + (let ((initial-url (%local-url))) + (parameterize ((%http-server-port (+ 1 (%http-server-port)))) + (with-http-server (301 `((location . ,(string->uri initial-url)))) + "" + (let ((pkg (package + (inherit (dummy-package "x")) + (source (origin + (method url-fetch) + (uri (%local-url)) + (sha256 %null-sha256)))))) + (match (check-source pkg) + ((first-warning ; All source URIs are unreachable + (and (? lint-warning?) second-warning)) + (lint-warning-message second-warning))))))))) (test-skip (if (http-server-can-listen?) 0 1)) -(test-assert "source: 301 -> 404" - (->bool - (string-contains - (with-warnings - (with-http-server 404 "booh!" - (let ((initial-url (%local-url))) - (parameterize ((%http-server-port (+ 1 (%http-server-port)))) - (with-http-server (301 `((location . ,(string->uri initial-url)))) - "" - (let ((pkg (package - (inherit (dummy-package "x")) - (source (origin - (method url-fetch) - (uri (%local-url)) - (sha256 %null-sha256)))))) - (check-source pkg))))))) - "not reachable: 404"))) - -(test-assert "mirror-url" - (string-null? - (with-warnings - (let ((source (origin - (method url-fetch) - (uri "http://example.org/foo/bar.tar.gz") - (sha256 %null-sha256)))) - (check-mirror-url (dummy-package "x" (source source))))))) - -(test-assert "mirror-url: one suggestion" - (string-contains - (with-warnings - (let ((source (origin - (method url-fetch) - (uri "http://ftp.gnu.org/pub/gnu/foo/foo.tar.gz") - (sha256 %null-sha256)))) - (check-mirror-url (dummy-package "x" (source source))))) - "mirror://gnu/foo/foo.tar.gz")) - -(test-assert "github-url" - (string-null? - (with-warnings - (with-http-server 200 %long-string - (check-github-url - (dummy-package "x" (source - (origin - (method url-fetch) - (uri (%local-url)) - (sha256 %null-sha256))))))))) +(test-equal "source: 301 -> 404" + "URI http://localhost:10000/foo/bar not reachable: 404 (\"Such is life\")" + (with-http-server 404 "booh!" + (let ((initial-url (%local-url))) + (parameterize ((%http-server-port (+ 1 (%http-server-port)))) + (with-http-server (301 `((location . ,(string->uri initial-url)))) + "" + (let ((pkg (package + (inherit (dummy-package "x")) + (source (origin + (method url-fetch) + (uri (%local-url)) + (sha256 %null-sha256)))))) + (match (check-source pkg) + ((first-warning ; The first warning says that all URI's are + ; unreachable + (and (? lint-warning?) second-warning)) + (lint-warning-message second-warning))))))))) + +(test-equal "mirror-url" + '() + (let ((source (origin + (method url-fetch) + (uri "http://example.org/foo/bar.tar.gz") + (sha256 %null-sha256)))) + (check-mirror-url (dummy-package "x" (source source))))) + +(test-equal "mirror-url: one suggestion" + "URL should be 'mirror://gnu/foo/foo.tar.gz'" + (let ((source (origin + (method url-fetch) + (uri "http://ftp.gnu.org/pub/gnu/foo/foo.tar.gz") + (sha256 %null-sha256)))) + (single-lint-warning-message + (check-mirror-url (dummy-package "x" (source source)))))) + +(test-equal "github-url" + '() + (with-http-server 200 %long-string + (check-github-url + (dummy-package "x" (source + (origin + (method url-fetch) + (uri (%local-url)) + (sha256 %null-sha256))))))) (let ((github-url "https://github.com/foo/bar/bar-1.0.tar.gz")) - (test-assert "github-url: one suggestion" - (string-contains - (with-warnings - (with-http-server (301 `((location . ,(string->uri github-url)))) "" - (let ((initial-uri (%local-url))) - (parameterize ((%http-server-port (+ 1 (%http-server-port)))) - (with-http-server (302 `((location . ,(string->uri initial-uri)))) "" - (check-github-url - (dummy-package "x" (source - (origin - (method url-fetch) - (uri (%local-url)) - (sha256 %null-sha256)))))))))) - github-url)) - (test-assert "github-url: already the correct github url" - (string-null? - (with-warnings - (check-github-url - (dummy-package "x" (source - (origin - (method url-fetch) - (uri github-url) - (sha256 %null-sha256))))))))) - -(test-assert "cve" + (test-equal "github-url: one suggestion" + (string-append + "URL should be '" github-url "'") + (with-http-server (301 `((location . ,(string->uri github-url)))) "" + (let ((initial-uri (%local-url))) + (parameterize ((%http-server-port (+ 1 (%http-server-port)))) + (with-http-server (302 `((location . ,(string->uri initial-uri)))) "" + (single-lint-warning-message + (check-github-url + (dummy-package "x" (source + (origin + (method url-fetch) + (uri (%local-url)) + (sha256 %null-sha256))))))))))) + (test-equal "github-url: already the correct github url" + '() + (check-github-url + (dummy-package "x" (source + (origin + (method url-fetch) + (uri github-url) + (sha256 %null-sha256))))))) + +(test-equal "cve" + '() (mock ((guix scripts lint) package-vulnerabilities (const '())) - (string-null? - (with-warnings (check-vulnerabilities (dummy-package "x")))))) + (check-vulnerabilities (dummy-package "x")))) -(test-assert "cve: one vulnerability" +(test-equal "cve: one vulnerability" + "probably vulnerable to CVE-2015-1234" (mock ((guix scripts lint) package-vulnerabilities (lambda (package) (list (make-struct (@@ (guix cve) ) 0 "CVE-2015-1234" (list (cons (package-name package) (package-version package))))))) - (string-contains - (with-warnings - (check-vulnerabilities (dummy-package "pi" (version "3.14")))) - "vulnerable to CVE-2015-1234"))) + (single-lint-warning-message + (check-vulnerabilities (dummy-package "pi" (version "3.14")))))) -(test-assert "cve: one patched vulnerability" +(test-equal "cve: one patched vulnerability" + '() (mock ((guix scripts lint) package-vulnerabilities (lambda (package) (list (make-struct (@@ (guix cve) ) 0 "CVE-2015-1234" (list (cons (package-name package) (package-version package))))))) - (string-null? - (with-warnings - (check-vulnerabilities - (dummy-package "pi" - (version "3.14") - (source - (dummy-origin - (patches - (list "/a/b/pi-CVE-2015-1234.patch")))))))))) - -(test-assert "cve: known safe from vulnerability" + (check-vulnerabilities + (dummy-package "pi" + (version "3.14") + (source + (dummy-origin + (patches + (list "/a/b/pi-CVE-2015-1234.patch")))))))) + +(test-equal "cve: known safe from vulnerability" + '() (mock ((guix scripts lint) package-vulnerabilities (lambda (package) (list (make-struct (@@ (guix cve) ) 0 "CVE-2015-1234" (list (cons (package-name package) (package-version package))))))) - (string-null? - (with-warnings - (check-vulnerabilities - (dummy-package "pi" - (version "3.14") - (properties `((lint-hidden-cve . ("CVE-2015-1234")))))))))) - -(test-assert "cve: vulnerability fixed in replacement version" + (check-vulnerabilities + (dummy-package "pi" + (version "3.14") + (properties `((lint-hidden-cve . ("CVE-2015-1234")))))))) + +(test-equal "cve: vulnerability fixed in replacement version" + '() (mock ((guix scripts lint) package-vulnerabilities (lambda (package) (match (package-version package) @@ -845,71 +765,60 @@ (package-version package)))))) ("1" '())))) - (and (not (string-null? - (with-warnings - (check-vulnerabilities - (dummy-package "foo" (version "0")))))) - (string-null? - (with-warnings - (check-vulnerabilities - (dummy-package - "foo" (version "0") - (replacement (dummy-package "foo" (version "1")))))))))) - -(test-assert "cve: patched vulnerability in replacement" + (check-vulnerabilities + (dummy-package + "foo" (version "0") + (replacement (dummy-package "foo" (version "1"))))))) + +(test-equal "cve: patched vulnerability in replacement" + '() (mock ((guix scripts lint) package-vulnerabilities (lambda (package) (list (make-struct (@@ (guix cve) ) 0 "CVE-2015-1234" (list (cons (package-name package) (package-version package))))))) - (string-null? - (with-warnings - (check-vulnerabilities - (dummy-package - "pi" (version "3.14") (source (dummy-origin)) - (replacement (dummy-package - "pi" (version "3.14") - (source - (dummy-origin - (patches - (list "/a/b/pi-CVE-2015-1234.patch")))))))))))) - -(test-assert "formatting: lonely parentheses" - (string-contains - (with-warnings - (check-formatting - ( - dummy-package "ugly as hell!" - ) - )) - "lonely")) + (check-vulnerabilities + (dummy-package + "pi" (version "3.14") (source (dummy-origin)) + (replacement (dummy-package + "pi" (version "3.14") + (source + (dummy-origin + (patches + (list "/a/b/pi-CVE-2015-1234.patch")))))))))) + +(test-equal "formatting: lonely parentheses" + "parentheses feel lonely, move to the previous or next line" + (single-lint-warning-message + (check-formatting + (dummy-package "ugly as hell!" + ) + ))) (test-assert "formatting: tabulation" - (string-contains - (with-warnings - (check-formatting (dummy-package "leave the tab here: "))) - "tabulation")) + (string-match-or-error + "tabulation on line [0-9]+, column [0-9]+" + (single-lint-warning-message + (check-formatting (dummy-package "leave the tab here: "))))) (test-assert "formatting: trailing white space" - (string-contains - (with-warnings - ;; Leave the trailing white space on the next line! - (check-formatting (dummy-package "x"))) - "trailing white space")) + (string-match-or-error + "trailing white space .*" + ;; Leave the trailing white space on the next line! + (single-lint-warning-message + (check-formatting (dummy-package "x"))))) (test-assert "formatting: long line" - (string-contains - (with-warnings - (check-formatting - (dummy-package "x" ;here is a stupid comment just to make a long line - ))) - "too long")) - -(test-assert "formatting: alright" - (string-null? - (with-warnings - (check-formatting (dummy-package "x"))))) + (string-match-or-error + "line [0-9]+ is way too long \\([0-9]+ characters\\)" + (single-lint-warning-message (check-formatting + (dummy-package "x")) ;here is a stupid comment just to make a long line + ))) + +(test-equal "formatting: alright" + '() + (check-formatting (dummy-package "x"))) (test-end "lint") -- cgit v1.2.3 From 57238532f44f99d4770508ba11e105299c96590b Mon Sep 17 00:00:00 2001 From: Christopher Baines Date: Sun, 16 Jun 2019 13:52:13 +0100 Subject: scripts: lint: Separate the message warning text and data. So that translations can be handled more flexibly, rather than having to translate the message text within the checker. * guix/scripts/lint.scm (lint-warning-message-text, lint-warning-message-data): New procedures. (lint-warning-message): Remove record field accessor, replace with procedure that handles the lint warning data and translating the message. (make-warning): Rename to %make-warning. (make-warning): New macro. (emit-warnings): Handle the message-text and message-data fields. (check-description-style): Adjust for changes to make-warning. [check-trademarks, check-end-of-sentence-space): Adjust for changes to make-warning. (check-inputs-should-be-native, check-inputs-should-not-be-an-input-at-all, check-synopsis-style, validate-uri, check-home-page, check-patch-file-names, check-gnu-synopsis+description, check-mirror-url, check-github-url, check-derivation, check-vulnerabilities, check-for-updates, report-tabulations, report-trailing-white-space, report-long-line, report-lone-parentheses): Adjust for changes to make-warning. --- guix/scripts/lint.scm | 198 +++++++++++++++++++++++++++----------------------- 1 file changed, 106 insertions(+), 92 deletions(-) (limited to 'guix') diff --git a/guix/scripts/lint.scm b/guix/scripts/lint.scm index 1b08068669..4eb7e0e200 100644 --- a/guix/scripts/lint.scm +++ b/guix/scripts/lint.scm @@ -88,6 +88,8 @@ lint-warning? lint-warning-package lint-warning-message + lint-warning-message-text + lint-warning-message-data lint-warning-location %checkers @@ -105,35 +107,49 @@ (define-record-type* lint-warning make-lint-warning lint-warning? - (package lint-warning-package) - (message lint-warning-message) - (location lint-warning-location - (default #f))) + (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 - #:key field location) +(define* (%make-warning package message-text + #:optional (message-data '()) + #:key field location) (make-lint-warning package - message + 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 ...)))) + (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. (for-each (match-lambda - (($ package message loc) + (($ package message-text message-data loc) (format (guix-warning-port) "~a: ~a@~a: ~a~%" (location->string loc) (package-name package) (package-version package) - message))) + (apply format #f (G_ message-text) message-data)))) warnings)) @@ -199,9 +215,9 @@ http://www.gnu.org/prep/standards/html_node/Trademarks.html." ((and (? number?) index) (list (make-warning package - (format #f (G_ "description should not contain ~ + (G_ "description should not contain ~ trademark sign '~a' at ~d") - (string-ref description index) index) + (list (string-ref description index) index) #:field 'description))) (else '()))) @@ -242,10 +258,10 @@ trademark sign '~a' at ~d") '() (list (make-warning package - (format #f (G_ "sentences in description should be followed ~ + (G_ "sentences in description should be followed ~ by two spaces; possible infraction~p at ~{~a~^, ~}") - (length infractions) - infractions) + (list (length infractions) + infractions) #:field 'description))))) (let ((description (package-description package))) @@ -263,7 +279,8 @@ by two spaces; possible infraction~p at ~{~a~^, ~}") (check-proper-start plain-description)))) (list (make-warning package - (format #f (G_ "invalid description: ~s") description) + (G_ "invalid description: ~s") + (list description) #:field 'description))))) (define (package-input-intersection inputs-to-check input-names) @@ -308,8 +325,8 @@ of a package, and INPUT-NAMES, a list of package specifications such as (map (lambda (input) (make-warning package - (format #f (G_ "'~a' should probably be a native input") - input) + (G_ "'~a' should probably be a native input") + (list input) #:field 'inputs)) (package-input-intersection inputs input-names)))) @@ -323,9 +340,8 @@ of a package, and INPUT-NAMES, a list of package specifications such as (map (lambda (input) (make-warning package - (format #f - (G_ "'~a' should probably not be an input at all") - input) + (G_ "'~a' should probably not be an input at all") + (list input) #:field 'inputs)) (package-input-intersection (package-direct-inputs package) input-names)))) @@ -423,7 +439,9 @@ markup is valid return a plain-text version of SYNOPSIS, otherwise #f." checks)) (invalid (list - (make-warning package (format #f (G_ "invalid synopsis: ~s") invalid) + (make-warning package + (G_ "invalid synopsis: ~s") + (list invalid) #:field 'synopsis))))) (define* (probe-uri uri #:key timeout) @@ -540,64 +558,59 @@ PACKAGE mentionning the FIELD." ;; such malicious behavior. (or (> length 1000) (make-warning package - (format #f - (G_ "URI ~a returned \ + (G_ "URI ~a returned \ suspiciously small file (~a bytes)") - (uri->string uri) - length) + (list (uri->string uri) + length) #:field field))) (_ #t))) ((= 301 (response-code argument)) (if (response-location argument) (make-warning package - (format #f (G_ "permanent redirect from ~a to ~a") - (uri->string uri) - (uri->string - (response-location argument))) + (G_ "permanent redirect from ~a to ~a") + (list (uri->string uri) + (uri->string + (response-location argument))) #:field field) (make-warning package - (format #f (G_ "invalid permanent redirect \ + (G_ "invalid permanent redirect \ from ~a") - (uri->string uri)) + (list (uri->string uri)) #:field field))) (else (make-warning package - (format #f - (G_ "URI ~a not reachable: ~a (~s)") - (uri->string uri) - (response-code argument) - (response-reason-phrase argument)) + (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 - (format #f - (G_ "URI ~a not reachable: ~a (~s)") - (uri->string uri) - code (string-trim-both message)) + (G_ "URI ~a not reachable: ~a (~s)") + (list (uri->string uri) + code (string-trim-both message)) #:field field)))) ((getaddrinfo-error) (make-warning package - (format #f - (G_ "URI ~a domain not found: ~a") - (uri->string uri) - (gai-strerror (car argument))) + (G_ "URI ~a domain not found: ~a") + (list (uri->string uri) + (gai-strerror (car argument))) #:field field)) ((system-error) (make-warning package - (format #f - (G_ "URI ~a unreachable: ~a") - (uri->string uri) - (strerror - (system-error-errno - (cons status argument)))) + (G_ "URI ~a unreachable: ~a") + (list (uri->string uri) + (strerror + (system-error-errno + (cons status argument)))) #:field field)) ((tls-certificate-error) (make-warning package - (format #f (G_ "TLS certificate error: ~a") - (tls-certificate-error-string argument)) + (G_ "TLS certificate error: ~a") + (list (tls-certificate-error-string argument)) #:field field)) ((invalid-http-response gnutls-error) ;; Probably a misbehaving server; ignore. @@ -627,8 +640,9 @@ from ~a") #:field 'home-page)))) (else (list - (make-warning package (format #f (G_ "invalid home page URL: ~s") - (package-home-page package)) + (make-warning package + (G_ "invalid home page URL: ~s") + (list (package-home-page package)) #:field 'home-page)))))) (define %distro-directory @@ -640,8 +654,10 @@ from ~a") patch could not be found." (guard (c ((message-condition? c) ;raised by 'search-patch' (list - (make-warning package (condition-message c) - #:field 'patch-file-names)))) + ;; 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) '())) @@ -674,8 +690,8 @@ patch could not be found." max) (make-warning package - (format #f (G_ "~a: file name is too long") - (basename patch)) + (G_ "~a: file name is too long") + (list (basename patch)) #:field 'patch-file-names) #f)) (_ #f)) @@ -716,8 +732,8 @@ descriptions maintained upstream." (not (string=? upstream downstream)))) (list (make-warning package - (format #f (G_ "proposed synopsis: ~s~%") - upstream) + (G_ "proposed synopsis: ~s~%") + (list upstream) #:field 'synopsis)) '())) @@ -730,9 +746,8 @@ descriptions maintained upstream." (list (make-warning package - (format #f - (G_ "proposed description:~% \"~a\"~%") - (fill-paragraph (escape-quotes upstream) 77 7)) + (G_ "proposed description:~% \"~a\"~%") + (list (fill-paragraph (escape-quotes upstream) 77 7)) #:field 'description)) '())))))) @@ -831,10 +846,10 @@ descriptions maintained upstream." (loop rest)) (prefix (make-warning package - (format #f (G_ "URL should be \ + (G_ "URL should be \ 'mirror://~a/~a'") - mirror-id - (string-drop uri (string-length prefix))) + (list mirror-id + (string-drop uri (string-length prefix))) #:field 'source))))))) (let ((origin (package-source package))) @@ -876,7 +891,8 @@ descriptions maintained upstream." #f (make-warning package - (format #f (G_ "URL should be '~a'") github-uri) + (G_ "URL should be '~a'") + (list github-uri) #:field 'source))))) (origin-uris origin)) '()))) @@ -888,14 +904,14 @@ descriptions maintained upstream." (lambda () (guard (c ((store-protocol-error? c) (make-warning package - (format #f (G_ "failed to create ~a derivation: ~a") - system - (store-protocol-error-message c)))) + (G_ "failed to create ~a derivation: ~a") + (list system + (store-protocol-error-message c)))) ((message-condition? c) (make-warning package - (format #f (G_ "failed to create ~a derivation: ~a") - system - (condition-message c))))) + (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)) @@ -910,8 +926,8 @@ descriptions maintained upstream." #:graft? #f))))))) (lambda args (make-warning package - (format #f (G_ "failed to create ~a derivation: ~s") - system args))))) + (G_ "failed to create ~a derivation: ~s") + (list system args))))) (filter lint-warning? (map try (package-supported-systems package)))) @@ -1001,15 +1017,15 @@ the NIST server non-fatal." (list (make-warning package - (format #f (G_ "probably vulnerable to ~a") - (string-join (map vulnerability-id unpatched) - ", ")))))))))) + (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 - (format #f (G_ "while retrieving upstream info for '~a'") - (package-name package)) + (G_ "while retrieving upstream info for '~a'") + (list (package-name package)) #f (package-latest-release* package (force %updaters))) ((? upstream-source? source) @@ -1017,8 +1033,8 @@ the NIST server non-fatal." (package-version package)) (list (make-warning package - (format #f (G_ "can be upgraded to ~a") - (upstream-source-version source)) + (G_ "can be upgraded to ~a") + (list (upstream-source-version source)) #:field 'version)) '())) (#f '()))) ; cannot find newer upstream release @@ -1034,8 +1050,8 @@ the NIST server non-fatal." (#f #t) (index (make-warning package - (format #f (G_ "tabulation on line ~a, column ~a") - line-number index) + (G_ "tabulation on line ~a, column ~a") + (list line-number index) #:location (location (package-file package) line-number @@ -1046,9 +1062,8 @@ the NIST server non-fatal." (unless (or (string=? line (string-trim-right line)) (string=? line (string #\page))) (make-warning package - (format #f - (G_ "trailing white space on line ~a") - line-number) + (G_ "trailing white space on line ~a") + (list line-number) #:location (location (package-file package) line-number @@ -1061,8 +1076,8 @@ the NIST server non-fatal." ;; much noise. (when (> (string-length line) 90) (make-warning package - (format #f (G_ "line ~a is way too long (~a characters)") - line-number (string-length line)) + (G_ "line ~a is way too long (~a characters)") + (list line-number (string-length line)) #:location (location (package-file package) line-number @@ -1075,10 +1090,9 @@ the NIST server non-fatal." "Emit a warning if LINE contains hanging parentheses." (when (regexp-exec %hanging-paren-rx line) (make-warning package - (format #f - (G_ "parentheses feel lonely, \ + (G_ "parentheses feel lonely, \ move to the previous or next line") - line-number) + (list line-number) #:location (location (package-file package) line-number -- cgit v1.2.3 From f363c836e0b4c416dae594af4257459da592b35c Mon Sep 17 00:00:00 2001 From: Christopher Baines Date: Tue, 2 Jul 2019 20:25:41 +0100 Subject: lint: Move the linting code to a different module. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit To try and move towards making programatic access to the linting code easier, this commit separates out the linting script, from the linting functionality that it uses. * guix/scripts/lint.scm (emit-warnings): Alter to to not use match-lambda, as isn't accessible. (, lint-warning, make-lint-warning, lint-warning?, lint-warning-message, lint-warning-message-text, lint-warning-message-data, lint-warning-location, package-file, %make-warning make-warning, , lint-checker, make-lint-checker, lint-checker?, lint-checker-name, lint-checker-description, lint-checker-check, properly-starts-sentance?, starts-with-abbreviation?, %quoted-identifier-rx, check-description-style, package-input-intersection, check-inputs-should-be-native, check-inputs-should-not-be-an-input-at-all, package-name-regexp, check-synopsis-style, probe-uri, tls-certificate-error-string, validate-uri, check-home-page, %distro-directory, check-patch-file-names, escape-quotes, official-gnu-packages*, check-gnu-synopsis+description, origin-uris, check-source, check-source-file-name, check-source-unstable-tarball, check-mirror-url, check-github-url, check-derivation, check-license, call-with-networking-fail-safe, with-networking-fail-safe, current-vulnerabilities*, package-vulnerabilities, check-vulnerabilities, check-for-updates, report-tabulations, report-trailing-white-space, report-long-line, %hanging-paren-rx, report-lone-parantheses, %formatting-reporters, report-formatting-issues, check-formatting, %checkers): Move to… * guix/lint.scm: … here * po/guix/POTFILES.in: Add guix/lint.scm. * Makefile.am: Add guix/lint.scm. * tests/lint.scm: Change to import (guix lint), rather than (guix scripts lint). --- Makefile.am | 1 + guix/lint.scm | 1222 +++++++++++++++++++++++++++++++++++++++++++++++++ guix/scripts/lint.scm | 1220 +----------------------------------------------- po/guix/POTFILES.in | 1 + tests/lint.scm | 2 +- 5 files changed, 1244 insertions(+), 1202 deletions(-) create mode 100644 guix/lint.scm (limited to 'guix') diff --git a/Makefile.am b/Makefile.am index bb7156458c..b63c55d784 100644 --- a/Makefile.am +++ b/Makefile.am @@ -98,6 +98,7 @@ MODULES = \ guix/self.scm \ guix/upstream.scm \ guix/licenses.scm \ + guix/lint.scm \ guix/glob.scm \ guix/git.scm \ guix/graph.scm \ diff --git a/guix/lint.scm b/guix/lint.scm new file mode 100644 index 0000000000..c2c0914958 --- /dev/null +++ b/guix/lint.scm @@ -0,0 +1,1222 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2014 Cyril Roelandt +;;; Copyright © 2014, 2015 Eric Bavier +;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018, 2019 Ludovic Courtès +;;; Copyright © 2015, 2016 Mathieu Lirzin +;;; Copyright © 2016 Danny Milosavljevic +;;; Copyright © 2016 Hartmut Goebel +;;; Copyright © 2017 Alex Kost +;;; Copyright © 2017 Tobias Geerinckx-Rice +;;; Copyright © 2017, 2018 Efraim Flashner +;;; Copyright © 2018, 2019 Arun Isaac +;;; +;;; 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 . + +(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 + + %checkers + + lint-checker + lint-checker? + lint-checker-name + lint-checker-description + lint-checker-check)) + + +;;; +;;; Warnings +;;; + +(define-record-type* + 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 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 + ;; . + (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 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 %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: is the name of a data type and must not be + ;; translated. + (description "Make sure the 'license' field is a \ +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)))) diff --git a/guix/scripts/lint.scm b/guix/scripts/lint.scm index 4eb7e0e200..1c46fba16b 100644 --- a/guix/scripts/lint.scm +++ b/guix/scripts/lint.scm @@ -26,1224 +26,32 @@ ;;; along with GNU Guix. If not, see . (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 - - lint-warning - lint-warning? - lint-warning-package - lint-warning-message - lint-warning-message-text - lint-warning-message-data - lint-warning-location - - %checkers - lint-checker - lint-checker? - lint-checker-name - lint-checker-description - lint-checker-check)) - - -;;; -;;; Warnings -;;; - -(define-record-type* - 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 ...)))) + run-checkers)) (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. (for-each - (match-lambda - (($ package message-text message-data loc) - (format (guix-warning-port) "~a: ~a@~a: ~a~%" - (location->string loc) - (package-name package) (package-version package) - (apply format #f (G_ message-text) message-data)))) + (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)) - -;;; -;;; Checkers -;;; - -(define-record-type* - 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) - (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 - ;; . - (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 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 %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: is the name of a data type and must not be - ;; translated. - (description "Make sure the 'license' field is a \ -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)) "Run the given CHECKERS on PACKAGE." (let ((tty? (isatty? (current-error-port)))) @@ -1260,6 +68,16 @@ or a list thereof") (format (current-error-port) "\x1b[K") (force-output (current-error-port))))) +(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)) + ;;; ;;; Command-line options. diff --git a/po/guix/POTFILES.in b/po/guix/POTFILES.in index ad06ebce95..8b556ac0ec 100644 --- a/po/guix/POTFILES.in +++ b/po/guix/POTFILES.in @@ -40,6 +40,7 @@ gnu/machine/ssh.scm guix/scripts.scm guix/scripts/build.scm guix/discovery.scm +guix/lint.scm guix/scripts/download.scm guix/scripts/package.scm guix/scripts/install.scm diff --git a/tests/lint.scm b/tests/lint.scm index d8b2ca54cd..59be061a99 100644 --- a/tests/lint.scm +++ b/tests/lint.scm @@ -33,7 +33,7 @@ #:use-module (guix git-download) #:use-module (guix build-system gnu) #:use-module (guix packages) - #:use-module (guix scripts lint) + #:use-module (guix lint) #:use-module (guix ui) #:use-module (gnu packages) #:use-module (gnu packages glib) -- cgit v1.2.3 From 38f3176a57593be45e245de5fec27518886ce5eb Mon Sep 17 00:00:00 2001 From: Christopher Baines Date: Tue, 2 Jul 2019 20:25:42 +0100 Subject: lint: Separate checkers by dependence on the internet. I think there are a couple of potential uses for this. It's somewhat a separation in to what checkers are just checking the contents of the repository (line length for example), and other checkers which are bringing in external information which could change. I'm thinking particularly, about treating network dependent checkers differently when automatically running them, but this commit also adds a --no-network flag to guix lint, which selects the checkers that don't access the network, which could be useful if no network access is available. * guix/lint.scm (%checkers): Rename to %all-checkers. (%local-checkers, %network-dependent-checkers): New variables. * guix/scripts/lint.scm (run-checkers): Make the checkers argument mandatory. (list-checkers-and-exit): Handle the checkers as an argument. (%options): Adjust for changes to %checkers, add a --no-network option, and change how the --list-checkers option is handled. (guix-lint): Adjust indentation, and update how the checkers are handled. --- guix/lint.scm | 63 +++++++++++++++++++++++++++++---------------------- guix/scripts/lint.scm | 49 +++++++++++++++++++++++---------------- 2 files changed, 66 insertions(+), 46 deletions(-) (limited to 'guix') diff --git a/guix/lint.scm b/guix/lint.scm index c2c0914958..2542a81a2d 100644 --- a/guix/lint.scm +++ b/guix/lint.scm @@ -91,7 +91,9 @@ lint-warning-message-data lint-warning-location - %checkers + %local-checkers + %network-dependent-checkers + %all-checkers lint-checker lint-checker? @@ -1146,16 +1148,12 @@ them for PACKAGE." ;;; List of checkers. ;;; -(define %checkers +(define %local-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") @@ -1164,14 +1162,6 @@ them for PACKAGE." (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: is the name of a data type and must not be @@ -1179,18 +1169,10 @@ them for PACKAGE." (description "Make sure the 'license' field is a \ 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") @@ -1203,10 +1185,37 @@ or a list thereof") (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\ @@ -1215,8 +1224,8 @@ or a list thereof") (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)))) + (check check-for-updates)))) + +(define %all-checkers + (append %local-checkers + %network-dependent-checkers)) diff --git a/guix/scripts/lint.scm b/guix/scripts/lint.scm index 1c46fba16b..98ee469501 100644 --- a/guix/scripts/lint.scm +++ b/guix/scripts/lint.scm @@ -52,7 +52,7 @@ (lint-warning-message lint-warning)))) warnings)) -(define* (run-checkers package #:optional (checkers %checkers)) +(define (run-checkers package checkers) "Run the given CHECKERS on PACKAGE." (let ((tty? (isatty? (current-error-port)))) (for-each (lambda (checker) @@ -68,14 +68,14 @@ (format (current-error-port) "\x1b[K") (force-output (current-error-port))))) -(define (list-checkers-and-exit) +(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) + checkers) (exit 0)) @@ -111,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"))))) @@ -148,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))))) -- cgit v1.2.3 From c82c16a6f3cfeec82ba8bd7572b11852a6152c7e Mon Sep 17 00:00:00 2001 From: Robert Vollmert Date: Mon, 15 Jul 2019 21:41:53 +0200 Subject: build/cargo-build-system: Set CARGO_HOME early. * guix/build/cargo-build-system.scm (configure): Set CARGO_HOME. (install): No longer set CARGO_HOME. Signed-off-by: Danny Milosavljevic --- guix/build/cargo-build-system.scm | 4 +--- 1 file changed, 1 insertion(+), 3 deletions(-) (limited to 'guix') diff --git a/guix/build/cargo-build-system.scm b/guix/build/cargo-build-system.scm index 1f36304b15..e4e62dd838 100644 --- a/guix/build/cargo-build-system.scm +++ b/guix/build/cargo-build-system.scm @@ -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. -- cgit v1.2.3 From 4fde0030d42068b347d7af58ed3b746c5ea2f877 Mon Sep 17 00:00:00 2001 From: Robert Vollmert Date: Mon, 15 Jul 2019 21:41:55 +0200 Subject: build/cargo-build-system: Use bundled json instead of guile-json. * guix/build/cargo-build-system.scm: Use (gnu build json) instead of (json parser). * guix/build-system/cargo.scm: Import (gnu build json) instead of (json parser). Signed-off-by: Danny Milosavljevic --- guix/build-system/cargo.scm | 2 +- guix/build/cargo-build-system.scm | 8 ++++---- 2 files changed, 5 insertions(+), 5 deletions(-) (limited to 'guix') 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/cargo-build-system.scm b/guix/build/cargo-build-system.scm index e4e62dd838..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)))) -- cgit v1.2.3 From 3fb3291e25a7827f1466fba4943c5098a0a0a524 Mon Sep 17 00:00:00 2001 From: Tobias Geerinckx-Rice Date: Mon, 15 Jul 2019 18:46:39 +0200 Subject: Use more guix.gnu.org. * build-aux/build-self.scm (make-config.scm): Replace gnu.org/s/guix with guix.gnu.org. * guix/scripts/publish.scm (render-home-page): Likewise. * guix/self.scm (make-config.scm): Likewise. --- build-aux/build-self.scm | 2 +- guix/scripts/publish.scm | 2 +- guix/self.scm | 2 +- 3 files changed, 3 insertions(+), 3 deletions(-) (limited to 'guix') diff --git a/build-aux/build-self.scm b/build-aux/build-self.scm index 0a1234abb5..fc13032b73 100644 --- a/build-aux/build-self.scm +++ b/build-aux/build-self.scm @@ -75,7 +75,7 @@ (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) 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 b8581d01d5..838ede7690 100644 --- a/guix/self.scm +++ b/guix/self.scm @@ -916,7 +916,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) -- cgit v1.2.3