summaryrefslogtreecommitdiff
path: root/guix/scripts/lint.scm
diff options
context:
space:
mode:
authorLudovic Courtès <ludo@gnu.org>2016-11-09 16:27:29 +0100
committerLudovic Courtès <ludo@gnu.org>2016-11-09 21:24:44 +0100
commitc169d91e5a0be92b6bd48a8fd98c43078d2a12ef (patch)
tree36378c2cf980be7a15294644908636c9ebc52c0a /guix/scripts/lint.scm
parent8bb115e0c6673143f174e88df43594077979945b (diff)
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.
Diffstat (limited to 'guix/scripts/lint.scm')
-rw-r--r--guix/scripts/lint.scm36
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