From 8a81ae61c183085b3a1edc4572d721ac5b2a581c Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 24 Jun 2021 14:01:53 +0200 Subject: lint: 'github-url' checker gracefully handles networking errors. Fixes . Reported by Tobias Geerinckx-Rice . * 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'. --- guix/lint.scm | 108 ++++++++++++++++++++++++++++++---------------------------- 1 file changed, 55 insertions(+), 53 deletions(-) (limited to 'guix') 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 @@ (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,15 +1080,17 @@ (define (follow-redirects-to-github uri) (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 @@ (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 -- cgit v1.2.3