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.
 
 
 
 
 
 

308 lines
11 KiB

  1. ;;; GNU Guix --- Functional package management for GNU
  2. ;;; Copyright © 2015 Federico Beffa <beffa@fbengineering.ch>
  3. ;;; Copyright © 2015, 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org>
  4. ;;; Copyright © 2018 Oleg Pykhalov <go.wigust@gmail.com>
  5. ;;;
  6. ;;; This file is part of GNU Guix.
  7. ;;;
  8. ;;; GNU Guix is free software; you can redistribute it and/or modify it
  9. ;;; under the terms of the GNU General Public License as published by
  10. ;;; the Free Software Foundation; either version 3 of the License, or (at
  11. ;;; your option) any later version.
  12. ;;;
  13. ;;; GNU Guix is distributed in the hope that it will be useful, but
  14. ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  15. ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
  16. ;;; GNU General Public License for more details.
  17. ;;;
  18. ;;; You should have received a copy of the GNU General Public License
  19. ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
  20. (define-module (guix import elpa)
  21. #:use-module (ice-9 match)
  22. #:use-module (ice-9 rdelim)
  23. #:use-module (web uri)
  24. #:use-module (srfi srfi-1)
  25. #:use-module (srfi srfi-9)
  26. #:use-module (srfi srfi-9 gnu)
  27. #:use-module (srfi srfi-11)
  28. #:use-module (srfi srfi-26)
  29. #:use-module ((guix download) #:select (download-to-store))
  30. #:use-module (guix import utils)
  31. #:use-module (guix http-client)
  32. #:use-module (guix store)
  33. #:use-module (guix ui)
  34. #:use-module (gcrypt hash)
  35. #:use-module (guix base32)
  36. #:use-module (guix upstream)
  37. #:use-module (guix packages)
  38. #:use-module ((guix utils) #:select (call-with-temporary-output-file))
  39. #:export (elpa->guix-package
  40. %elpa-updater
  41. elpa-recursive-import))
  42. (define (elpa-dependencies->names deps)
  43. "Convert DEPS, a list of symbol/version pairs à la ELPA, to a list of
  44. package names as strings"
  45. (match deps
  46. (((names _ ...) ...)
  47. (map symbol->string names))))
  48. (define emacs-standard-library?
  49. (let ((libs '("emacs" "cl-lib")))
  50. (lambda (lib)
  51. "Return true if LIB is part of Emacs itself. The check is not
  52. exhaustive and only attempts to recognize a subset of packages which in the
  53. past were distributed separately from Emacs."
  54. (member lib libs))))
  55. (define (filter-dependencies names)
  56. "Remove the package names included with Emacs from the list of
  57. NAMES (strings)."
  58. (remove emacs-standard-library? names))
  59. (define (elpa-name->package-name name)
  60. "Given the NAME of an Emacs package, return the corresponding Guix name."
  61. (let ((package-name-prefix "emacs-"))
  62. (if (string-prefix? package-name-prefix name)
  63. (string-downcase name)
  64. (string-append package-name-prefix (string-downcase name)))))
  65. (define* (elpa-url #:optional (repo 'gnu))
  66. "Retrieve the URL of REPO."
  67. (let ((elpa-archives
  68. '((gnu . "https://elpa.gnu.org/packages")
  69. (melpa-stable . "https://stable.melpa.org/packages")
  70. (melpa . "https://melpa.org/packages"))))
  71. (assq-ref elpa-archives repo)))
  72. (define* (elpa-fetch-archive #:optional (repo 'gnu))
  73. "Retrieve the archive with the list of packages available from REPO."
  74. (let ((url (and=> (elpa-url repo)
  75. (cut string-append <> "/archive-contents"))))
  76. (if url
  77. ;; Use a relatively small TTL for the archive itself.
  78. (let* ((port (http-fetch/cached (string->uri url)
  79. #:ttl (* 6 3600)))
  80. (data (read port)))
  81. (close-port port)
  82. data)
  83. (leave (G_ "~A: currently not supported~%") repo))))
  84. (define* (call-with-downloaded-file url proc #:optional (error-thunk #f))
  85. "Fetch URL, store the content in a temporary file and call PROC with that
  86. file. Returns the value returned by PROC. On error call ERROR-THUNK and
  87. return its value or leave if it's false."
  88. (catch #t
  89. (lambda ()
  90. (proc (http-fetch/cached (string->uri url))))
  91. (lambda (key . args)
  92. (if error-thunk
  93. (error-thunk)
  94. (leave (G_ "~A: download failed~%") url)))))
  95. (define (is-elpa-package? name elpa-pkg-spec)
  96. "Return true if the string NAME corresponds to the name of the package
  97. defined by ELPA-PKG-SPEC, a package specification as in an archive
  98. 'archive-contents' file."
  99. (eq? (first elpa-pkg-spec) (string->symbol name)))
  100. (define* (elpa-package-info name #:optional (repo 'gnu))
  101. "Extract the information about the package NAME from the package archieve of
  102. REPO."
  103. (let* ((archive (elpa-fetch-archive repo))
  104. (pkgs (match archive ((version pkg-spec ...) pkg-spec)))
  105. (info (filter (cut is-elpa-package? name <>) pkgs)))
  106. (if (pair? info) (first info) #f)))
  107. ;; Object to store information about an ELPA package.
  108. (define-record-type <elpa-package>
  109. (make-elpa-package name version inputs synopsis kind home-page description
  110. source-url)
  111. elpa-package?
  112. (name elpa-package-name)
  113. (version elpa-package-version)
  114. (inputs elpa-package-inputs)
  115. (synopsis elpa-package-synopsis)
  116. (kind elpa-package-kind)
  117. (home-page elpa-package-home-page)
  118. (description elpa-package-description)
  119. (source-url elpa-package-source-url))
  120. (set-record-type-printer! <elpa-package>
  121. (lambda (package port)
  122. (format port "#<elpa-package ~a@~a>"
  123. (elpa-package-name package)
  124. (elpa-package-version package))))
  125. (define (elpa-version->string elpa-version)
  126. "Convert the package version as used in Emacs package files into a string."
  127. (if (pair? elpa-version)
  128. (let-values (((ms rest) (match elpa-version
  129. ((ms . rest)
  130. (values ms rest)))))
  131. (fold (lambda (n s) (string-append s "." (number->string n)))
  132. (number->string ms) rest))
  133. #f))
  134. (define (package-home-page alist)
  135. "Extract the package home-page from ALIST."
  136. (or (assq-ref alist ':url) "unspecified"))
  137. (define (ensure-list alist)
  138. "If ALIST is the symbol 'nil return the empty list. Otherwise, return ALIST."
  139. (if (eq? alist 'nil)
  140. '()
  141. alist))
  142. (define (package-source-url kind name version repo)
  143. "Return the source URL of the package described the the strings NAME and
  144. VERSION at REPO. KIND is either the symbol 'single or 'tar."
  145. (case kind
  146. ((single) (full-url repo name ".el" version))
  147. ((tar) (full-url repo name ".tar" version))
  148. (else
  149. #f)))
  150. (define* (full-url repo name suffix #:optional (version #f))
  151. "Return the full URL of the package NAME at REPO and the SUFFIX. Maybe
  152. include VERSION."
  153. (if version
  154. (string-append (elpa-url repo) "/" name "-" version suffix)
  155. (string-append (elpa-url repo) "/" name suffix)))
  156. (define (fetch-package-description kind name repo)
  157. "Fetch the description of package NAME of type KIND from REPO."
  158. (let ((url (full-url repo name "-readme.txt"))
  159. (error-thunk (lambda () "No description available.")))
  160. (call-with-downloaded-file url read-string error-thunk)))
  161. (define* (fetch-elpa-package name #:optional (repo 'gnu))
  162. "Fetch package NAME from REPO."
  163. (let ((pkg (elpa-package-info name repo)))
  164. (match pkg
  165. ((name version reqs synopsis kind . rest)
  166. (let* ((name (symbol->string name))
  167. (ver (elpa-version->string version))
  168. (url (package-source-url kind name ver repo)))
  169. (make-elpa-package name ver
  170. (ensure-list reqs) synopsis kind
  171. (package-home-page (match rest
  172. (() #f)
  173. ((one) one)))
  174. (fetch-package-description kind name repo)
  175. url)))
  176. (_ #f))))
  177. (define* (elpa-package->sexp pkg #:optional license)
  178. "Return the `package' S-expression for the Emacs package PKG, a record of
  179. type '<elpa-package>'."
  180. (define name (elpa-package-name pkg))
  181. (define version (elpa-package-version pkg))
  182. (define source-url (elpa-package-source-url pkg))
  183. (define dependencies-names
  184. (filter-dependencies (elpa-dependencies->names
  185. (elpa-package-inputs pkg))))
  186. (define dependencies
  187. (map (lambda (n)
  188. (let ((new-n (elpa-name->package-name n)))
  189. (list new-n (list 'unquote (string->symbol new-n)))))
  190. dependencies-names))
  191. (define (maybe-inputs input-type inputs)
  192. (match inputs
  193. (()
  194. '())
  195. ((inputs ...)
  196. (list (list input-type
  197. (list 'quasiquote inputs))))))
  198. (let ((tarball (with-store store
  199. (download-to-store store source-url))))
  200. (values
  201. `(package
  202. (name ,(elpa-name->package-name name))
  203. (version ,version)
  204. (source (origin
  205. (method url-fetch)
  206. (uri (string-append ,@(factorize-uri source-url version)))
  207. (sha256
  208. (base32
  209. ,(if tarball
  210. (bytevector->nix-base32-string (file-sha256 tarball))
  211. "failed to download package")))))
  212. (build-system emacs-build-system)
  213. ,@(maybe-inputs 'propagated-inputs dependencies)
  214. (home-page ,(elpa-package-home-page pkg))
  215. (synopsis ,(elpa-package-synopsis pkg))
  216. (description ,(elpa-package-description pkg))
  217. (license ,license))
  218. dependencies-names)))
  219. (define* (elpa->guix-package name #:optional (repo 'gnu))
  220. "Fetch the package NAME from REPO and produce a Guix package S-expression."
  221. (match (fetch-elpa-package name repo)
  222. (#f #f)
  223. (package
  224. ;; ELPA is known to contain only GPLv3+ code. Other repos may contain
  225. ;; code under other license but there's no license metadata.
  226. (let ((license (and (eq? 'gnu repo) 'license:gpl3+)))
  227. (elpa-package->sexp package license)))))
  228. ;;;
  229. ;;; Updates.
  230. ;;;
  231. (define (latest-release package)
  232. "Return an <upstream-release> for the latest release of PACKAGE."
  233. (define name
  234. (if (string-prefix? "emacs-" (package-name package))
  235. (string-drop (package-name package) 6)
  236. (package-name package)))
  237. (let* ((repo 'gnu)
  238. (info (elpa-package-info name repo))
  239. (version (match info
  240. ((name raw-version . _)
  241. (elpa-version->string raw-version))))
  242. (url (match info
  243. ((_ raw-version reqs synopsis kind . rest)
  244. (package-source-url kind name version repo)))))
  245. (upstream-source
  246. (package (package-name package))
  247. (version version)
  248. (urls (list url))
  249. (signature-urls (list (string-append url ".sig"))))))
  250. (define (package-from-gnu.org? package)
  251. "Return true if PACKAGE is from elpa.gnu.org."
  252. (match (and=> (package-source package) origin-uri)
  253. ((? string? uri)
  254. (let ((uri (string->uri uri)))
  255. (and uri (string=? (uri-host uri) "elpa.gnu.org"))))
  256. (_ #f)))
  257. (define %elpa-updater
  258. ;; The ELPA updater. We restrict it to packages hosted on elpa.gnu.org
  259. ;; because for other repositories, we typically grab the source elsewhere.
  260. (upstream-updater
  261. (name 'elpa)
  262. (description "Updater for ELPA packages")
  263. (pred package-from-gnu.org?)
  264. (latest latest-release)))
  265. (define elpa-guix-name (cut guix-name "emacs-" <>))
  266. (define* (elpa-recursive-import package-name #:optional (repo 'gnu))
  267. (recursive-import package-name repo
  268. #:repo->guix-package elpa->guix-package
  269. #:guix-name elpa-guix-name))
  270. ;;; elpa.scm ends here