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 --- tests/gexp.scm | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) (limited to 'tests') 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 9e64302d6875585e0d5d1d6c36843c05f23c2ea7 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 10 Jul 2019 18:14:47 +0200 Subject: derivations: Update tests to use new calling convention. * tests/derivations.scm ("build derivation with 1 source"): Adjust to new 'derivation' calling convention. ("identical files are deduplicated"): Likewise. ("fixed-output-derivation?"): Likewise. ("fixed-output derivation"): Likewise. ("fixed-output derivation, recursive"): Likewise. ("derivation with a fixed-output input"): Likewise. ("multiple-output derivation"): Likewise. ("multiple-output derivation, non-alphabetic order"): Likewise. ("read-derivation vs. derivation"): Likewise. ("user of multiple-output derivation"): Likewise. ("derivation with #:references-graphs"): Likewise. ("derivation #:allowed-references, ok"): Likewise. ("derivation #:allowed-references, not allowed"): Likewise. ("derivation #:allowed-references, self allowed"): Likewise. ("derivation #:allowed-references, self not allowed"): Likewise. ("derivation #:disallowed-references, ok"): Likewise. ("derivation #:disallowed-references, not ok"): Likewise. ("derivation #:leaked-env-vars"): Likewise. ("build derivation with coreutils"): Likewise. ("map-derivation, sources"): Likewise. ("derivation with local file as input"): Remove. --- tests/derivations.scm | 89 ++++++++++++++++++++------------------------------- 1 file changed, 35 insertions(+), 54 deletions(-) (limited to 'tests') diff --git a/tests/derivations.scm b/tests/derivations.scm index 7be7726163..368012d2b2 100644 --- a/tests/derivations.scm +++ b/tests/derivations.scm @@ -137,7 +137,7 @@ #:env-vars '(("HOME" . "/homeless") ("zzz" . "Z!") ("AAA" . "A!")) - #:inputs `((,%bash) (,builder)))) + #:sources `(,%bash ,builder))) (succeeded? (build-derivations %store (list drv)))) (and succeeded? @@ -146,36 +146,13 @@ (string=? (call-with-input-file path read-line) "hello, world")))))) -(test-assert "derivation with local file as input" - (let* ((builder (add-text-to-store - %store "my-builder.sh" - "(while read line ; do echo \"$line\" ; done) < $in > $out" - '())) - (input (search-path %load-path "ice-9/boot-9.scm")) - (input* (add-to-store %store (basename input) - #t "sha256" input)) - (drv (derivation %store "derivation-with-input-file" - %bash `(,builder) - - ;; Cheat to pass the actual file name to the - ;; builder. - #:env-vars `(("in" . ,input*)) - - #:inputs `((,%bash) - (,builder) - (,input))))) ; ← local file name - (and (build-derivations %store (list drv)) - ;; Note: we can't compare the files because the above trick alters - ;; the contents. - (valid-path? %store (derivation->output-path drv))))) - (test-assert "derivation fails but keep going" ;; In keep-going mode, 'build-derivations' should fail because of D1, but it ;; must return only after D2 has succeeded. (with-store store (let* ((d1 (derivation %store "fails" %bash `("-c" "false") - #:inputs `((,%bash)))) + #:sources (list %bash))) (d2 (build-expression->derivation %store "sleep-then-succeed" `(begin ,(random-text) @@ -205,10 +182,10 @@ '())) (drv1 (derivation %store "foo" %bash `(,build1) - #:inputs `((,%bash) (,build1)))) + #:sources `(,%bash ,build1))) (drv2 (derivation %store "bar" %bash `(,build2) - #:inputs `((,%bash) (,build2))))) + #:sources `(,%bash ,build2)))) (and (build-derivations %store (list drv1 drv2)) (let ((file1 (derivation->output-path drv1)) (file2 (derivation->output-path drv2))) @@ -344,7 +321,7 @@ (hash (sha256 (string->utf8 "hello"))) (drv (derivation %store "fixed" %bash `(,builder) - #:inputs `((,builder)) + #:sources (list builder) #:hash hash #:hash-algo 'sha256))) (fixed-output-derivation? drv))) @@ -354,7 +331,7 @@ (hash (sha256 (string->utf8 "hello"))) (drv (derivation %store "fixed" %bash `(,builder) - #:inputs `((,builder)) ; optional + #:sources `(,builder) ;optional #:hash hash #:hash-algo 'sha256)) (succeeded? (build-derivations %store (list drv)))) (and succeeded? @@ -386,7 +363,7 @@ (hash (sha256 (string->utf8 "hello"))) (drv (derivation %store "fixed-rec" %bash `(,builder) - #:inputs `((,builder)) + #:sources (list builder) #:hash (base32 "0sg9f58l1jj88w6pdrfdpj5x9b1zrwszk84j81zvby36q9whhhqa") #:hash-algo 'sha256 #:recursive? #t)) @@ -420,11 +397,13 @@ (final1 (derivation %store "final" %bash `(,builder3) #:env-vars `(("in" . ,fixed-out)) - #:inputs `((,%bash) (,builder3) (,fixed1)))) + #:sources (list %bash builder3) + #:inputs (list (derivation-input fixed1)))) (final2 (derivation %store "final" %bash `(,builder3) #:env-vars `(("in" . ,fixed-out)) - #:inputs `((,%bash) (,builder3) (,fixed2)))) + #:sources (list %bash builder3) + #:inputs (list (derivation-input fixed2)))) (succeeded? (build-derivations %store (list final1 final2)))) (and succeeded? @@ -440,7 +419,7 @@ #:env-vars '(("HOME" . "/homeless") ("zzz" . "Z!") ("AAA" . "A!")) - #:inputs `((,%bash) (,builder)) + #:sources `(,%bash ,builder) #:outputs '("out" "second"))) (succeeded? (build-derivations %store (list drv)))) (and succeeded? @@ -460,7 +439,7 @@ '())) (drv (derivation %store "fixed" %bash `(,builder) - #:inputs `((,%bash) (,builder)) + #:sources `(,%bash ,builder) #:outputs '("out" "AAA"))) (succeeded? (build-derivations %store (list drv)))) (and succeeded? @@ -482,15 +461,15 @@ (inputs (map (lambda (file) (derivation %store "derivation-input" %bash '() - #:inputs `((,%bash) (,file)))) + #:sources `(,%bash ,file))) sources)) (builder (add-text-to-store %store "builder.sh" "echo one > $one ; echo two > $two" '())) (drv (derivation %store "derivation" %bash `(,builder) - #:inputs `((,%bash) (,builder) - ,@(map list (append sources inputs))) + #:sources `(,%bash ,builder ,@sources) + #:inputs (map derivation-input inputs) #:outputs '("two" "one"))) (drv* (call-with-input-file (derivation-file-name drv) read-derivation))) @@ -521,7 +500,7 @@ '())) (mdrv (derivation %store "multiple-output" %bash `(,builder1) - #:inputs `((,%bash) (,builder1)) + #:sources (list %bash builder1) #:outputs '("out" "two"))) (builder2 (add-text-to-store %store "my-mo-user-builder.sh" "read x < $one; @@ -536,11 +515,11 @@ ("two" . ,(derivation->output-path mdrv "two"))) - #:inputs `((,%bash) - (,builder2) - ;; two occurrences of MDRV: - (,mdrv) - (,mdrv "two"))))) + #:sources (list %bash builder2) + ;; two occurrences of MDRV: + #:inputs + (list (derivation-input mdrv) + (derivation-input mdrv '("two")))))) (and (build-derivations %store (list (pk 'udrv udrv))) (let ((p (derivation->output-path udrv))) (and (valid-path? %store p) @@ -566,7 +545,7 @@ `(("bash" . ,%bash) ("input1" . ,input1) ("input2" . ,input2)) - #:inputs `((,%bash) (,builder)))) + #:sources (list %bash builder))) (out (derivation->output-path drv))) (define (deps path . deps) (let ((count (length deps))) @@ -599,7 +578,7 @@ (test-assert "derivation #:allowed-references, ok" (let ((drv (derivation %store "allowed" %bash '("-c" "echo hello > $out") - #:inputs `((,%bash)) + #:sources (list %bash) #:allowed-references '()))) (build-derivations %store (list drv)))) @@ -607,7 +586,7 @@ (let* ((txt (add-text-to-store %store "foo" "Hello, world.")) (drv (derivation %store "disallowed" %bash `("-c" ,(string-append "echo " txt "> $out")) - #:inputs `((,%bash) (,txt)) + #:sources (list %bash txt) #:allowed-references '()))) (guard (c ((store-protocol-error? c) ;; There's no specific error message to check for. @@ -618,14 +597,14 @@ (test-assert "derivation #:allowed-references, self allowed" (let ((drv (derivation %store "allowed" %bash '("-c" "echo $out > $out") - #:inputs `((,%bash)) + #:sources (list %bash) #:allowed-references '("out")))) (build-derivations %store (list drv)))) (test-assert "derivation #:allowed-references, self not allowed" (let ((drv (derivation %store "disallowed" %bash `("-c" ,"echo $out > $out") - #:inputs `((,%bash)) + #:sources (list %bash) #:allowed-references '()))) (guard (c ((store-protocol-error? c) ;; There's no specific error message to check for. @@ -636,7 +615,7 @@ (test-assert "derivation #:disallowed-references, ok" (let ((drv (derivation %store "disallowed" %bash '("-c" "echo hello > $out") - #:inputs `((,%bash)) + #:sources (list %bash) #:disallowed-references '("out")))) (build-derivations %store (list drv)))) @@ -644,7 +623,7 @@ (let* ((txt (add-text-to-store %store "foo" "Hello, world.")) (drv (derivation %store "disdisallowed" %bash `("-c" ,(string-append "echo " txt "> $out")) - #:inputs `((,%bash) (,txt)) + #:sources (list %bash txt) #:disallowed-references (list txt)))) (guard (c ((store-protocol-error? c) ;; There's no specific error message to check for. @@ -663,7 +642,7 @@ '("-c" "echo -n $GUIX_STATE_DIRECTORY > $out") #:hash (sha256 (string->utf8 value)) #:hash-algo 'sha256 - #:inputs `((,%bash)) + #:sources (list %bash) #:leaked-env-vars '("GUIX_STATE_DIRECTORY")))) (and (build-derivations %store (list drv)) (call-with-input-file (derivation->output-path drv) @@ -689,8 +668,8 @@ ,(string-append (derivation->output-path %coreutils) "/bin"))) - #:inputs `((,builder) - (,%coreutils)))) + #:sources (list builder) + #:inputs (list (derivation-input %coreutils)))) (succeeded? (build-derivations %store (list drv)))) (and succeeded? @@ -1240,7 +1219,9 @@ (derivation->output-path bash-full) `("-e" ,script1) - #:inputs `((,bash-full) (,script1)))) + #:sources (list script1) + #:inputs + (list (derivation-input bash-full '("out"))))) (drv2 (map-derivation %store drv1 `((,bash-full . ,%bash) (,script1 . ,script2)))) -- 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 'tests') 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 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 'tests') 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 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 'tests') 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