diff options
| author | Ludovic Courtès <ludo@gnu.org> | 2016-11-09 16:27:29 +0100 |
|---|---|---|
| committer | Ludovic Courtès <ludo@gnu.org> | 2016-11-09 21:24:44 +0100 |
| commit | c169d91e5a0be92b6bd48a8fd98c43078d2a12ef (patch) | |
| tree | 36378c2cf980be7a15294644908636c9ebc52c0a | |
| parent | 8bb115e0c6673143f174e88df43594077979945b (diff) | |
| download | gnu-guix-c169d91e5a0be92b6bd48a8fd98c43078d2a12ef.tar gnu-guix-c169d91e5a0be92b6bd48a8fd98c43078d2a12ef.tar.gz | |
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.
| -rw-r--r-- | guix/scripts/lint.scm | 36 |
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 |