diff options
| author | Ludovic Courtès <ludo@gnu.org> | 2020-07-12 22:41:09 +0200 |
|---|---|---|
| committer | Ludovic Courtès <ludo@gnu.org> | 2020-07-12 22:41:51 +0200 |
| commit | c10526672e515f07c92dc447bbc592808f67238e (patch) | |
| tree | 26dc5ea7ed9de7fd77faa2956e800c7780d2c07d | |
| parent | 7bbe4655a8726a7250837c01c2678d7bcc6262e6 (diff) | |
| download | guix-c10526672e515f07c92dc447bbc592808f67238e.tar guix-c10526672e515f07c92dc447bbc592808f67238e.tar.gz | |
lint: source: Validate URLs of Git references.
Until now the 'source' checker would look at URL for 'url-fetch' origins
but not for 'git-fetch' origins.
* guix/lint.scm (check-source): Add case for 'git-reference?'.
* tests/lint.scm ("source, git-reference: 301 -> 200"): New test.
| -rw-r--r-- | guix/lint.scm | 47 | ||||
| -rw-r--r-- | tests/lint.scm | 20 |
2 files changed, 46 insertions, 21 deletions
diff --git a/guix/lint.scm b/guix/lint.scm index 445c06f8f4..a550caa237 100644 --- a/guix/lint.scm +++ b/guix/lint.scm @@ -793,27 +793,32 @@ descriptions maintained upstream." (loop rest (cons warning warnings)))))))) (let ((origin (package-source package))) - (if (and (origin? origin) - (eqv? (origin-method origin) url-fetch)) - (let* ((uris (append-map (cut maybe-expand-mirrors <> %mirrors) - (map string->uri (origin-uris origin)))) - (warnings (warnings-for-uris uris))) - - ;; Just make sure that at least one of the URIs is valid. - (if (= (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) - '())) - '()))) + (if (origin? origin) + (cond + ((eq? (origin-method origin) url-fetch) + (let* ((uris (append-map (cut maybe-expand-mirrors <> %mirrors) + (map string->uri (origin-uris origin)))) + (warnings (warnings-for-uris uris))) + + ;; Just make sure that at least one of the URIs is valid. + (if (= (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) + '()))) + ((git-reference? (origin-uri origin)) + (warnings-for-uris + (list (string->uri (git-reference-url (origin-uri origin)))))) + (else + '()))))) (define (check-source-file-name package) "Emit a warning if PACKAGE's origin has no meaningful file name." diff --git a/tests/lint.scm b/tests/lint.scm index ac174f9f23..83becb655a 100644 --- a/tests/lint.scm +++ b/tests/lint.scm @@ -698,6 +698,26 @@ (lint-warning-message second-warning))))))))) (test-skip (if (http-server-can-listen?) 0 1)) +(test-equal "source, git-reference: 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)) + (redirect (build-response #:code 301 + #:headers + `((location + . ,(string->uri initial-url)))))) + (parameterize ((%http-server-port (+ 1 (%http-server-port)))) + (with-http-server `((,redirect "")) + (let ((pkg (dummy-package + "x" + (source (origin + (method git-fetch) + (uri (git-reference (url (%local-url)) + (commit "v1.0.0"))) + (sha256 %null-sha256)))))) + (single-lint-warning-message (check-source pkg)))))))) + +(test-skip (if (http-server-can-listen?) 0 1)) (test-equal "source: 301 -> 404" "URI http://localhost:10000/foo/bar not reachable: 404 (\"Such is life\")" (with-http-server '((404 "booh!")) |