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'.

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."