05/06: lint: 'cve' checker catches 'tls-certificate-error'.

[Ludovic Courtès]

civodul pushed a commit to branch master
in repository guix.

commit c169d91e5a0be92b6bd48a8fd98c43078d2a12ef
Author: Ludovic Courtès <address@hidden>
Date:   Wed Nov 9 16:27:29 2016 +0100

    lint: 'cve' checker catches 'tls-certificate-error'.
    
    Reported by Frederick Muriithi <address@hidden>.
    
    * guix/scripts/lint.scm (tls-certificate-error-string): New procedure.
    (validate-uri): Use it.
    (current-vulnerabilities*): Catch 'tls-certificate-error' and print a
    warning.
---
 guix/scripts/lint.scm |   36 +++++++++++++++++++++++-------------
 1 file changed, 23 insertions(+), 13 deletions(-)

diff --git a/guix/scripts/lint.scm b/guix/scripts/lint.scm
index 049c297..6e6f550 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