nixo
/
guix-devel
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

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.
This commit is contained in:
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
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

36
guix/scripts/lint.scm
View File

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