>From 8072ee3ac66a71b74e79af4047d4f03bac9fed48 Mon Sep 17 00:00:00 2001
From: Ben Woodcroft
Date: Sun, 15 Nov 2015 10:18:05 +1000
Subject: [PATCH] import: Add github-updater.
* guix/import/github.scm: New file.
* guix/scripts/refresh.scm (%updaters): Add %GITHUB-UPDATER
---
guix/import/github.scm | 118 +++++++++++++++++++++++++++++++++++++++++++++++
guix/scripts/refresh.scm | 4 +-
2 files changed, 121 insertions(+), 1 deletion(-)
create mode 100644 guix/import/github.scm
diff --git a/guix/import/github.scm b/guix/import/github.scm
new file mode 100644
index 0000000..2fecb0a
--- /dev/null
+++ b/guix/import/github.scm
@@ -0,0 +1,118 @@
+;;; 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 binary-ports)
+ #:use-module (ice-9 match)
+ #:use-module (ice-9 pretty-print)
+ #:use-module (ice-9 regex)
+ #:use-module ((ice-9 rdelim) #:select (read-line))
+ #:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-26)
+ #:use-module (rnrs bytevectors)
+ #:use-module (json)
+ #:use-module (web uri)
+ #:use-module (guix ui)
+ #:use-module (guix utils)
+ #:use-module ((guix 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)
+ #:export (%github-updater))
+
+(define (json-fetch* url)
+ "Return a list/hash representation of the JSON resource URL, or #f on
+failure."
+ ;; TODO: make silent
+ (call-with-temporary-output-file
+ (lambda (temp port)
+ (and (url-fetch url temp)
+ (call-with-input-file temp json->scm)))))
+
+(define (github-package? package)
+ "Return true if PACKAGE is a package from GitHub."
+
+ ;; TODO: currently requires the standard "v1.0" or "1.0" style tag names
+ ;; TODO: currently only accepts .tar.gz downloads
+ ;; TODO: should also accept alternative download URLs of style like
+ ;; https://github.com/libical/libical/releases/download/v1.0.1/libical-1.0.1.tar.gz
+ (define (github-url? url)
+ (and
+ (string-prefix? "https://github.com/" url)
+ (or
+ (string-suffix?
+ (string-append "/archive/v" (package-version package) ".tar.gz") url)
+ (string-suffix?
+ (string-append "/archive/" (package-version package) ".tar.gz") url))))
+
+ (let ((source-url (and=> (package-source package) origin-uri))
+ (fetch-method (and=> (package-source package) origin-method)))
+ (display (list "testing" source-url))
+ (display "\n")
+ (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 (latest-released-version url)
+ "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', or #f if there
+is no releases"
+ ;; TODO: don't return pre-release versions, can detect this from JSON field
+ ;; 'prerelease'
+ (let ((json (json-fetch*
+ (string-append "https://api.github.com/repos/"
+ (github-user-slash-repository url)
+ "/releases"
+ ;;"?access_token=aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+ ))))
+ (if (eq? (length json) 0) #f
+ (let ((tag (assoc-ref (hash-table->alist (first json)) "tag_name")))
+ (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)))
+ (version (latest-released-version source-uri)))
+ (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)))
diff --git a/guix/scripts/refresh.scm b/guix/scripts/refresh.scm
index 3161aac..f9ac0ed 100644
--- a/guix/scripts/refresh.scm
+++ b/guix/scripts/refresh.scm
@@ -3,6 +3,7 @@
;;; Copyright © 2013 Nikita Karetnikov
;;; Copyright © 2014 Eric Bavier
;;; Copyright © 2015 Alex Kost
+;;; Copyright © 2015 Ben Woodcroft
;;;
;;; This file is part of GNU Guix.
;;;
@@ -184,7 +185,8 @@ unavailable optional dependencies such as Guile-JSON."
(list-updaters %gnu-updater
%elpa-updater
%cran-updater
- ((guix import pypi) => %pypi-updater)))
+ ((guix import pypi) => %pypi-updater)
+ ((guix import github) => %github-updater)))
(define (lookup-updater name)
"Return the updater called NAME."
--
2.5.0