;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2016 Ben Woodcroft <donttrustben@gmail.com>
+;;; Copyright © 2017, 2018 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2018 Eric Bavier <bavier@member.fsf.org>
+;;; Copyright © 2019 Arun Isaac <arunisaac@systemreboot.net>
;;;
;;; This file is part of GNU Guix.
;;;
(define-module (guix import github)
#:use-module (ice-9 match)
#:use-module (srfi srfi-1)
- #:use-module (json)
+ #:use-module (srfi srfi-26)
+ #:use-module (srfi srfi-34)
#:use-module (guix utils)
#: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 (guix packages)
#:use-module (guix upstream)
- #:use-module (gnu packages)
+ #:use-module (guix http-client)
#:use-module (web uri)
#:export (%github-updater))
-(define (json-fetch* url)
- "Return a list/hash representation of the JSON resource URL, or #f on
-failure."
- (call-with-output-file "/dev/null"
- (lambda (null)
- (with-error-to-port null
- (lambda ()
- (call-with-temporary-output-file
- (lambda (temp port)
- (and (url-fetch url temp)
- (call-with-input-file temp json->scm)))))))))
-
(define (find-extension url)
"Return the extension of the archive e.g. '.tar.gz' given a URL, or
false if none is recognized"
- (find (lambda x (string-suffix? (first x) url))
- (list ".tar.gz" ".tar.bz2" ".tar.xz" ".zip" ".tar")))
+ (find (lambda (x) (string-suffix? x url))
+ (list ".tar.gz" ".tar.bz2" ".tar.xz" ".zip" ".tar"
+ ".tgz" ".tbz" ".love")))
(define (updated-github-url old-package new-version)
;; Return a url for the OLD-PACKAGE with NEW-VERSION. If no source url in
(define (updated-url url)
(if (string-prefix? "https://github.com/" url)
- (let ((ext (find-extension url))
+ (let ((ext (or (find-extension url) ""))
(name (package-name old-package))
(version (package-version old-package))
(prefix (string-append "https://github.com/"
(#t #f))) ; Some URLs are not recognised.
#f))
- (let ((source-url (and=> (package-source old-package) origin-uri))
+ (let ((source-uri (and=> (package-source old-package) origin-uri))
(fetch-method (and=> (package-source old-package) origin-method)))
- (if (eq? fetch-method download:url-fetch)
- (match source-url
- ((? string?)
- (updated-url source-url))
- ((source-url ...)
- (find updated-url source-url)))
- #f)))
+ (cond
+ ((eq? fetch-method download:url-fetch)
+ (match source-uri
+ ((? string?)
+ (updated-url source-uri))
+ ((source-uri ...)
+ (find updated-url source-uri))))
+ ((and (eq? fetch-method download:git-fetch)
+ (string-prefix? "https://github.com/"
+ (download:git-reference-url source-uri)))
+ (download:git-reference-url source-uri))
+ (else #f))))
(define (github-package? package)
"Return true if PACKAGE is a package from GitHub, else false."
- (not (eq? #f (updated-github-url package "dummy"))))
+ (->bool (updated-github-url package "dummy")))
(define (github-repository url)
"Return a string e.g. bedtools2 of the name of the repository, from a string
URL of the form 'https://github.com/arq5x/bedtools2/archive/v2.24.0.tar.gz'"
(match (string-split (uri-path (string->uri url)) #\/)
((_ owner project . rest)
- (string-append project))))
+ (string-append (basename project ".git")))))
(define (github-user-slash-repository url)
"Return a string e.g. arq5x/bedtools2 of the owner and the name of the
'https://github.com/arq5x/bedtools2/archive/v2.24.0.tar.gz'"
(match (string-split (uri-path (string->uri url)) #\/)
((_ owner project . rest)
- (string-append owner "/" project))))
+ (string-append owner "/" (basename project ".git")))))
(define %github-token
;; Token to be passed to Github.com to avoid the 60-request per hour
;; 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))))
+ (define (pre-release? x)
+ (hash-ref x "prerelease"))
+
+ (define (release->version release)
+ (let ((tag (or (hash-ref release "tag_name") ;a "release"
+ (hash-ref release "name"))) ;a tag
+ (name-length (string-length package-name)))
+ (cond
+ ;; some tags include the name of the package e.g. "fdupes-1.51"
+ ;; so remove these
+ ((and (< name-length (string-length tag))
+ (string=? (string-append package-name "-")
+ (substring tag 0 (+ name-length 1))))
+ (substring tag (+ name-length 1)))
+ ;; some tags start with a "v" e.g. "v0.25.0"
+ ;; where some are just the version number
+ ((string-prefix? "v" tag)
+ (substring tag 1))
+ ;; Finally, reject tags that don't start with a digit:
+ ;; they may not represent a release.
+ ((and (not (string-null? tag))
+ (char-set-contains? char-set:digit
+ (string-ref tag 0)))
+ tag)
+ (else #f))))
+
+ (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
- #f)
- ((release . rest) ;one or more releases
- (let ((tag (hash-ref release "tag_name"))
- (name-length (string-length package-name)))
- ;; some tags include the name of the package e.g. "fdupes-1.51"
- ;; so remove these
- (if (and (< name-length (string-length tag))
- (string=? (string-append package-name "-")
- (substring tag 0 (+ name-length 1))))
- (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)))))))))
-
-(define (latest-release guix-package)
- "Return an <upstream-source> for the latest release of GUIX-PACKAGE."
- (let* ((pkg (specification->package guix-package))
- (source-uri (origin-uri (package-source pkg)))
+ (match (sort (filter-map release->version
+ (match (remove pre-release? json)
+ (() json) ; keep everything
+ (releases releases)))
+ version>?)
+ ((latest-release . _) latest-release)
+ (() #f)))))
+
+(define (latest-release pkg)
+ "Return an <upstream-source> for the latest release of PKG."
+ (define (origin-github-uri origin)
+ (match (origin-uri origin)
+ ((? string? url)
+ url) ;surely a github.com URL
+ ((? download:git-reference? ref)
+ (download:git-reference-url ref))
+ ((urls ...)
+ (find (cut string-contains <> "github.com") urls))))
+
+ (let* ((source-uri (origin-github-uri (package-source pkg)))
(name (package-name pkg))
(newest-version (latest-released-version source-uri name)))
(if newest-version
(upstream-source
- (package pkg)
+ (package name)
(version newest-version)
(urls (list (updated-github-url pkg newest-version))))
#f))) ; On GitHub but no proper releases
HCoop / jackhill / guix / guix.git / blobdiff