summaryrefslogtreecommitdiff
path: root/guix
diff options
context:
space:
mode:
authorArun Isaac <arunisaac@systemreboot.net>2019-03-13 16:18:02 +0530
committerArun Isaac <arunisaac@systemreboot.net>2019-03-18 20:55:55 +0530
commitae031d453cc43f87481dcfb06051cb6a928f4c5c (patch)
tree5dba6c3e6dc2349bfa5c7defd2b4c7dd3524d9a7 /guix
parent15871b520f01369cdf351462feea7ce0a341df1b (diff)
import: Add Launchpad updater.
* guix/import/launchpad.scm: New file. * Makefile.am (MODULES): Register it. * doc/guix.texi (Invoking guix refresh): Mention the Launchpad updater.
Diffstat (limited to 'guix')
-rw-r--r--guix/import/launchpad.scm124
1 files changed, 124 insertions, 0 deletions
diff --git a/guix/import/launchpad.scm b/guix/import/launchpad.scm
new file mode 100644
index 0000000000..ffd5e9221e
--- /dev/null
+++ b/guix/import/launchpad.scm
@@ -0,0 +1,124 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2019 Arun Isaac <arunisaac@systemreboot.net>
+;;;
+;;; 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 launchpad)
+ #:use-module (ice-9 match)
+ #:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-26)
+ #:use-module (web uri)
+ #:use-module ((guix download) #:prefix download:)
+ #:use-module (guix import json)
+ #:use-module (guix packages)
+ #:use-module (guix upstream)
+ #:use-module (guix utils)
+ #:export (%launchpad-updater))
+
+(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? x url))
+ (list ".tar.gz" ".tar.bz2" ".tar.xz"
+ ".zip" ".tar" ".tgz" ".tbz" ".love")))
+
+(define (updated-launchpad-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 Launchpad url, then return false.
+
+ (define (updated-url url)
+ (and (string-prefix? "https://launchpad.net/" url)
+ (let ((ext (or (find-extension url) ""))
+ (name (package-name old-package))
+ (version (package-version old-package))
+ (repo (launchpad-repository url)))
+ (cond
+ ((and
+ (>= (length (string-split version #\.)) 2)
+ (string=? (string-append "https://launchpad.net/"
+ repo "/" (version-major+minor version)
+ "/" version "/+download/" repo "-" version ext)
+ url))
+ (string-append "https://launchpad.net/"
+ repo "/" (version-major+minor new-version)
+ "/" new-version "/+download/" repo "-" new-version ext))
+ (#t #f))))) ; Some URLs are not recognised.
+
+ (let ((source-uri (and=> (package-source old-package) origin-uri))
+ (fetch-method (and=> (package-source old-package) origin-method)))
+ (cond
+ ((eq? fetch-method download:url-fetch)
+ (match source-uri
+ ((? string?)
+ (updated-url source-uri))
+ ((source-uri ...)
+ (find updated-url source-uri))))
+ (else #f))))
+
+(define (launchpad-package? package)
+ "Return true if PACKAGE is a package from Launchpad, else false."
+ (->bool (updated-launchpad-url package "1.0.0")))
+
+(define (launchpad-repository url)
+ "Return a string e.g. linuxdcpp of the name of the repository, from a string
+URL of the form
+'https://launchpad.net/linuxdcpp/1.1/1.1.0/+download/linuxdcpp-1.1.0.tar.bz2'"
+ (match (string-split (uri-path (string->uri url)) #\/)
+ ((_ repo . rest) repo)))
+
+(define (latest-released-version package-name)
+ "Return a string of the newest released version name given the PACKAGE-NAME,
+for example, 'linuxdcpp'. Return #f if there is no releases."
+ (define (pre-release? x)
+ ;; Versions containing anything other than digit characters and "." (for
+ ;; example, "5.1.0-rc1") are assumed to be pre-releases.
+ (not (string-every (char-set-union (char-set #\.)
+ char-set:digit)
+ (hash-ref x "version"))))
+
+ (hash-ref
+ (last (remove
+ pre-release?
+ (hash-ref (json-fetch
+ (string-append "https://api.launchpad.net/1.0/"
+ package-name "/releases"))
+ "entries")))
+ "version"))
+
+(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 Launchpad URL
+ ((urls ...)
+ (find (cut string-contains <> "launchpad.net") urls))))
+
+ (let* ((source-uri (origin-github-uri (package-source pkg)))
+ (name (package-name pkg))
+ (newest-version (latest-released-version name)))
+ (if newest-version
+ (upstream-source
+ (package name)
+ (version newest-version)
+ (urls (list (updated-launchpad-url pkg newest-version))))
+ #f))) ; On Launchpad but no proper releases
+
+(define %launchpad-updater
+ (upstream-updater
+ (name 'launchpad)
+ (description "Updater for Launchpad packages")
+ (pred launchpad-package?)
+ (latest latest-release)))