Merge branch 'master' into staging

4 files changed, 80 insertions, 33 deletions

diff --git a/guix/build-system/asdf.scm b/guix/build-system/asdf.scm
index ab0ae57c6e..57e294d74d 100644
--- a/guix/build-system/asdf.scm
+++ b/guix/build-system/asdf.scm
@@ -62,7 +62,7 @@
 
 (define (default-lisp implementation)
   "Return the default package for the lisp IMPLEMENTATION."
-  ;; Lazily resolve the binding to avoid a circular dependancy.
+  ;; Lazily resolve the binding to avoid a circular dependency.
   (let ((lisp-module (resolve-interface '(gnu packages lisp))))
     (module-ref lisp-module implementation)))
 
diff --git a/guix/import/github.scm b/guix/import/github.scm
index ef226911b9..af9f56e1dc 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 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2017, 2018 Ludovic Courtès <ludo@gnu.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -120,41 +120,73 @@ repository separated by a forward slash, from a string URL of the form
   ;; limit, or #f.
   (make-parameter (getenv "GUIX_GITHUB_TOKEN")))
 
+(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 (hash tables),
+or #f if the information could not be retrieved.
+
+We look at both /releases and /tags because the \"release\" feature of GitHub
+is little used; often, people simply provide a tag.  What's confusing is that
+tags show up in the \"Releases\" tab of the web UI.  For instance,
+'https://github.com/aconchillo/guile-json/releases' shows a number of
+\"releases\" (really: tags), whereas
+'https://api.github.com/repos/aconchillo/guile-json/releases' returns the
+empty list."
+  (define release-url
+    (string-append "https://api.github.com/repos/"
+                   (github-user-slash-repository url)
+                   "/releases"))
+  (define tag-url
+    (string-append "https://api.github.com/repos/"
+                   (github-user-slash-repository url)
+                   "/tags"))
+
+  (define headers
+    ;; Ask for version 3 of the API as suggested at
+    ;; <https://developer.github.com/v3/>.
+    `((Accept . "application/vnd.github.v3+json")
+      (user-agent . "GNU Guile")))
+
+  (define (decorate url)
+    (if (%github-token)
+        (string-append url "?access_token=" (%github-token))
+        url))
+
+  (match (json-fetch (decorate release-url) #:headers headers)
+    (()
+     ;; 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 (decorate tag-url) #:headers headers))
+    (x x)))
+
 (define (latest-released-version url package-name)
   "Return a string of the newest released version name given a string URL like
 'https://github.com/arq5x/bedtools2/archive/v2.24.0.tar.gz' and the name of
 the package e.g. 'bedtools2'.  Return #f if there is no releases"
-  (let* ((token (%github-token))
-         (api-url (string-append
-                   "https://api.github.com/repos/"
-                   (github-user-slash-repository url)
-                   "/releases"))
-         (json (json-fetch
-                (if token
-                    (string-append api-url "?access_token=" token)
-                    api-url))))
+  (let* ((json (fetch-releases-or-tags url)))
     (if (eq? json #f)
-        (if token
+        (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"))
-        (let ((proper-releases
-               (filter
-                (lambda (x)
-                  ;; example pre-release:
-                  ;; https://github.com/wwood/OrfM/releases/tag/v0.5.1
-                  ;; or an all-prerelease set
-                  ;; https://github.com/powertab/powertabeditor/releases
-                  (not (hash-ref x "prerelease")))
-                json)))
-          (match proper-releases
-            (()                       ;empty release list
+        (let loop ((releases
+                    (filter
+                     (lambda (x)
+                       ;; example pre-release:
+                       ;; https://github.com/wwood/OrfM/releases/tag/v0.5.1
+                       ;; or an all-prerelease set
+                       ;; https://github.com/powertab/powertabeditor/releases
+                       (not (hash-ref x "prerelease")))
+                     json)))
+          (match releases
+            (()                                   ;empty release list
              #f)
-            ((release . rest)         ;one or more releases
-             (let ((tag (hash-ref release "tag_name"))
+            ((release . rest)                     ;one or more releases
+             (let ((tag (or (hash-ref release "tag_name") ;a "release"
+                            (hash-ref release "name")))   ;a tag
                    (name-length (string-length package-name)))
                ;; some tags include the name of the package e.g. "fdupes-1.51"
                ;; so remove these
@@ -164,8 +196,16 @@ https://github.com/settings/tokens"))
                    (substring tag (+ name-length 1))
                    ;; some tags start with a "v" e.g. "v0.25.0"
                    ;; where some are just the version number
-                   (if (eq? (string-ref tag 0) #\v)
-                       (substring tag 1) tag)))))))))
+                   (if (string-prefix? "v" tag)
+                       (substring tag 1)
+
+                       ;; Finally, reject tags that don't start with a digit:
+                       ;; they may not represent a release.
+                       (if (and (not (string-null? tag))
+                                (char-set-contains? char-set:digit
+                                                    (string-ref tag 0)))
+                           tag
+                           (loop rest)))))))))))
 
 (define (latest-release pkg)
   "Return an <upstream-source> for the latest release of PKG."
diff --git a/guix/import/json.scm b/guix/import/json.scm
index 3f2ab1e3ea..4f96a513df 100644
--- a/guix/import/json.scm
+++ b/guix/import/json.scm
@@ -1,6 +1,7 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2014 David Thompson <davet@gnu.org>
 ;;; Copyright © 2015, 2016 Eric Bavier <bavier@member.fsf.org>
+;;; Copyright © 2018 Ludovic Courtès <ludo@gnu.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -25,17 +26,20 @@
   #:export (json-fetch
             json-fetch-alist))
 
-(define (json-fetch url)
+(define* (json-fetch url
+                     ;; Note: many websites returns 403 if we omit a
+                     ;; 'User-Agent' header.
+                     #:key (headers `((user-agent . "GNU Guile")
+                                      (Accept . "application/json"))))
   "Return a representation of the JSON resource URL (a list or hash table), or
-#f if URL returns 403 or 404."
+#f if URL returns 403 or 404.  HEADERS is a list of HTTP headers to pass in
+the query."
   (guard (c ((and (http-get-error? c)
                   (let ((error (http-get-error-code c)))
                     (or (= 403 error)
                         (= 404 error))))
              #f))
-    ;; Note: many websites returns 403 if we omit a 'User-Agent' header.
-    (let* ((port   (http-fetch url #:headers '((user-agent . "GNU Guile")
-                                               (Accept . "application/json"))))
+    (let* ((port   (http-fetch url #:headers headers))
            (result (json->scm port)))
       (close-port port)
       result)))
diff --git a/guix/inferior.scm b/guix/inferior.scm
index 629c2c4313..05c8d65deb 100644
--- a/guix/inferior.scm
+++ b/guix/inferior.scm
@@ -87,7 +87,10 @@ equivalent.  Return #f if the inferior could not be launched."
   (define pipe
     (inferior-pipe directory command))
 
-  (setvbuf pipe _IOLBF)
+  (cond-expand
+    ((and guile-2 (not guile-2.2)) #t)
+    (else (setvbuf pipe 'line)))
+
   (match (read pipe)
     (('repl-version 0 rest ...)
      (let ((result (inferior 'pipe pipe (cons 0 rest))))