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

[guix-commits]

civodul pushed a commit to branch master
in repository guix.

commit 702c3c7dab87df674c3d6abc138805895b5d1d32
Author: Ludovic Courtès <address@hidden>
Date:   Thu Apr 18 10:19:54 2019 +0200

    lint: 'check-github-url' uses our own 'open-connection-for-uri'.
    
    Fixes <https://bugs.gnu.org/35053>.
    Reported by Efraim Flashner <address@hidden>.
    
    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.
---
 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 ddad5b7..dc338a1 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)))