diff options
Diffstat (limited to 'guix')
| -rw-r--r-- | guix/build-system/asdf.scm | 2 | ||||
| -rw-r--r-- | guix/import/github.scm | 92 | ||||
| -rw-r--r-- | guix/import/json.scm | 14 | ||||
| -rw-r--r-- | guix/inferior.scm | 5 |
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)))) |