You can not select more than 25 topics Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.

236 lines
10 KiB

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