guix/import/github.scm

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