From 2766282f5a91f4a2739cfc3fce0dee7c7ec9e5cc Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Mon, 20 Aug 2018 15:11:14 +0200 Subject: import: github: Request API v3 in the 'Accept' header. * guix/import/json.scm (json-fetch): Add #:headers argument and honor it. * guix/import/github.scm (latest-released-version): Pass #:headers to 'json-fetch'. --- guix/import/github.scm | 9 +++++++-- guix/import/json.scm | 14 +++++++++----- 2 files changed, 16 insertions(+), 7 deletions(-) (limited to 'guix') diff --git a/guix/import/github.scm b/guix/import/github.scm index ef226911b9..d7a673e8d6 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 -;;; Copyright © 2017 Ludovic Courtès +;;; Copyright © 2017, 2018 Ludovic Courtès ;;; ;;; This file is part of GNU Guix. ;;; @@ -132,7 +132,12 @@ the package e.g. 'bedtools2'. Return #f if there is no releases" (json (json-fetch (if token (string-append api-url "?access_token=" token) - api-url)))) + api-url) + #:headers + ;; Ask for version 3 of the API as suggested at + ;; . + `((Accept . "application/vnd.github.v3+json") + (user-agent . "GNU Guile"))))) (if (eq? json #f) (if token (error "Error downloading release information through the GitHub 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 ;;; Copyright © 2015, 2016 Eric Bavier +;;; Copyright © 2018 Ludovic Courtès ;;; ;;; 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))) -- cgit v1.2.3 From 45c01189cca2c9c7852eb1bc24e3cd892906c912 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Mon, 20 Aug 2018 15:29:43 +0200 Subject: import: github: Get /tags when /releases returns the empty list. This allows "guix refresh" to work for many packages where it would previously fail with "no updater for PACKAGE". * guix/import/github.scm (fetch-releases-or-tags): New procedure. (latest-released-version): Use it instead of calling 'json-fetch'. Adjust 'hash-ref' call. --- guix/import/github.scm | 59 ++++++++++++++++++++++++++++++++++++-------------- 1 file changed, 43 insertions(+), 16 deletions(-) (limited to 'guix') diff --git a/guix/import/github.scm b/guix/import/github.scm index d7a673e8d6..d11f5fa31f 100644 --- a/guix/import/github.scm +++ b/guix/import/github.scm @@ -120,26 +120,52 @@ 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 + ;; . + `((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) - #:headers - ;; Ask for version 3 of the API as suggested at - ;; . - `((Accept . "application/vnd.github.v3+json") - (user-agent . "GNU Guile"))))) + (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 @@ -159,7 +185,8 @@ https://github.com/settings/tokens")) (() ;empty release list #f) ((release . rest) ;one or more releases - (let ((tag (hash-ref release "tag_name")) + (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 -- cgit v1.2.3 From bab4dc58f7278e481c7eb8c6f954d6f1751deb23 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Mon, 20 Aug 2018 16:31:32 +0200 Subject: import: github: Filter out tags that don't look like version numbers. * guix/import/github.scm (latest-released-version): Filter out RELEASE if it doesn't start with digit. --- guix/import/github.scm | 36 ++++++++++++++++++++++-------------- 1 file changed, 22 insertions(+), 14 deletions(-) (limited to 'guix') diff --git a/guix/import/github.scm b/guix/import/github.scm index d11f5fa31f..af9f56e1dc 100644 --- a/guix/import/github.scm +++ b/guix/import/github.scm @@ -172,19 +172,19 @@ API when using a GitHub token") 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 + ((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))) @@ -196,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 for the latest release of PKG." -- cgit v1.2.3 From dece8c91a954d17249eb9cfb48ae75fe131fe831 Mon Sep 17 00:00:00 2001 From: Pierre Neidhardt Date: Tue, 21 Aug 2018 16:27:03 +0200 Subject: build-system/asdf: Fix typo in "dependency". * guix/build-system/asdf.scm (default-lisp): Fix typo in "dependency". --- guix/build-system/asdf.scm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'guix') 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))) -- cgit v1.2.3 From a81b59b1bf99255cf78d736c3d2aa28eb1e9bbdf Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Tue, 21 Aug 2018 14:28:03 +0200 Subject: inferior: Adjust for Guile 2.0. Partly fixes . Reported by Michael Bowcutt . * guix/inferior.scm (open-inferior): Wrap 'setvbuf' call in 'cond-expand'. --- guix/inferior.scm | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) (limited to 'guix') 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)))) -- cgit v1.2.3