Mirror of GNU Guix
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.

196 lines
8.5 KiB

  1. ;;; GNU Guix --- Functional package management for GNU
  2. ;;; Copyright © 2016 Ben Woodcroft <donttrustben@gmail.com>
  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. (define-module (guix import github)
  19. #:use-module (ice-9 match)
  20. #:use-module (srfi srfi-1)
  21. #:use-module (json)
  22. #:use-module (guix utils)
  23. #:use-module ((guix download) #:prefix download:)
  24. #:use-module (guix import utils)
  25. #:use-module (guix packages)
  26. #:use-module (guix upstream)
  27. #:use-module (web uri)
  28. #:export (%github-updater))
  29. (define (json-fetch* url)
  30. "Return a list/hash representation of the JSON resource URL, or #f on
  31. failure."
  32. (call-with-output-file "/dev/null"
  33. (lambda (null)
  34. (with-error-to-port null
  35. (lambda ()
  36. (call-with-temporary-output-file
  37. (lambda (temp port)
  38. (and (url-fetch url temp)
  39. (call-with-input-file temp json->scm)))))))))
  40. (define (find-extension url)
  41. "Return the extension of the archive e.g. '.tar.gz' given a URL, or
  42. false if none is recognized"
  43. (find (lambda x (string-suffix? (first x) url))
  44. (list ".tar.gz" ".tar.bz2" ".tar.xz" ".zip" ".tar")))
  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. (define (updated-url url)
  49. (if (string-prefix? "https://github.com/" url)
  50. (let ((ext (find-extension url))
  51. (name (package-name old-package))
  52. (version (package-version old-package))
  53. (prefix (string-append "https://github.com/"
  54. (github-user-slash-repository url)))
  55. (repo (github-repository url)))
  56. (cond
  57. ((string-suffix? (string-append "/tarball/v" version) url)
  58. (string-append prefix "/tarball/v" new-version))
  59. ((string-suffix? (string-append "/tarball/" version) url)
  60. (string-append prefix "/tarball/" new-version))
  61. ((string-suffix? (string-append "/archive/v" version ext) url)
  62. (string-append prefix "/archive/v" new-version ext))
  63. ((string-suffix? (string-append "/archive/" version ext) url)
  64. (string-append prefix "/archive/" new-version ext))
  65. ((string-suffix? (string-append "/archive/" name "-" version ext)
  66. url)
  67. (string-append prefix "/archive/" name "-" new-version ext))
  68. ((string-suffix? (string-append "/releases/download/v" version "/"
  69. name "-" version ext)
  70. url)
  71. (string-append prefix "/releases/download/v" new-version "/" name
  72. "-" new-version ext))
  73. ((string-suffix? (string-append "/releases/download/" version "/"
  74. name "-" version ext)
  75. url)
  76. (string-append prefix "/releases/download/" new-version "/" name
  77. "-" new-version ext))
  78. ((string-suffix? (string-append "/releases/download/" version "/"
  79. repo "-" version ext)
  80. url)
  81. (string-append prefix "/releases/download/" new-version "/" repo
  82. "-" new-version ext))
  83. ((string-suffix? (string-append "/releases/download/" repo "-"
  84. version "/" repo "-" version ext)
  85. url)
  86. (string-append "/releases/download/" repo "-" version "/" repo "-"
  87. version ext))
  88. (#t #f))) ; Some URLs are not recognised.
  89. #f))
  90. (let ((source-url (and=> (package-source old-package) origin-uri))
  91. (fetch-method (and=> (package-source old-package) origin-method)))
  92. (if (eq? fetch-method download:url-fetch)
  93. (match source-url
  94. ((? string?)
  95. (updated-url source-url))
  96. ((source-url ...)
  97. (find updated-url source-url)))
  98. #f)))
  99. (define (github-package? package)
  100. "Return true if PACKAGE is a package from GitHub, else false."
  101. (not (eq? #f (updated-github-url package "dummy"))))
  102. (define (github-repository url)
  103. "Return a string e.g. bedtools2 of the name of the repository, from a string
  104. URL of the form 'https://github.com/arq5x/bedtools2/archive/v2.24.0.tar.gz'"
  105. (match (string-split (uri-path (string->uri url)) #\/)
  106. ((_ owner project . rest)
  107. (string-append project))))
  108. (define (github-user-slash-repository url)
  109. "Return a string e.g. arq5x/bedtools2 of the owner and the name of the
  110. repository separated by a forward slash, from a string URL of the form
  111. 'https://github.com/arq5x/bedtools2/archive/v2.24.0.tar.gz'"
  112. (match (string-split (uri-path (string->uri url)) #\/)
  113. ((_ owner project . rest)
  114. (string-append owner "/" project))))
  115. (define %github-token
  116. ;; Token to be passed to Github.com to avoid the 60-request per hour
  117. ;; limit, or #f.
  118. (make-parameter (getenv "GUIX_GITHUB_TOKEN")))
  119. (define (latest-released-version url package-name)
  120. "Return a string of the newest released version name given a string URL like
  121. 'https://github.com/arq5x/bedtools2/archive/v2.24.0.tar.gz' and the name of
  122. the package e.g. 'bedtools2'. Return #f if there is no releases"
  123. (let* ((token (%github-token))
  124. (api-url (string-append
  125. "https://api.github.com/repos/"
  126. (github-user-slash-repository url)
  127. "/releases"))
  128. (json (json-fetch*
  129. (if token
  130. (string-append api-url "?access_token=" token)
  131. api-url))))
  132. (if (eq? json #f)
  133. (if token
  134. (error "Error downloading release information through the GitHub
  135. API when using a GitHub token")
  136. (error "Error downloading release information through the GitHub
  137. API. This may be fixed by using an access token and setting the environment
  138. variable GUIX_GITHUB_TOKEN, for instance one procured from
  139. https://github.com/settings/tokens"))
  140. (let ((proper-releases
  141. (filter
  142. (lambda (x)
  143. ;; example pre-release:
  144. ;; https://github.com/wwood/OrfM/releases/tag/v0.5.1
  145. ;; or an all-prerelease set
  146. ;; https://github.com/powertab/powertabeditor/releases
  147. (not (hash-ref x "prerelease")))
  148. json)))
  149. (match proper-releases
  150. (() ;empty release list
  151. #f)
  152. ((release . rest) ;one or more releases
  153. (let ((tag (hash-ref release "tag_name"))
  154. (name-length (string-length package-name)))
  155. ;; some tags include the name of the package e.g. "fdupes-1.51"
  156. ;; so remove these
  157. (if (and (< name-length (string-length tag))
  158. (string=? (string-append package-name "-")
  159. (substring tag 0 (+ name-length 1))))
  160. (substring tag (+ name-length 1))
  161. ;; some tags start with a "v" e.g. "v0.25.0"
  162. ;; where some are just the version number
  163. (if (eq? (string-ref tag 0) #\v)
  164. (substring tag 1) tag)))))))))
  165. (define (latest-release pkg)
  166. "Return an <upstream-source> for the latest release of PKG."
  167. (let* ((source-uri (origin-uri (package-source pkg)))
  168. (name (package-name pkg))
  169. (newest-version (latest-released-version source-uri name)))
  170. (if newest-version
  171. (upstream-source
  172. (package name)
  173. (version newest-version)
  174. (urls (list (updated-github-url pkg newest-version))))
  175. #f))) ; On GitHub but no proper releases
  176. (define %github-updater
  177. (upstream-updater
  178. (name 'github)
  179. (description "Updater for GitHub packages")
  180. (pred github-package?)
  181. (latest latest-release)))