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