From 702c3c7dab87df674c3d6abc138805895b5d1d32 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Thu, 18 Apr 2019 10:19:54 +0200 Subject: lint: 'check-github-url' uses our own 'open-connection-for-uri'. Fixes . Reported by Efraim Flashner . 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 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. --- guix/scripts/lint.scm | 10 ++++++---- 1 file changed, 6 insertions(+), 4 deletions(-) diff --git a/guix/scripts/lint.scm b/guix/scripts/lint.scm index ddad5b7fd0..dc338a1d7b 100644 --- a/guix/scripts/lint.scm +++ b/guix/scripts/lint.scm @@ -45,7 +45,6 @@ #: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 @@ descriptions maintained upstream." (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))) -- cgit v1.2.3