diff options
| -rw-r--r-- | guix/import/github.scm | 116 |
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." |