diff options
| author | Ludovic Courtès <ludo@gnu.org> | 2019-04-18 10:19:54 +0200 |
|---|---|---|
| committer | Ludovic Courtès <ludo@gnu.org> | 2019-04-18 17:43:56 +0200 |
| commit | 702c3c7dab87df674c3d6abc138805895b5d1d32 (patch) | |
| tree | e1a000929a0d529a5d70bacfaf54cc64cc43fd73 | |
| parent | bd5b6ce0d7562a669d24f710fe62adcd0b8bf67a (diff) | |
| download | guix-702c3c7dab87df674c3d6abc138805895b5d1d32.tar guix-702c3c7dab87df674c3d6abc138805895b5d1d32.tar.gz | |
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.
| -rw-r--r-- | guix/scripts/lint.scm | 10 |
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))) |