ryan77627/guix
1
0
Fork 0
mirror of https://git.in.rschanz.org/ryan77627/guix.git synced 2024-12-24 05:18:07 -05:00
Code Issues Projects Releases Packages Wiki Activity Actions

lint: source: Validate URLs of Git references.

Browse source 
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.
This commit is contained in:
Ludovic Courtès 2020-07-12 22:41:09 +02:00
parent 7bbe4655a8
commit c10526672e
No known key found for this signature in database
GPG key ID: 090B11993D9AEBB5
2 changed files with 45 additions and 20 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

45
guix/lint.scm
View file

@ -793,27 +793,32 @@ (define (warnings-for-uris uris)
(loop rest (cons warning warnings)))))))) (loop rest (cons warning warnings))))))))
(let ((origin (package-source package))) (let ((origin (package-source package)))
(if (and (origin? origin) (if (origin? origin)
(eqv? (origin-method origin) url-fetch)) (cond
(let* ((uris (append-map (cut maybe-expand-mirrors <> %mirrors) ((eq? (origin-method origin) url-fetch)
(map string->uri (origin-uris origin)))) (let* ((uris (append-map (cut maybe-expand-mirrors <> %mirrors)
(warnings (warnings-for-uris uris))) (map string->uri (origin-uris origin))))
(warnings (warnings-for-uris uris)))
;; Just make sure that at least one of the URIs is valid. ;; Just make sure that at least one of the URIs is valid.
(if (= (length uris) (length warnings)) (if (= (length uris) (length warnings))
;; When everything fails, report all of WARNINGS, otherwise don't ;; When everything fails, report all of WARNINGS, otherwise don't
;; report anything. ;; report anything.
;; ;;
;; XXX: Ideally we'd still allow warnings to be raised if *some* ;; XXX: Ideally we'd still allow warnings to be raised if *some*
;; URIs are unreachable, but distinguish that from the error case ;; URIs are unreachable, but distinguish that from the error case
;; where *all* the URIs are unreachable. ;; where *all* the URIs are unreachable.
(cons* (cons*
(make-warning package (make-warning package
(G_ "all the source URIs are unreachable:") (G_ "all the source URIs are unreachable:")
#:field 'source) #:field 'source)
warnings) 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) (define (check-source-file-name package)
"Emit a warning if PACKAGE's origin has no meaningful file name." "Emit a warning if PACKAGE's origin has no meaningful file name."

20
tests/lint.scm
View file

@ -697,6 +697,26 @@ (define (warning-contains? str warnings)
(and (? lint-warning?) second-warning)) (and (? lint-warning?) second-warning))
(lint-warning-message second-warning))))))))) (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-skip (if (http-server-can-listen?) 0 1))
(test-equal "source: 301 -> 404" (test-equal "source: 301 -> 404"
"URI http://localhost:10000/foo/bar not reachable: 404 (\"Such is life\")" "URI http://localhost:10000/foo/bar not reachable: 404 (\"Such is life\")"