[bug#50874] [PATCH] lint: Check if HTTPS version of HTTP URL exists.

[Xinglu Chen <public@yoctocell.xyz>]

* guix/lint.scm (check-if-https-uri-exists?): New procedure.
(check-home-page, check-source): Use it.
---
I don’t really know how to test this while making it future-proof, any
suggestions?

 guix/lint.scm | 41 ++++++++++++++++++++++++++++++++++++-----
 1 file changed, 36 insertions(+), 5 deletions(-)

diff --git a/guix/lint.scm b/guix/lint.scm
index 527fda165a..246a5ab9c8 100644
--- a/guix/lint.scm
+++ b/guix/lint.scm
@@ -875,17 +875,44 @@ (define (validate-uri uri package field)
       (else
        (error "internal linter error" status)))))
 
+(define (check-if-https-uri-exists? uri field package)
+  "Given a URI that uses HTTP, check whether a HTTPS version exists."
+  (guard (c ((http-get-error? c)
+             #f))
+    (catch #t
+      (lambda ()
+        (let* ((url (uri->string uri))
+               (https-url (string-append
+                           "https" (string-drop url (string-length "http"))))
+               (https-uri (string->uri https-url)))
+          (when (http-fetch/cached https-uri)
+            (make-warning package
+                          (G_ "HTTPS version is available for: ~a")
+                          (list url)
+                          #:field field))))
+      (match-lambda*
+        ((or ('gnutls-error _ ...) ('tls-certificate-error _ ...))
+         #f)
+        (args
+         (apply throw args))))))
+
 (define (check-home-page package)
   "Emit a warning if PACKAGE has an invalid 'home-page' field, or if that
 'home-page' is not reachable."
-  (let ((uri (and=> (package-home-page package) string->uri)))
+  (let* ((home-page (package-home-page package))
+         (uri (and=> home-page string->uri)))
     (cond
      ((uri? uri)
       (match (validate-uri uri package 'home-page)
         ((and (? lint-warning? warning) warning)
          (list warning))
-        (_ '())))
-     ((not (package-home-page package))
+        (_ (if (eq? (uri-scheme uri) 'http)
+               (match (check-if-https-uri-exists? uri 'home-page package)
+                 ((? lint-warning? warning)
+                  (list warning))
+                 (_ '()))
+               '()))))
+     ((not home-page)
       (if (or (string-contains (package-name package) "bootstrap")
               (string=? (package-name package) "ld-wrapper"))
           '()
@@ -1079,8 +1106,12 @@ (define (warnings-for-uris uris)
         ((uri rest ...)
          (match (validate-uri uri package 'source)
            (#t
-            ;; We found a working URL, so stop right away.
-            '())
+            (if (eq? (uri-scheme uri) 'http)
+               (match (check-if-https-uri-exists? uri 'source package)
+                 ((? lint-warning? warning)
+                  (list warning))
+                 (_ '()))
+               '()))
            (#f
             ;; Unsupported URL or other error, skip.
             (loop rest warnings))

base-commit: 009f0fc3dde0c2162c6df02fc4790a9f1d909e99
-- 
2.33.0