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.
master
Ludovic Courtès 2016-11-09 16:27:29 +01:00
parent 8bb115e0c6
commit c169d91e5a
No known key found for this signature in database
GPG Key ID: 090B11993D9AEBB5
1 changed files with 23 additions and 13 deletions

View File

@ -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