From cf1f08ba8f4c9866ab0077cc50941133ba4ff77b Mon Sep 17 00:00:00 2001 Message-Id: From: Xinglu Chen Date: Fri, 17 Dec 2021 21:32:51 +0100 Subject: [PATCH] lint: Fix handling of HTTP errors. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit The 'catch' call would wrap the '&http-get-error' error in an '%exception' meaning that the 'guard' form would never catch a '&http-get-error'. It seems that the throw/catch system doesn't play nicely with the raise/guard system. * guix/lint.scm (call-with-networking-fail-safe): Add pattern to match '&http-get-error'; handle GitHub rate limit error; remove 'guard' form. Fixes: --- guix/lint.scm | 80 ++++++++++++++++++++++++++++----------------------- 1 file changed, 44 insertions(+), 36 deletions(-) diff --git a/guix/lint.scm b/guix/lint.scm index 403f343b6c..67b2bb7221 100644 --- a/guix/lint.scm +++ b/guix/lint.scm @@ -801,43 +801,51 @@ (define response (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~%") + (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)))) + ((and ('%exception exception) + (http-get-error? exception)) + (cond + ((and (string-contains (uri->string (http-get-error-uri exception)) + "api.github.com") + (string=? (http-get-error-reason exception) + "rate limit exceeded")) + (warning (G_ "GitHub rate limit exceeded"))) + (else + (warning (G_ "~a: HTTP GET error for ~a: ~a (~s)~%") 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)))))) + (uri->string (http-get-error-uri exception)) + (http-get-error-code exception) + (http-get-error-reason exception)))) + error-value) + (args + (apply throw args))))) (define-syntax-rule (with-networking-fail-safe message error-value exp ...) (call-with-networking-fail-safe message error-value base-commit: 6718fe7e872e78f8f15dd596fcf15c594a039bfe -- 2.33.1