[jackhill/guix/guix.git] / guix / import / launchpad.scm

;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2019, 2020 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 ".orig.tar.gz" ".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
            ((< (length (string-split version #\.)) 2) #f)
            ((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))
            ((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))
            ((string=? (string-append "https://launchpad.net/"
                                      repo "/trunk/" version "/+download/"
                                      repo "-" version ext)
                       url)
             (string-append "https://launchpad.net/"
                            repo "/trunk/" new-version
                            "/+download/" repo "-" new-version ext))
            ((string=? (string-append "https://launchpad.net/"
                                      repo "/trunk/" version "/+download/"
                                      repo "_" version ext)
                       url)
             (string-append "https://launchpad.net/"
                            repo "/trunk/" new-version
                            "/+download/" repo "_" new-version ext))
            (#t #f))))) ; Some URLs are not recognised.

  (match (package-source old-package)
    ((? origin? origin)
     (let ((source-uri   (origin-uri origin))
           (fetch-method (origin-method origin)))
       (and (eq? fetch-method download:url-fetch)
            (match source-uri
              ((? string?)
               (updated-url source-uri))
              ((source-uri ...)
               (any updated-url source-uri))))))
    (_ #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)
                       (assoc-ref x "version"))))

  (assoc-ref
   (last (remove
          pre-release?
          (vector->list
           (assoc-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)))
Commit	Line	Data
ae031d45	1	;;; GNU Guix --- Functional package management for GNU
8b9b5a7f	2	;;; Copyright © 2019, 2020 Arun Isaac <arunisaac@systemreboot.net>
ae031d45 AI	3	;;;
	4	;;; This file is part of GNU Guix.
	5	;;;
	6	;;; GNU Guix is free software; you can redistribute it and/or modify it
	7	;;; under the terms of the GNU General Public License as published by
	8	;;; the Free Software Foundation; either version 3 of the License, or (at
	9	;;; your option) any later version.
	10	;;;
	11	;;; GNU Guix is distributed in the hope that it will be useful, but
	12	;;; WITHOUT ANY WARRANTY; without even the implied warranty of
	13	;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
	14	;;; GNU General Public License for more details.
	15	;;;
	16	;;; You should have received a copy of the GNU General Public License
	17	;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
	18
	19	(define-module (guix import launchpad)
	20	#:use-module (ice-9 match)
	21	#:use-module (srfi srfi-1)
	22	#:use-module (srfi srfi-26)
	23	#:use-module (web uri)
	24	#:use-module ((guix download) #:prefix download:)
	25	#:use-module (guix import json)
	26	#:use-module (guix packages)
	27	#:use-module (guix upstream)
	28	#:use-module (guix utils)
	29	#:export (%launchpad-updater))
	30
	31	(define (find-extension url)
	32	"Return the extension of the archive e.g. '.tar.gz' given a URL, or
	33	false if none is recognized"
	34	(find (lambda (x) (string-suffix? x url))
43225612	35	(list ".orig.tar.gz" ".tar.gz" ".tar.bz2" ".tar.xz"
ae031d45 AI	36	".zip" ".tar" ".tgz" ".tbz" ".love")))
	37
	38	(define (updated-launchpad-url old-package new-version)
	39	;; Return a url for the OLD-PACKAGE with NEW-VERSION. If no source url in
	40	;; the OLD-PACKAGE is a Launchpad url, then return false.
	41
	42	(define (updated-url url)
	43	(and (string-prefix? "https://launchpad.net/" url)
	44	(let ((ext (or (find-extension url) ""))
	45	(name (package-name old-package))
	46	(version (package-version old-package))
	47	(repo (launchpad-repository url)))
	48	(cond
4546c0dd AI	49	((< (length (string-split version #\.)) 2) #f)
	50	((string=? (string-append "https://launchpad.net/"
	51	repo "/" (version-major+minor version)
	52	"/" version "/+download/" repo "-" version ext)
	53	url)
ae031d45 AI	54	(string-append "https://launchpad.net/"
	55	repo "/" (version-major+minor new-version)
	56	"/" new-version "/+download/" repo "-" new-version ext))
4546c0dd AI	57	((string=? (string-append "https://launchpad.net/"
	58	repo "/" (version-major+minor version)
	59	"/" version "/+download/" repo "_" version ext)
	60	url)
	61	(string-append "https://launchpad.net/"
	62	repo "/" (version-major+minor new-version)
	63	"/" new-version "/+download/" repo "-" new-version ext))
	64	((string=? (string-append "https://launchpad.net/"
	65	repo "/trunk/" version "/+download/"
	66	repo "-" version ext)
	67	url)
	68	(string-append "https://launchpad.net/"
	69	repo "/trunk/" new-version
	70	"/+download/" repo "-" new-version ext))
	71	((string=? (string-append "https://launchpad.net/"
	72	repo "/trunk/" version "/+download/"
	73	repo "_" version ext)
	74	url)
	75	(string-append "https://launchpad.net/"
	76	repo "/trunk/" new-version
	77	"/+download/" repo "_" new-version ext))
ae031d45 AI	78	(#t #f))))) ; Some URLs are not recognised.
ae031d45 AI	79
f54cbc0e LC	80	(match (package-source old-package)
	81	((? origin? origin)
	82	(let ((source-uri (origin-uri origin))
	83	(fetch-method (origin-method origin)))
	84	(and (eq? fetch-method download:url-fetch)
	85	(match source-uri
	86	((? string?)
	87	(updated-url source-uri))
	88	((source-uri ...)
8b9b5a7f	89	(any updated-url source-uri))))))
f54cbc0e	90	(_ #f)))
ae031d45 AI	91
	92	(define (launchpad-package? package)
	93	"Return true if PACKAGE is a package from Launchpad, else false."
	94	(->bool (updated-launchpad-url package "1.0.0")))
	95
	96	(define (launchpad-repository url)
	97	"Return a string e.g. linuxdcpp of the name of the repository, from a string
	98	URL of the form
	99	'https://launchpad.net/linuxdcpp/1.1/1.1.0/+download/linuxdcpp-1.1.0.tar.bz2'"
	100	(match (string-split (uri-path (string->uri url)) #\/)
	101	((_ repo . rest) repo)))
	102
	103	(define (latest-released-version package-name)
	104	"Return a string of the newest released version name given the PACKAGE-NAME,
	105	for example, 'linuxdcpp'. Return #f if there is no releases."
	106	(define (pre-release? x)
	107	;; Versions containing anything other than digit characters and "." (for
	108	;; example, "5.1.0-rc1") are assumed to be pre-releases.
	109	(not (string-every (char-set-union (char-set #\.)
	110	char-set:digit)
81c3dc32	111	(assoc-ref x "version"))))
ae031d45	112
81c3dc32	113	(assoc-ref
ae031d45 AI	114	(last (remove
ae031d45 AI	115	pre-release?
81c3dc32 LC	116	(vector->list
	117	(assoc-ref (json-fetch
	118	(string-append "https://api.launchpad.net/1.0/"
	119	package-name "/releases"))
	120	"entries"))))
ae031d45 AI	121	"version"))
	122
	123	(define (latest-release pkg)
	124	"Return an <upstream-source> for the latest release of PKG."
	125	(define (origin-github-uri origin)
	126	(match (origin-uri origin)
	127	((? string? url) url) ; surely a Launchpad URL
	128	((urls ...)
	129	(find (cut string-contains <> "launchpad.net") urls))))
	130
	131	(let* ((source-uri (origin-github-uri (package-source pkg)))
	132	(name (package-name pkg))
	133	(newest-version (latest-released-version name)))
	134	(if newest-version
	135	(upstream-source
	136	(package name)
	137	(version newest-version)
	138	(urls (list (updated-launchpad-url pkg newest-version))))
	139	#f))) ; On Launchpad but no proper releases
	140
	141	(define %launchpad-updater
	142	(upstream-updater
	143	(name 'launchpad)
	144	(description "Updater for Launchpad packages")
	145	(pred launchpad-package?)
	146	(latest latest-release)))