lint: 'check-github-url' uses our own 'open-connection-for-uri'.

Fixes <https://bugs.gnu.org/35053>.
Reported by Efraim Flashner <efraim@flashner.co.il>.

Previously 'check-github-url' would let Guile 2.2's (web client) module
take care of opening the connection.  Consequently, it wouldn't use the
TLS priority strings that we use in (guix build download),
'open-connection-for-uri'.  In particular, it would not disable TLSv1.3,
which would trigger <https://bugs.gnu.org/34102> for github.com.

* guix/scripts/lint.scm (check-github-url): Add #:timeout parameter.
[follow-redirect]: Change parameter name to 'url' and pass it to
'string->uri'.  Call 'guix:open-connection-for-uri' to open the
connection and pass it to 'http-head' via #:port.
This commit is contained in:
Ludovic Courtès 2019-04-18 10:19:54 +02:00
parent bd5b6ce0d7
commit 702c3c7dab
No known key found for this signature in database
GPG key ID: 090B11993D9AEBB5

View file

@ -45,7 +45,6 @@ (define-module (guix scripts lint)
#:use-module (guix cve)
#:use-module (gnu packages)
#:use-module (ice-9 match)
#:use-module (ice-9 receive)
#:use-module (ice-9 regex)
#:use-module (ice-9 format)
#:use-module (web client)
@ -796,10 +795,13 @@ (define (check-mirror-uri uri) ;XXX: could be optimized
(let ((uris (origin-uris origin)))
(for-each check-mirror-uri uris)))))
(define (check-github-url package)
(define* (check-github-url package #:key (timeout 3))
"Check whether PACKAGE uses source URLs that redirect to GitHub."
(define (follow-redirect uri)
(receive (response body) (http-head uri)
(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)))