;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2015 Ben Woodcroft ;;; ;;; 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 . ;; TODO: Are all of these imports used? (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) #: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))))))))) ;; TODO: is there some code from elsewhere in guix that can be used instead of ;; redefining? (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 (github-package? package) "Return true if PACKAGE is a package from GitHub." (define (github-url? url) (and (string-prefix? "https://github.com/" url) (let ((ext (find-extension url))) (and ext (or (string-suffix? (string-append "/archive/v" (package-version package) ext) url) (string-suffix? (string-append "/archive/" (package-version package) ext) url) (string-suffix? (string-append "/archive/" (package-name package) "-" (package-version package) ext) url) (string-suffix? (string-append "/releases/download/v" (package-version package) "/" (package-name package) "-" (package-version package) ext) url) (string-suffix? (string-append "/releases/download/" (package-version package) "/" (package-name package) "-" (package-version package) ext) url)))))) (let ((source-url (and=> (package-source package) origin-uri)) (fetch-method (and=> (package-source package) origin-method))) (and (eq? fetch-method download:url-fetch) (match source-url ((? string?) (github-url? source-url)) ((source-url ...) (any github-url? source-url)))))) (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'" (let ((splits (string-split url #\/))) (string-append (list-ref splits 3) "/" (list-ref splits 4)))) (define %github-token ;; Token to be passed to Github.com to avoid the 60-request per hour ;; limit, or #f. ;; QUESTION: is there a need to check that the token looks like a token, for ;; security, since it gets used in a fetch as is? (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 (eq? (assoc-ref (hash-table->alist x) "prerelease") #f)) json))) (if (eq? (length proper-releases) 0) #f ;empty releases list (let* ((tag (assoc-ref (hash-table->alist (first proper-releases)) "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 for the latest release of GUIX-PACKAGE." (let* ((pkg (specification->package guix-package)) (source-uri (origin-uri (package-source pkg))) (name (package-name pkg)) (version (latest-released-version source-uri name))) (if version (upstream-source (package guix-package) (version version) (urls (list source-uri))) #f))) (define %github-updater (upstream-updater (name 'github) (description "Updater for GitHub packages") (pred github-package?) (latest latest-release)))