summaryrefslogtreecommitdiff
path: root/guix
diff options
context:
space:
mode:
authorLudovic Courtès <ludo@gnu.org>2021-06-24 14:01:53 +0200
committerLudovic Courtès <ludo@gnu.org>2021-06-24 23:40:48 +0200
commit8a81ae61c183085b3a1edc4572d721ac5b2a581c (patch)
tree9f8a705edb1c7cd1b968ac8d300f9c413a95ec71 /guix
parent468a5f8676c82e17de98d12077c671823177d944 (diff)
lint: 'github-url' checker gracefully handles networking errors.
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'.
Diffstat (limited to 'guix')
-rw-r--r--guix/lint.scm108
1 files changed, 55 insertions, 53 deletions
diff --git a/guix/lint.scm b/guix/lint.scm
index 36a672c081..70ed677a54 100644
--- a/guix/lint.scm
+++ b/guix/lint.scm
@@ -617,6 +617,51 @@ for connections to complete; when TIMEOUT is #f, wait as long as needed."
(_
(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,15 +1080,17 @@ descriptions maintained upstream."
(eqv? (origin-method origin) url-fetch))
(filter-map
(lambda (uri)
- (and=> (follow-redirects-to-github uri)
+ (and=> (with-networking-fail-safe
+ (format #f (G_ "while accessing '~a'") uri)
+ #f
+ (follow-redirects-to-github uri))
(lambda (github-uri)
- (if (string=? github-uri uri)
- #f
- (make-warning
- package
- (G_ "URL should be '~a'")
- (list github-uri)
- #:field 'source)))))
+ (and (not (string=? github-uri uri))
+ (make-warning
+ package
+ (G_ "URL should be '~a'")
+ (list github-uri)
+ #:field 'source)))))
(origin-uris origin))
'())))
@@ -1140,51 +1187,6 @@ of the propagated inputs it pulls in."
(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