mirror of
https://git.in.rschanz.org/ryan77627/guix.git
synced 2024-12-24 21:38:07 -05:00
import: Add github-updater.
* guix/import/github.scm: New file. * guix/scripts/refresh.scm (%updaters): Add %GITHUB-UPDATER. * doc/guix.texi (Invoking guix refresh): Mention it. * Makefile.am (MODULES): Add gnu/import/github.scm.
This commit is contained in:
parent
22572d56cb
commit
917a2a58ec
4 changed files with 216 additions and 1 deletions
|
@ -109,6 +109,7 @@ MODULES = \
|
|||
guix/import/cran.scm \
|
||||
guix/import/hackage.scm \
|
||||
guix/import/elpa.scm \
|
||||
guix/import/github.scm \
|
||||
guix/scripts.scm \
|
||||
guix/scripts/download.scm \
|
||||
guix/scripts/build.scm \
|
||||
|
|
|
@ -17,6 +17,7 @@ Copyright @copyright{} 2015 Mathieu Lirzin@*
|
|||
Copyright @copyright{} 2014 Pierre-Antoine Rault@*
|
||||
Copyright @copyright{} 2015 Taylan Ulrich Bayırlı/Kammer@*
|
||||
Copyright @copyright{} 2015, 2016 Leo Famulari
|
||||
Copyright @copyright{} 2016 Ben Woodcroft
|
||||
|
||||
Permission is granted to copy, distribute and/or modify this document
|
||||
under the terms of the GNU Free Documentation License, Version 1.3 or
|
||||
|
@ -4660,6 +4661,8 @@ the updater for @uref{http://www.bioconductor.org/, Bioconductor} R packages;
|
|||
the updater for @uref{https://pypi.python.org, PyPI} packages.
|
||||
@item gem
|
||||
the updater for @uref{https://rubygems.org, RubyGems} packages.
|
||||
@item github
|
||||
the updater for @uref{https://github.com, GitHub} packages.
|
||||
@end table
|
||||
|
||||
For instance, the following command only checks for updates of Emacs
|
||||
|
@ -4746,6 +4749,18 @@ Use @var{host} as the OpenPGP key server when importing a public key.
|
|||
|
||||
@end table
|
||||
|
||||
The @code{github} updater uses the
|
||||
@uref{https://developer.github.com/v3/, GitHub API} to query for new
|
||||
releases. When used repeatedly e.g. when refreshing all packages,
|
||||
GitHub will eventually refuse to answer any further API requests. By
|
||||
default 60 API requests per hour are allowed, and a full refresh on all
|
||||
GitHub packages in Guix requires more than this. Authentication with
|
||||
GitHub through the use of an API token alleviates these limits. To use
|
||||
an API token, set the environment variable @code{GUIX_GITHUB_TOKEN} to a
|
||||
token procured from @uref{https://github.com/settings/tokens} or
|
||||
otherwise.
|
||||
|
||||
|
||||
@node Invoking guix lint
|
||||
@section Invoking @command{guix lint}
|
||||
The @command{guix lint} command is meant to help package developers avoid
|
||||
|
|
198
guix/import/github.scm
Normal file
198
guix/import/github.scm
Normal file
|
@ -0,0 +1,198 @@
|
|||
;;; GNU Guix --- Functional package management for GNU
|
||||
;;; Copyright © 2016 Ben Woodcroft <donttrustben@gmail.com>
|
||||
;;;
|
||||
;;; This file is part of GNU Guix.
|
||||
;;;
|
||||
;;; GNU Guix is free software; you can redistribute it and/or modify it
|
||||
;;; under the terms of the GNU General Public License as published by
|
||||
;;; the Free Software Foundation; either version 3 of the License, or (at
|
||||
;;; your option) any later version.
|
||||
;;;
|
||||
;;; GNU Guix is distributed in the hope that it will be useful, but
|
||||
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
;;; GNU General Public License for more details.
|
||||
;;;
|
||||
;;; You should have received a copy of the GNU General Public License
|
||||
;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
|
||||
|
||||
(define-module (guix import github)
|
||||
#:use-module (ice-9 match)
|
||||
#:use-module (srfi srfi-1)
|
||||
#:use-module (json)
|
||||
#:use-module (guix utils)
|
||||
#:use-module ((guix download) #:prefix download:)
|
||||
#:use-module (guix import utils)
|
||||
#:use-module (guix packages)
|
||||
#:use-module (guix upstream)
|
||||
#:use-module (gnu packages)
|
||||
#: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")))
|
||||
|
||||
(define (updated-github-url old-package new-version)
|
||||
;; Return a url for the OLD-PACKAGE with NEW-VERSION. If no source url in
|
||||
;; the OLD-PACKAGE is a GitHub url, then return false.
|
||||
|
||||
(define (updated-url url)
|
||||
(if (string-prefix? "https://github.com/" url)
|
||||
(let ((ext (find-extension url))
|
||||
(name (package-name old-package))
|
||||
(version (package-version old-package))
|
||||
(prefix (string-append "https://github.com/"
|
||||
(github-user-slash-repository url)))
|
||||
(repo (github-repository url)))
|
||||
(cond
|
||||
((string-suffix? (string-append "/tarball/v" version) url)
|
||||
(string-append prefix "/tarball/v" new-version))
|
||||
((string-suffix? (string-append "/tarball/" version) url)
|
||||
(string-append prefix "/tarball/" new-version))
|
||||
((string-suffix? (string-append "/archive/v" version ext) url)
|
||||
(string-append prefix "/archive/v" new-version ext))
|
||||
((string-suffix? (string-append "/archive/" version ext) url)
|
||||
(string-append prefix "/archive/" new-version ext))
|
||||
((string-suffix? (string-append "/archive/" name "-" version ext)
|
||||
url)
|
||||
(string-append prefix "/archive/" name "-" new-version ext))
|
||||
((string-suffix? (string-append "/releases/download/v" version "/"
|
||||
name "-" version ext)
|
||||
url)
|
||||
(string-append prefix "/releases/download/v" new-version "/" name
|
||||
"-" new-version ext))
|
||||
((string-suffix? (string-append "/releases/download/" version "/"
|
||||
name "-" version ext)
|
||||
url)
|
||||
(string-append prefix "/releases/download/" new-version "/" name
|
||||
"-" new-version ext))
|
||||
((string-suffix? (string-append "/releases/download/" version "/"
|
||||
repo "-" version ext)
|
||||
url)
|
||||
(string-append prefix "/releases/download/" new-version "/" repo
|
||||
"-" new-version ext))
|
||||
((string-suffix? (string-append "/releases/download/" repo "-"
|
||||
version "/" repo "-" version ext)
|
||||
url)
|
||||
(string-append "/releases/download/" repo "-" version "/" repo "-"
|
||||
version ext))
|
||||
(#t #f))) ; Some URLs are not recognised.
|
||||
#f))
|
||||
|
||||
(let ((source-url (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)))
|
||||
|
||||
(define (github-package? package)
|
||||
"Return true if PACKAGE is a package from GitHub, else false."
|
||||
(not (eq? #f (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))))
|
||||
|
||||
(define (github-user-slash-repository url)
|
||||
"Return a string e.g. arq5x/bedtools2 of the owner and the name of the
|
||||
repository separated by a forward slash, 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 owner "/" project))))
|
||||
|
||||
(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 (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))))
|
||||
(if (eq? json #f)
|
||||
(if 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)))
|
||||
(name (package-name pkg))
|
||||
(newest-version (latest-released-version source-uri name)))
|
||||
(if newest-version
|
||||
(upstream-source
|
||||
(package pkg)
|
||||
(version newest-version)
|
||||
(urls (list (updated-github-url pkg newest-version))))
|
||||
#f))) ; On GitHub but no proper releases
|
||||
|
||||
(define %github-updater
|
||||
(upstream-updater
|
||||
(name 'github)
|
||||
(description "Updater for GitHub packages")
|
||||
(pred github-package?)
|
||||
(latest latest-release)))
|
||||
|
||||
|
|
@ -199,7 +199,8 @@ (define %updaters
|
|||
%cran-updater
|
||||
%bioconductor-updater
|
||||
((guix import pypi) => %pypi-updater)
|
||||
((guix import gem) => %gem-updater)))
|
||||
((guix import gem) => %gem-updater)
|
||||
((guix import github) => %github-updater)))
|
||||
|
||||
(define (lookup-updater name)
|
||||
"Return the updater called NAME."
|
||||
|
|
Loading…
Reference in a new issue