summaryrefslogtreecommitdiff
path: root/guix/import
diff options
context:
space:
mode:
authorLudovic Courtès <ludo@gnu.org>2022-03-03 17:35:21 +0100
committerLudovic Courtès <ludo@gnu.org>2022-03-06 22:49:47 +0100
commit55e8e283ae398cc476e50e822383797c5f43db4c (patch)
treed2d6b3b5b660dcd9e54684cf5ca5b2b4aa7f250f /guix/import
parentecad9b221364c5c941385eaac3a652e2bd42d1ac (diff)
import: github: Gracefully handle rate limit exhaustion.
Previously, 'guix refresh' would literally crash when the rate limit was reached due to the call to 'error'. With this change, the updater notices when the rate limit is reached and it turns itself into a no-op until the rate limit has been reset. When running "guix refresh" (with no arguments), the 'github' updater gets used until the rate limit has been reached, after which "guix refresh" automatically picks up the next valid updater, typically 'generic-git'. * guix/import/github.scm (fetch-releases-or-tags): Use 'http-fetch' directly instead of 'json-fetch' to let 'http-get-error?' exceptions through. Handle 403 errors with an 'X-RateLimit-Remaining' header. (%rate-limit-reset-time): New variable. (update-rate-limit-reset-time!, request-rate-limit-reached?): New procedures. (latest-released-version): Remove calls to 'error'.
Diffstat (limited to 'guix/import')
-rw-r--r--guix/import/github.scm116
1 files changed, 83 insertions, 33 deletions
diff --git a/guix/import/github.scm b/guix/import/github.scm
index 8c1898c0c5..f3a1b1c5c4 100644
--- a/guix/import/github.scm
+++ b/guix/import/github.scm
@@ -1,6 +1,6 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2016 Ben Woodcroft <donttrustben@gmail.com>
-;;; Copyright © 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2017-2020, 2022 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2018 Eric Bavier <bavier@member.fsf.org>
;;; Copyright © 2019 Arun Isaac <arunisaac@systemreboot.net>
;;; Copyright © 2019 Efraim Flashner <efraim@flashner.co.il>
@@ -30,15 +30,16 @@
#:use-module (guix utils)
#:use-module (guix i18n)
#:use-module (guix diagnostics)
+ #:use-module ((guix ui) #:select (display-hint))
#:use-module ((guix download) #:prefix download:)
#:use-module ((guix git-download) #:prefix download:)
#:use-module (guix import utils)
- #:use-module (guix import json)
#:use-module (json)
#:use-module (guix packages)
#:use-module (guix upstream)
#:use-module (guix http-client)
#:use-module (web uri)
+ #:use-module (web response)
#:export (%github-api %github-updater))
;; For tests.
@@ -140,6 +141,33 @@ repository separated by a forward slash, from a string URL of the form
;; limit, or #f.
(make-parameter (getenv "GUIX_GITHUB_TOKEN")))
+(define %rate-limit-reset-time
+ ;; Time (seconds since the Epoch, UTC) when the rate limit for GitHub
+ ;; requests will be reset, or #f if the rate limit hasn't been reached.
+ #f)
+
+(define (update-rate-limit-reset-time! headers)
+ "Update the rate limit reset time based on HEADERS, the HTTP response
+headers."
+ (match (assq-ref headers 'x-ratelimit-reset)
+ ((= string->number (? number? reset))
+ (set! %rate-limit-reset-time reset)
+ reset)
+ (_
+ ;; This shouldn't happen.
+ (warning
+ (G_ "GitHub HTTP response lacks 'X-RateLimit-Reset' header~%"))
+ 0)))
+
+(define (request-rate-limit-reached?)
+ "Return true if the rate limit has been reached."
+ (and %rate-limit-reset-time
+ (match (< (car (gettimeofday)) %rate-limit-reset-time)
+ (#t #t)
+ (#f
+ (set! %rate-limit-reset-time #f)
+ #f))))
+
(define (fetch-releases-or-tags url)
"Fetch the list of \"releases\" or, if it's empty, the list of tags for the
repository at URL. Return the corresponding JSON dictionaries (alists),
@@ -170,20 +198,49 @@ empty list."
`((Authorization . ,(string-append "token " (%github-token))))
'())))
- (guard (c ((and (http-get-error? c)
- (= 404 (http-get-error-code c)))
- (warning (G_ "~a is unreachable (~a)~%")
- release-url (http-get-error-code c))
- '#())) ;return an empty release set
- (let* ((port (http-fetch release-url #:headers headers))
- (result (json->scm port)))
- (close-port port)
- (match result
- (#()
- ;; We got the empty list, presumably because the user didn't use GitHub's
- ;; "release" mechanism, but hopefully they did use Git tags.
- (json-fetch tag-url #:headers headers))
- (x x)))))
+ (and (not (request-rate-limit-reached?))
+ (guard (c ((and (http-get-error? c)
+ (= 404 (http-get-error-code c)))
+ (warning (G_ "~a is unreachable (~a)~%")
+ (uri->string (http-get-error-uri c))
+ (http-get-error-code c))
+ '#()) ;return an empty release set
+ ((and (http-get-error? c)
+ (= 403 (http-get-error-code c)))
+ ;; See
+ ;; <https://docs.github.com/en/rest/overview/resources-in-the-rest-api#rate-limiting>.
+ (match (assq-ref (http-get-error-headers c)
+ 'x-ratelimit-remaining)
+ (#f
+ (raise c))
+ ((? (compose zero? string->number))
+ (let ((reset (update-rate-limit-reset-time!
+ (http-get-error-headers c))))
+ (warning (G_ "GitHub rate limit exceeded; \
+disallowing requests for ~a seconds~%")
+ (- reset (car (gettimeofday))))
+ (display-hint (G_ "You can raise the rate limit by
+setting the @env{GUIX_GITHUB_TOKEN} environment variable to a token obtained
+from @url{https://github.com/settings/tokens} with your GitHub account.
+
+Alternatively, you can wait until your rate limit is reset, or use the
+@code{generic-git} updater instead."))
+ #f)) ;bail out
+ (_
+ (raise c)))))
+
+ (let* ((port (http-fetch release-url #:headers headers))
+ (result (json->scm port)))
+ (close-port port)
+ (match result
+ (#()
+ ;; We got the empty list, presumably because the user didn't use GitHub's
+ ;; "release" mechanism, but hopefully they did use Git tags.
+ (let* ((port (http-fetch tag-url #:headers headers))
+ (json (json->scm port)))
+ (close-port port)
+ json))
+ (x x))))))
(define (latest-released-version url package-name)
"Return the newest released version and its tag given a string URL like
@@ -223,23 +280,16 @@ releases."
(cons tag tag))
(else #f))))
- (let* ((json (and=> (fetch-releases-or-tags url)
- vector->list)))
- (if (eq? json #f)
- (if (%github-token)
- (error "Error downloading release information through the GitHub
-API when using a GitHub token")
- (error "Error downloading release information through the GitHub
-API. This may be fixed by using an access token and setting the environment
-variable GUIX_GITHUB_TOKEN, for instance one procured from
-https://github.com/settings/tokens"))
- (match (sort (filter-map release->version
- (match (remove pre-release? json)
- (() json) ; keep everything
- (releases releases)))
- (lambda (x y) (version>? (car x) (car y))))
- (((latest-version . tag) . _) (values latest-version tag))
- (() (values #f #f))))))
+ (match (and=> (fetch-releases-or-tags url) vector->list)
+ (#f (values #f #f))
+ (json
+ (match (sort (filter-map release->version
+ (match (remove pre-release? json)
+ (() json) ; keep everything
+ (releases releases)))
+ (lambda (x y) (version>? (car x) (car y))))
+ (((latest-version . tag) . _) (values latest-version tag))
+ (() (values #f #f))))))
(define (latest-release pkg)
"Return an <upstream-source> for the latest release of PKG."