guix/import/github.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2016 Ben Woodcroft <donttrustben@gmail.com>
   3 ;;; Copyright © 2017, 2018 Ludovic Courtès <ludo@gnu.org>
   4 ;;; Copyright © 2018 Eric Bavier <bavier@member.fsf.org>
   5 ;;; Copyright © 2019 Arun Isaac <arunisaac@systemreboot.net>
   6 ;;;
   7 ;;; This file is part of GNU Guix.
   8 ;;;
   9 ;;; GNU Guix is free software; you can redistribute it and/or modify it
  10 ;;; under the terms of the GNU General Public License as published by
  11 ;;; the Free Software Foundation; either version 3 of the License, or (at
  12 ;;; your option) any later version.
  13 ;;;
  14 ;;; GNU Guix is distributed in the hope that it will be useful, but
  15 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  16 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  17 ;;; GNU General Public License for more details.
  18 ;;;
  19 ;;; You should have received a copy of the GNU General Public License
  20 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
  21
  22 (define-module (guix import github)
  23   #:use-module (ice-9 match)
  24   #:use-module (srfi srfi-1)
  25   #:use-module (srfi srfi-26)
  26   #:use-module (srfi srfi-34)
  27   #:use-module (guix utils)
  28   #:use-module ((guix download) #:prefix download:)
  29   #:use-module ((guix git-download) #:prefix download:)
  30   #:use-module (guix import utils)
  31   #:use-module (guix import json)
  32   #:use-module (guix packages)
  33   #:use-module (guix upstream)
  34   #:use-module (guix http-client)
  35   #:use-module (web uri)
  36   #:export (%github-updater))
  37
  38 (define (find-extension url)
  39   "Return the extension of the archive e.g. '.tar.gz' given a URL, or
  40 false if none is recognized"
  41   (find (lambda (x) (string-suffix? x url))
  42         (list ".tar.gz" ".tar.bz2" ".tar.xz" ".zip" ".tar"
  43               ".tgz" ".tbz" ".love")))
  44
  45 (define (updated-github-url old-package new-version)
  46   ;; Return a url for the OLD-PACKAGE with NEW-VERSION.  If no source url in
  47   ;; the OLD-PACKAGE is a GitHub url, then return false.
  48
  49   (define (updated-url url)
  50     (if (string-prefix? "https://github.com/" url)
  51         (let ((ext     (or (find-extension url) ""))
  52               (name    (package-name old-package))
  53               (version (package-version old-package))
  54               (prefix  (string-append "https://github.com/"
  55                                       (github-user-slash-repository url)))
  56               (repo    (github-repository url)))
  57           (cond
  58            ((string-suffix? (string-append "/tarball/v" version) url)
  59             (string-append prefix "/tarball/v" new-version))
  60            ((string-suffix? (string-append "/tarball/" version) url)
  61             (string-append prefix "/tarball/" new-version))
  62            ((string-suffix? (string-append "/archive/v" version ext) url)
  63             (string-append prefix "/archive/v" new-version ext))
  64            ((string-suffix? (string-append "/archive/" version ext) url)
  65             (string-append prefix "/archive/" new-version ext))
  66            ((string-suffix? (string-append "/archive/" name "-" version ext)
  67                             url)
  68             (string-append prefix "/archive/" name "-" new-version ext))
  69            ((string-suffix? (string-append "/releases/download/v" version "/"
  70                                            name "-" version ext)
  71                             url)
  72             (string-append prefix "/releases/download/v" new-version "/" name
  73                            "-" new-version ext))
  74            ((string-suffix? (string-append "/releases/download/" version "/"
  75                                            name "-" version ext)
  76                             url)
  77             (string-append prefix "/releases/download/" new-version "/" name
  78                            "-" new-version ext))
  79            ((string-suffix? (string-append "/releases/download/" version "/"
  80                                            repo "-" version ext)
  81                             url)
  82             (string-append prefix "/releases/download/" new-version "/" repo
  83                            "-" new-version ext))
  84            ((string-suffix? (string-append "/releases/download/" repo "-"
  85                                            version "/" repo "-" version ext)
  86                             url)
  87             (string-append "/releases/download/" repo "-" version "/" repo "-"
  88                            version ext))
  89            (#t #f))) ; Some URLs are not recognised.
  90         #f))
  91
  92   (let ((source-uri (and=> (package-source old-package) origin-uri))
  93         (fetch-method (and=> (package-source old-package) origin-method)))
  94     (cond
  95      ((eq? fetch-method download:url-fetch)
  96       (match source-uri
  97              ((? string?)
  98               (updated-url source-uri))
  99              ((source-uri ...)
 100               (find updated-url source-uri))))
 101      ((and (eq? fetch-method download:git-fetch)
 102            (string-prefix? "https://github.com/"
 103                            (download:git-reference-url source-uri)))
 104       (download:git-reference-url source-uri))
 105      (else #f))))
 106
 107 (define (github-package? package)
 108   "Return true if PACKAGE is a package from GitHub, else false."
 109   (->bool (updated-github-url package "dummy")))
 110
 111 (define (github-repository url)
 112   "Return a string e.g. bedtools2 of the name of the repository, from a string
 113 URL of the form 'https://github.com/arq5x/bedtools2/archive/v2.24.0.tar.gz'"
 114   (match (string-split (uri-path (string->uri url)) #\/)
 115     ((_ owner project . rest)
 116      (string-append (basename project ".git")))))
 117
 118 (define (github-user-slash-repository url)
 119   "Return a string e.g. arq5x/bedtools2 of the owner and the name of the
 120 repository separated by a forward slash, from a string URL of the form
 121 'https://github.com/arq5x/bedtools2/archive/v2.24.0.tar.gz'"
 122   (match (string-split (uri-path (string->uri url)) #\/)
 123     ((_ owner project . rest)
 124      (string-append owner "/" (basename project ".git")))))
 125
 126 (define %github-token
 127   ;; Token to be passed to Github.com to avoid the 60-request per hour
 128   ;; limit, or #f.
 129   (make-parameter (getenv "GUIX_GITHUB_TOKEN")))
 130
 131 (define (fetch-releases-or-tags url)
 132   "Fetch the list of \"releases\" or, if it's empty, the list of tags for the
 133 repository at URL.  Return the corresponding JSON dictionaries (hash tables),
 134 or #f if the information could not be retrieved.
 135
 136 We look at both /releases and /tags because the \"release\" feature of GitHub
 137 is little used; often, people simply provide a tag.  What's confusing is that
 138 tags show up in the \"Releases\" tab of the web UI.  For instance,
 139 'https://github.com/aconchillo/guile-json/releases' shows a number of
 140 \"releases\" (really: tags), whereas
 141 'https://api.github.com/repos/aconchillo/guile-json/releases' returns the
 142 empty list."
 143   (define release-url
 144     (string-append "https://api.github.com/repos/"
 145                    (github-user-slash-repository url)
 146                    "/releases"))
 147   (define tag-url
 148     (string-append "https://api.github.com/repos/"
 149                    (github-user-slash-repository url)
 150                    "/tags"))
 151
 152   (define headers
 153     ;; Ask for version 3 of the API as suggested at
 154     ;; <https://developer.github.com/v3/>.
 155     `((Accept . "application/vnd.github.v3+json")
 156       (user-agent . "GNU Guile")))
 157
 158   (define (decorate url)
 159     (if (%github-token)
 160         (string-append url "?access_token=" (%github-token))
 161         url))
 162
 163   (match (json-fetch (decorate release-url) #:headers headers)
 164     (()
 165      ;; We got the empty list, presumably because the user didn't use GitHub's
 166      ;; "release" mechanism, but hopefully they did use Git tags.
 167      (json-fetch (decorate tag-url) #:headers headers))
 168     (x x)))
 169
 170 (define (latest-released-version url package-name)
 171   "Return a string of the newest released version name given a string URL like
 172 'https://github.com/arq5x/bedtools2/archive/v2.24.0.tar.gz' and the name of
 173 the package e.g. 'bedtools2'.  Return #f if there is no releases"
 174   (define (pre-release? x)
 175     (hash-ref x "prerelease"))
 176
 177   (define (release->version release)
 178     (let ((tag (or (hash-ref release "tag_name") ;a "release"
 179                    (hash-ref release "name")))   ;a tag
 180           (name-length (string-length package-name)))
 181       (cond
 182        ;; some tags include the name of the package e.g. "fdupes-1.51"
 183        ;; so remove these
 184        ((and (< name-length (string-length tag))
 185              (string=? (string-append package-name "-")
 186                        (substring tag 0 (+ name-length 1))))
 187         (substring tag (+ name-length 1)))
 188        ;; some tags start with a "v" e.g. "v0.25.0"
 189        ;; where some are just the version number
 190        ((string-prefix? "v" tag)
 191         (substring tag 1))
 192        ;; Finally, reject tags that don't start with a digit:
 193        ;; they may not represent a release.
 194        ((and (not (string-null? tag))
 195              (char-set-contains? char-set:digit
 196                                  (string-ref tag 0)))
 197         tag)
 198        (else #f))))
 199
 200   (let* ((json (fetch-releases-or-tags url)))
 201     (if (eq? json #f)
 202         (if (%github-token)
 203             (error "Error downloading release information through the GitHub
 204 API when using a GitHub token")
 205             (error "Error downloading release information through the GitHub
 206 API. This may be fixed by using an access token and setting the environment
 207 variable GUIX_GITHUB_TOKEN, for instance one procured from
 208 https://github.com/settings/tokens"))
 209         (match (sort (filter-map release->version
 210                                  (match (remove pre-release? json)
 211                                    (() json) ; keep everything
 212                                    (releases releases)))
 213                      version>?)
 214           ((latest-release . _) latest-release)
 215           (() #f)))))
 216
 217 (define (latest-release pkg)
 218   "Return an <upstream-source> for the latest release of PKG."
 219   (define (origin-github-uri origin)
 220     (match (origin-uri origin)
 221       ((? string? url)
 222        url)                                       ;surely a github.com URL
 223       ((? download:git-reference? ref)
 224        (download:git-reference-url ref))
 225       ((urls ...)
 226        (find (cut string-contains <> "github.com") urls))))
 227
 228   (let* ((source-uri (origin-github-uri (package-source pkg)))
 229          (name (package-name pkg))
 230          (newest-version (latest-released-version source-uri name)))
 231     (if newest-version
 232         (upstream-source
 233          (package name)
 234          (version newest-version)
 235          (urls (list (updated-github-url pkg newest-version))))
 236         #f))) ; On GitHub but no proper releases
 237
 238 (define %github-updater
 239   (upstream-updater
 240    (name 'github)
 241    (description "Updater for GitHub packages")
 242    (pred github-package?)
 243    (latest latest-release)))
 244
 245