summaryrefslogtreecommitdiff
path: root/guix
diff options
context:
space:
mode:
authorLudovic Courtès <ludo@gnu.org>2019-04-18 10:19:54 +0200
committerLudovic Courtès <ludo@gnu.org>2019-04-18 17:43:56 +0200
commit702c3c7dab87df674c3d6abc138805895b5d1d32 (patch)
treee1a000929a0d529a5d70bacfaf54cc64cc43fd73 /guix
parentbd5b6ce0d7562a669d24f710fe62adcd0b8bf67a (diff)
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.
Diffstat (limited to 'guix')
-rw-r--r--guix/scripts/lint.scm10
1 files 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)))