lint: 'cve' checker catches 'tls-certificate-error'.

Reported by Frederick Muriithi <fredmanglis@gmail.com>.

* guix/scripts/lint.scm (tls-certificate-error-string): New procedure.
(validate-uri): Use it.
(current-vulnerabilities*): Catch 'tls-certificate-error' and print a
warning.

1 files changed, 23 insertions, 13 deletions

diff --git a/guix/scripts/lint.scm b/guix/scripts/lint.scm
index 049c297224..6e6f550941 100644
--- a/guix/scripts/lint.scm
+++ b/guix/scripts/lint.scm
@@ -398,6 +398,13 @@ for connections to complete; when TIMEOUT is #f, wait as long as needed."
       (_
        (values 'unknown-protocol #f)))))
 
+(define (tls-certificate-error-string args)
+  "Return a string explaining the 'tls-certificate-error' arguments ARGS."
+  (call-with-output-string
+    (lambda (port)
+      (print-exception port #f
+                       'tls-certificate-error args))))
+
 (define (validate-uri uri package field)
   "Return #t if the given URI can be reached, otherwise return #f and emit a
 warning for PACKAGE mentionning the FIELD."
@@ -460,13 +467,8 @@ suspiciously small file (~a bytes)")
        #f)
       ((tls-certificate-error)
        (emit-warning package
-                     (format #f
-                             (_ "TLS certificate error: ~a")
-                             (call-with-output-string
-                               (lambda (port)
-                                 (print-exception port #f
-                                                  'tls-certificate-error
-                                                  argument))))))
+                     (format #f (_ "TLS certificate error: ~a")
+                             (tls-certificate-error-string argument))))
       ((invalid-http-response gnutls-error)
        ;; Probably a misbehaving server; ignore.
        #f)
@@ -682,14 +684,22 @@ from ~s: ~a (~s)~%")
                       (http-get-error-reason c))
              (warning (_ "assuming no CVE vulnerabilities~%"))
              '()))
-    (catch 'getaddrinfo-error
+    (catch #t
       (lambda ()
         (current-vulnerabilities))
-      (lambda (key errcode)
-        (warning (_ "failed to lookup NIST host: ~a~%")
-                 (gai-strerror errcode))
-        (warning (_ "assuming no CVE vulnerabilities~%"))
-        '()))))
+      (match-lambda*
+        (('getaddrinfo-error errcode)
+         (warning (_ "failed to lookup NIST host: ~a~%")
+                  (gai-strerror errcode))
+         (warning (_ "assuming no CVE vulnerabilities~%"))
+         '())
+        (('tls-certificate-error args ...)
+         (warning (_ "TLS certificate error: ~a")
+                  (tls-certificate-error-string args))
+         (warning (_ "assuming no CVE vulnerabilities~%"))
+         '())
+        (args
+         (apply throw args))))))
 
 (define package-vulnerabilities
   (let ((lookup (delay (vulnerabilities->lookup-proc