ryan77627/guix
1
0
Fork 0
mirror of https://git.in.rschanz.org/ryan77627/guix.git synced 2024-12-26 14:28:15 -05:00
Code Issues Projects Releases Packages Wiki Activity Actions

lint: 'github-url' checker gracefully handles networking errors.

Browse source 
Fixes <https://bugs.gnu.org/49114>.
Reported by Tobias Geerinckx-Rice <me@tobias.gr>.

* guix/lint.scm (call-with-networking-fail-safe, with-networking-fail-safe):
Move higher in the file.
* guix/lint.scm (check-github-url): Wrap call to
'follow-redirects-to-github' in 'with-networking-fail-safe'.
This commit is contained in:
Ludovic Courtès 2021-06-24 14:01:53 +02:00
parent 468a5f8676
commit 8a81ae61c1
No known key found for this signature in database
GPG key ID: 090B11993D9AEBB5
1 changed files with 55 additions and 53 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

98
guix/lint.scm
View file

@ -617,6 +617,51 @@ (define response
(_
(values 'unknown-protocol #f)))))
(define (call-with-networking-fail-safe message error-value proc)
"Call PROC catching any network-related errors. Upon a networking error,
display a message including MESSAGE and return ERROR-VALUE."
(guard (c ((http-get-error? c)
(warning (G_ "~a: HTTP GET error for ~a: ~a (~s)~%")
message
(uri->string (http-get-error-uri c))
(http-get-error-code c)
(http-get-error-reason c))
error-value))
(catch #t
proc
(match-lambda*
(('getaddrinfo-error errcode)
(warning (G_ "~a: host lookup failure: ~a~%")
message
(gai-strerror errcode))
error-value)
(('tls-certificate-error args ...)
(warning (G_ "~a: TLS certificate error: ~a")
message
(tls-certificate-error-string args))
error-value)
(('gnutls-error error function _ ...)
(warning (G_ "~a: TLS error in '~a': ~a~%")
message
function (error->string error))
error-value)
((and ('system-error _ ...) args)
(let ((errno (system-error-errno args)))
(if (member errno (list ECONNRESET ECONNABORTED ECONNREFUSED))
(let ((details (call-with-output-string
(lambda (port)
(print-exception port #f (car args)
(cdr args))))))
(warning (G_ "~a: ~a~%") message details)
error-value)
(apply throw args))))
(args
(apply throw args))))))
(define-syntax-rule (with-networking-fail-safe message error-value exp ...)
(call-with-networking-fail-safe message error-value
(lambda () exp ...)))
(define (tls-certificate-error-string args)
"Return a string explaining the 'tls-certificate-error' arguments ARGS."
(call-with-output-string
@ -1035,10 +1080,12 @@ (define (follow-redirects-to-github uri)
(eqv? (origin-method origin) url-fetch))
(filter-map
(lambda (uri)
(and=> (follow-redirects-to-github uri)
(lambda (github-uri)
(if (string=? github-uri uri)
(and=> (with-networking-fail-safe
(format #f (G_ "while accessing '~a'") uri)
#f
(follow-redirects-to-github uri))
(lambda (github-uri)
(and (not (string=? github-uri uri))
(make-warning
package
(G_ "URL should be '~a'")
@ -1140,51 +1187,6 @@ (define (check-license package)
(make-warning package (G_ "invalid license field")
#:field 'license)))))
(define (call-with-networking-fail-safe message error-value proc)
"Call PROC catching any network-related errors. Upon a networking error,
display a message including MESSAGE and return ERROR-VALUE."
(guard (c ((http-get-error? c)
(warning (G_ "~a: HTTP GET error for ~a: ~a (~s)~%")
message
(uri->string (http-get-error-uri c))
(http-get-error-code c)
(http-get-error-reason c))
error-value))
(catch #t
proc
(match-lambda*
(('getaddrinfo-error errcode)
(warning (G_ "~a: host lookup failure: ~a~%")
message
(gai-strerror errcode))
error-value)
(('tls-certificate-error args ...)
(warning (G_ "~a: TLS certificate error: ~a")
message
(tls-certificate-error-string args))
error-value)
(('gnutls-error error function _ ...)
(warning (G_ "~a: TLS error in '~a': ~a~%")
message
function (error->string error))
error-value)
((and ('system-error _ ...) args)
(let ((errno (system-error-errno args)))
(if (member errno (list ECONNRESET ECONNABORTED ECONNREFUSED))
(let ((details (call-with-output-string
(lambda (port)
(print-exception port #f (car args)
(cdr args))))))
(warning (G_ "~a: ~a~%") message details)
error-value)
(apply throw args))))
(args
(apply throw args))))))
(define-syntax-rule (with-networking-fail-safe message error-value exp ...)
(call-with-networking-fail-safe message error-value
(lambda () exp ...)))
(define (current-vulnerabilities*)
"Like 'current-vulnerabilities', but return the empty list upon networking
or HTTP errors. This allows network-less operation and makes problems with