guix/import/launchpad.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2019 Arun Isaac <arunisaac@systemreboot.net>
   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))
  35         (list ".tar.gz" ".tar.bz2" ".tar.xz"
  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
  49             ((and
  50               (>= (length (string-split version #\.)) 2)
  51               (string=? (string-append "https://launchpad.net/"
  52                                        repo "/" (version-major+minor version)
  53                                        "/" version "/+download/" repo "-" version ext)
  54                         url))
  55              (string-append "https://launchpad.net/"
  56                             repo "/" (version-major+minor new-version)
  57                             "/" new-version "/+download/" repo "-" new-version ext))
  58             (#t #f))))) ; Some URLs are not recognised.
  59
  60   (let ((source-uri (and=> (package-source old-package) origin-uri))
  61         (fetch-method (and=> (package-source old-package) origin-method)))
  62     (cond
  63      ((eq? fetch-method download:url-fetch)
  64       (match source-uri
  65              ((? string?)
  66               (updated-url source-uri))
  67              ((source-uri ...)
  68               (find updated-url source-uri))))
  69      (else #f))))
  70
  71 (define (launchpad-package? package)
  72   "Return true if PACKAGE is a package from Launchpad, else false."
  73   (->bool (updated-launchpad-url package "1.0.0")))
  74
  75 (define (launchpad-repository url)
  76   "Return a string e.g. linuxdcpp of the name of the repository, from a string
  77 URL of the form
  78 'https://launchpad.net/linuxdcpp/1.1/1.1.0/+download/linuxdcpp-1.1.0.tar.bz2'"
  79   (match (string-split (uri-path (string->uri url)) #\/)
  80     ((_ repo . rest) repo)))
  81
  82 (define (latest-released-version package-name)
  83   "Return a string of the newest released version name given the PACKAGE-NAME,
  84 for example, 'linuxdcpp'. Return #f if there is no releases."
  85   (define (pre-release? x)
  86     ;; Versions containing anything other than digit characters and "." (for
  87     ;; example, "5.1.0-rc1") are assumed to be pre-releases.
  88     (not (string-every (char-set-union (char-set #\.)
  89                                        char-set:digit)
  90                        (assoc-ref x "version"))))
  91
  92   (assoc-ref
  93    (last (remove
  94           pre-release?
  95           (vector->list
  96            (assoc-ref (json-fetch
  97                        (string-append "https://api.launchpad.net/1.0/"
  98                                       package-name "/releases"))
  99                       "entries"))))
 100    "version"))
 101
 102 (define (latest-release pkg)
 103   "Return an <upstream-source> for the latest release of PKG."
 104   (define (origin-github-uri origin)
 105     (match (origin-uri origin)
 106       ((? string? url) url) ; surely a Launchpad URL
 107       ((urls ...)
 108        (find (cut string-contains <> "launchpad.net") urls))))
 109
 110   (let* ((source-uri (origin-github-uri (package-source pkg)))
 111          (name (package-name pkg))
 112          (newest-version (latest-released-version name)))
 113     (if newest-version
 114         (upstream-source
 115          (package name)
 116          (version newest-version)
 117          (urls (list (updated-launchpad-url pkg newest-version))))
 118         #f))) ; On Launchpad but no proper releases
 119
 120 (define %launchpad-updater
 121   (upstream-updater
 122    (name 'launchpad)
 123    (description "Updater for Launchpad packages")
 124    (pred launchpad-package?)
 125    (latest latest-release)))