Commit | Line | Data |
---|---|---|
e1248602 | 1 | ;;; GNU Guix --- Functional package management for GNU |
2dca8b2d | 2 | ;;; Copyright © 2015, 2016, 2017 Ricardo Wurmus <rekado@elephly.net> |
f9704f17 | 3 | ;;; Copyright © 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org> |
db427602 | 4 | ;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com> |
e1248602 RW |
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 cran) | |
22 | #:use-module (ice-9 match) | |
23 | #:use-module (ice-9 regex) | |
2dca8b2d | 24 | #:use-module ((ice-9 rdelim) #:select (read-string read-line)) |
e1248602 | 25 | #:use-module (srfi srfi-1) |
d882c235 | 26 | #:use-module (srfi srfi-26) |
fdbc84b0 | 27 | #:use-module (srfi srfi-34) |
94e907b9 | 28 | #:use-module (srfi srfi-41) |
ad68f7fa | 29 | #:use-module (ice-9 receive) |
fdbc84b0 | 30 | #:use-module (web uri) |
f9704f17 | 31 | #:use-module (guix memoization) |
e1248602 RW |
32 | #:use-module (guix http-client) |
33 | #:use-module (guix hash) | |
34 | #:use-module (guix store) | |
35 | #:use-module (guix base32) | |
36 | #:use-module ((guix download) #:select (download-to-store)) | |
37 | #:use-module (guix import utils) | |
2dca8b2d RW |
38 | #:use-module ((guix build utils) #:select (find-files)) |
39 | #:use-module (guix utils) | |
d0bd632f | 40 | #:use-module ((guix build-system r) #:select (cran-uri bioconductor-uri)) |
d882c235 LC |
41 | #:use-module (guix upstream) |
42 | #:use-module (guix packages) | |
94e907b9 | 43 | #:use-module (gnu packages) |
d882c235 | 44 | #:export (cran->guix-package |
d0bd632f | 45 | bioconductor->guix-package |
94e907b9 | 46 | recursive-import |
d0bd632f RW |
47 | %cran-updater |
48 | %bioconductor-updater)) | |
e1248602 RW |
49 | |
50 | ;;; Commentary: | |
51 | ;;; | |
52 | ;;; Generate a package declaration template for the latest version of an R | |
0f6b9e98 | 53 | ;;; package on CRAN, using the DESCRIPTION file downloaded from |
e1248602 RW |
54 | ;;; cran.r-project.org. |
55 | ;;; | |
56 | ;;; Code: | |
57 | ||
58 | (define string->license | |
59 | (match-lambda | |
60 | ("AGPL-3" 'agpl3+) | |
61 | ("Artistic-2.0" 'artistic2.0) | |
62 | ("Apache License 2.0" 'asl2.0) | |
63 | ("BSD_2_clause" 'bsd-2) | |
576eda6d | 64 | ("BSD_2_clause + file LICENSE" 'bsd-2) |
e1248602 | 65 | ("BSD_3_clause" 'bsd-3) |
576eda6d | 66 | ("BSD_3_clause + file LICENSE" 'bsd-3) |
b6a22275 RW |
67 | ("GPL" (list 'gpl2+ 'gpl3+)) |
68 | ("GPL (>= 2)" 'gpl2+) | |
69 | ("GPL (>= 3)" 'gpl3+) | |
13f54d08 RW |
70 | ("GPL-2" 'gpl2) |
71 | ("GPL-3" 'gpl3) | |
72 | ("LGPL-2" 'lgpl2.0) | |
73 | ("LGPL-2.1" 'lgpl2.1) | |
74 | ("LGPL-3" 'lgpl3) | |
b6a22275 RW |
75 | ("LGPL (>= 2)" 'lgpl2.0+) |
76 | ("LGPL (>= 3)" 'lgpl3+) | |
741d68c2 RW |
77 | ("MIT" 'expat) |
78 | ("MIT + file LICENSE" 'expat) | |
e1248602 RW |
79 | ((x) (string->license x)) |
80 | ((lst ...) `(list ,@(map string->license lst))) | |
81 | (_ #f))) | |
82 | ||
0f6b9e98 RW |
83 | |
84 | (define (description->alist description) | |
85 | "Convert a DESCRIPTION string into an alist." | |
86 | (let ((lines (string-split description #\newline)) | |
87 | (parse (lambda (line acc) | |
88 | (if (string-null? line) acc | |
89 | ;; Keys usually start with a capital letter and end with | |
90 | ;; ":". There are some exceptions, unfortunately (such | |
91 | ;; as "biocViews"). There are no blanks in a key. | |
92 | (if (string-match "^[A-Za-z][^ :]+:( |\n|$)" line) | |
93 | ;; New key/value pair | |
94 | (let* ((pos (string-index line #\:)) | |
95 | (key (string-take line pos)) | |
96 | (value (string-drop line (+ 1 pos)))) | |
97 | (cons (cons key | |
98 | (string-trim-both value)) | |
99 | acc)) | |
100 | ;; This is a continuation of the previous pair | |
101 | (match-let ((((key . value) . rest) acc)) | |
102 | (cons (cons key (string-join | |
103 | (list value | |
104 | (string-trim-both line)))) | |
105 | rest))))))) | |
106 | (fold parse '() lines))) | |
107 | ||
e1248602 RW |
108 | (define (format-inputs names) |
109 | "Generate a sorted list of package inputs from a list of package NAMES." | |
110 | (map (lambda (name) | |
111 | (list name (list 'unquote (string->symbol name)))) | |
112 | (sort names string-ci<?))) | |
113 | ||
114 | (define* (maybe-inputs package-inputs #:optional (type 'inputs)) | |
115 | "Given a list of PACKAGE-INPUTS, tries to generate the TYPE field of a | |
116 | package definition." | |
117 | (match package-inputs | |
118 | (() | |
119 | '()) | |
120 | ((package-inputs ...) | |
121 | `((,type (,'quasiquote ,(format-inputs package-inputs))))))) | |
122 | ||
e1248602 | 123 | (define %cran-url "http://cran.r-project.org/web/packages/") |
d0bd632f RW |
124 | (define %bioconductor-url "http://bioconductor.org/packages/") |
125 | ||
7c3e4660 | 126 | ;; The latest Bioconductor release is 3.5. Bioconductor packages should be |
d0bd632f RW |
127 | ;; updated together. |
128 | (define %bioconductor-svn-url | |
129 | (string-append "https://readonly:readonly@" | |
7c3e4660 | 130 | "hedgehog.fhcrc.org/bioconductor/branches/RELEASE_3_5/" |
d0bd632f RW |
131 | "madman/Rpacks/")) |
132 | ||
e1248602 | 133 | |
34a75d35 | 134 | (define (fetch-description base-url name) |
0f6b9e98 | 135 | "Return an alist of the contents of the DESCRIPTION file for the R package |
fdbc84b0 | 136 | NAME, or #f in case of failure. NAME is case-sensitive." |
e1248602 | 137 | ;; This API always returns the latest release of the module. |
34a75d35 | 138 | (let ((url (string-append base-url name "/DESCRIPTION"))) |
fdbc84b0 RW |
139 | (guard (c ((http-get-error? c) |
140 | (format (current-error-port) | |
141 | "error: failed to retrieve package information \ | |
142 | from ~s: ~a (~s)~%" | |
143 | (uri->string (http-get-error-uri c)) | |
144 | (http-get-error-code c) | |
145 | (http-get-error-reason c)) | |
146 | #f)) | |
147 | (description->alist (read-string (http-fetch url)))))) | |
0f6b9e98 RW |
148 | |
149 | (define (listify meta field) | |
150 | "Look up FIELD in the alist META. If FIELD contains a comma-separated | |
151 | string, turn it into a list and strip off parenthetic expressions. Return the | |
152 | empty list when the FIELD cannot be found." | |
153 | (let ((value (assoc-ref meta field))) | |
154 | (if (not value) | |
155 | '() | |
156 | ;; Strip off parentheses | |
157 | (let ((items (string-split (regexp-substitute/global | |
158 | #f "( *\\([^\\)]+\\)) *" | |
159 | value 'pre 'post) | |
160 | #\,))) | |
be036757 RW |
161 | (remove (lambda (item) |
162 | (or (string-null? item) | |
163 | ;; When there is whitespace inside of items it is | |
164 | ;; probably because this was not an actual list to | |
165 | ;; begin with. | |
166 | (string-any char-set:whitespace item))) | |
0f6b9e98 RW |
167 | (map string-trim-both items)))))) |
168 | ||
b26abe4f | 169 | (define default-r-packages |
aeb64f3c | 170 | (list "base" |
b26abe4f | 171 | "compiler" |
b26abe4f RW |
172 | "grDevices" |
173 | "graphics" | |
174 | "grid" | |
b26abe4f | 175 | "methods" |
b26abe4f | 176 | "parallel" |
b26abe4f RW |
177 | "splines" |
178 | "stats" | |
179 | "stats4" | |
b26abe4f RW |
180 | "tcltk" |
181 | "tools" | |
182 | "translations" | |
183 | "utils")) | |
184 | ||
bfa0c752 RW |
185 | (define (guix-name name) |
186 | "Return a Guix package name for a given R package name." | |
187 | (string-append "r-" (string-map (match-lambda | |
188 | (#\_ #\-) | |
189 | (#\. #\-) | |
190 | (chr (char-downcase chr))) | |
191 | name))) | |
192 | ||
2dca8b2d RW |
193 | (define (needs-fortran? tarball) |
194 | "Check if the TARBALL contains Fortran source files." | |
195 | (define (check pattern) | |
196 | (parameterize ((current-error-port (%make-void-port "rw+")) | |
197 | (current-output-port (%make-void-port "rw+"))) | |
198 | (zero? (system* "tar" "--wildcards" "--list" pattern "-f" tarball)))) | |
199 | (or (check "*.f90") | |
200 | (check "*.f95") | |
201 | (check "*.f"))) | |
202 | ||
203 | (define (needs-zlib? tarball) | |
204 | "Return #T if any of the Makevars files in the src directory of the TARBALL | |
205 | contain a zlib linker flag." | |
206 | (call-with-temporary-directory | |
207 | (lambda (dir) | |
208 | (let ((pattern (make-regexp "-lz"))) | |
209 | (parameterize ((current-error-port (%make-void-port "rw+"))) | |
210 | (system* "tar" | |
211 | "xf" tarball "-C" dir | |
212 | "--wildcards" | |
213 | "*/src/Makevars*" "*/src/configure*" "*/configure*")) | |
214 | (any (lambda (file) | |
215 | (call-with-input-file file | |
216 | (lambda (port) | |
217 | (let loop () | |
218 | (let ((line (read-line port))) | |
219 | (cond | |
220 | ((eof-object? line) #f) | |
221 | ((regexp-exec pattern line) #t) | |
222 | (else (loop))))))) | |
223 | #t) | |
224 | (find-files dir)))))) | |
225 | ||
d0bd632f RW |
226 | (define (description->package repository meta) |
227 | "Return the `package' s-expression for an R package published on REPOSITORY | |
228 | from the alist META, which was derived from the R package's DESCRIPTION file." | |
d0bd632f RW |
229 | (let* ((base-url (case repository |
230 | ((cran) %cran-url) | |
231 | ((bioconductor) %bioconductor-url))) | |
232 | (uri-helper (case repository | |
233 | ((cran) cran-uri) | |
234 | ((bioconductor) bioconductor-uri))) | |
235 | (name (assoc-ref meta "Package")) | |
0f6b9e98 RW |
236 | (synopsis (assoc-ref meta "Title")) |
237 | (version (assoc-ref meta "Version")) | |
238 | (license (string->license (assoc-ref meta "License"))) | |
239 | ;; Some packages have multiple home pages. Some have none. | |
240 | (home-page (match (listify meta "URL") | |
241 | ((url rest ...) url) | |
d0bd632f RW |
242 | (_ (string-append base-url name)))) |
243 | (source-url (match (uri-helper name version) | |
0f6b9e98 | 244 | ((url rest ...) url) |
d0bd632f | 245 | ((? string? url) url) |
0f6b9e98 RW |
246 | (_ #f))) |
247 | (tarball (with-store store (download-to-store store source-url))) | |
2dca8b2d RW |
248 | (sysdepends (append |
249 | (if (needs-zlib? tarball) '("zlib") '()) | |
250 | (map string-downcase (listify meta "SystemRequirements")))) | |
b26abe4f RW |
251 | (propagate (filter (lambda (name) |
252 | (not (member name default-r-packages))) | |
253 | (lset-union equal? | |
254 | (listify meta "Imports") | |
255 | (listify meta "LinkingTo") | |
256 | (delete "R" | |
257 | (listify meta "Depends")))))) | |
ad68f7fa RW |
258 | (values |
259 | `(package | |
260 | (name ,(guix-name name)) | |
261 | (version ,version) | |
262 | (source (origin | |
263 | (method url-fetch) | |
264 | (uri (,(procedure-name uri-helper) ,name version)) | |
265 | (sha256 | |
266 | (base32 | |
267 | ,(bytevector->nix-base32-string (file-sha256 tarball)))))) | |
268 | ,@(if (not (equal? (string-append "r-" name) | |
269 | (guix-name name))) | |
270 | `((properties ,`(,'quasiquote ((,'upstream-name . ,name))))) | |
271 | '()) | |
272 | (build-system r-build-system) | |
273 | ,@(maybe-inputs sysdepends) | |
274 | ,@(maybe-inputs (map guix-name propagate) 'propagated-inputs) | |
2dca8b2d RW |
275 | ,@(if (needs-fortran? tarball) |
276 | `((native-inputs (,'quasiquote | |
277 | ,(list "gfortran" | |
278 | (list 'unquote 'gfortran))))) | |
279 | '()) | |
ad68f7fa RW |
280 | (home-page ,(if (string-null? home-page) |
281 | (string-append base-url name) | |
282 | home-page)) | |
283 | (synopsis ,synopsis) | |
284 | (description ,(beautify-description (or (assoc-ref meta "Description") | |
285 | ""))) | |
286 | (license ,license)) | |
287 | propagate))) | |
e1248602 | 288 | |
94e907b9 RW |
289 | (define cran->guix-package |
290 | (memoize | |
291 | (lambda* (package-name #:optional (repo 'cran)) | |
292 | "Fetch the metadata for PACKAGE-NAME from REPO and return the `package' | |
d0bd632f | 293 | s-expression corresponding to that package, or #f on failure." |
94e907b9 RW |
294 | (let* ((url (case repo |
295 | ((cran) %cran-url) | |
296 | ((bioconductor) %bioconductor-svn-url))) | |
297 | (module-meta (fetch-description url package-name))) | |
298 | (and=> module-meta (cut description->package repo <>)))))) | |
299 | ||
300 | (define* (recursive-import package-name #:optional (repo 'cran)) | |
301 | "Generate a stream of package expressions for PACKAGE-NAME and all its | |
302 | dependencies." | |
303 | (receive (package . dependencies) | |
304 | (cran->guix-package package-name repo) | |
305 | (if (not package) | |
306 | stream-null | |
307 | ||
308 | ;; Generate a lazy stream of package expressions for all unknown | |
309 | ;; dependencies in the graph. | |
310 | (let* ((make-state (lambda (queue done) | |
311 | (cons queue done))) | |
312 | (next (match-lambda | |
313 | (((next . rest) . done) next))) | |
314 | (imported (match-lambda | |
315 | ((queue . done) done))) | |
316 | (done? (match-lambda | |
317 | ((queue . done) | |
318 | (zero? (length queue))))) | |
319 | (unknown? (lambda* (dependency #:optional (done '())) | |
320 | (and (not (member dependency | |
321 | done)) | |
322 | (null? (find-packages-by-name | |
323 | (guix-name dependency)))))) | |
324 | (update (lambda (state new-queue) | |
325 | (match state | |
326 | (((head . tail) . done) | |
327 | (make-state (lset-difference | |
328 | equal? | |
329 | (lset-union equal? new-queue tail) | |
330 | done) | |
331 | (cons head done))))))) | |
332 | (stream-cons | |
333 | package | |
334 | (stream-unfold | |
335 | ;; map: produce a stream element | |
336 | (lambda (state) | |
337 | (cran->guix-package (next state) repo)) | |
338 | ||
339 | ;; predicate | |
e1f02f92 | 340 | (negate done?) |
94e907b9 RW |
341 | |
342 | ;; generator: update the queue | |
343 | (lambda (state) | |
344 | (receive (package . dependencies) | |
345 | (cran->guix-package (next state) repo) | |
346 | (if package | |
347 | (update state (filter (cut unknown? <> | |
348 | (cons (next state) | |
349 | (imported state))) | |
350 | (car dependencies))) | |
351 | ;; TODO: Try the other archives before giving up | |
352 | (update state (imported state))))) | |
353 | ||
354 | ;; initial state | |
355 | (make-state (filter unknown? (car dependencies)) | |
356 | (list package-name)))))))) | |
d882c235 LC |
357 | |
358 | \f | |
359 | ;;; | |
360 | ;;; Updater. | |
361 | ;;; | |
362 | ||
d1c11608 RW |
363 | (define (package->upstream-name package) |
364 | "Return the upstream name of the PACKAGE." | |
365 | (let* ((properties (package-properties package)) | |
366 | (upstream-name (and=> properties | |
367 | (cut assoc-ref <> 'upstream-name)))) | |
368 | (if upstream-name | |
369 | upstream-name | |
370 | (match (package-source package) | |
371 | ((? origin? origin) | |
372 | (match (origin-uri origin) | |
b98293eb | 373 | ((or (? string? url) (url _ ...)) |
d1c11608 RW |
374 | (let ((end (string-rindex url #\_)) |
375 | (start (string-rindex url #\/))) | |
376 | ;; The URL ends on | |
377 | ;; (string-append "/" name "_" version ".tar.gz") | |
db427602 | 378 | (and start end (substring url (+ start 1) end)))) |
d1c11608 RW |
379 | (_ #f))) |
380 | (_ #f))))) | |
381 | ||
d0bd632f | 382 | (define (latest-cran-release package) |
d882c235 | 383 | "Return an <upstream-source> for the latest release of PACKAGE." |
0f6b9e98 | 384 | |
d1c11608 | 385 | (define upstream-name |
7d27a025 | 386 | (package->upstream-name package)) |
0f6b9e98 RW |
387 | |
388 | (define meta | |
34a75d35 | 389 | (fetch-description %cran-url upstream-name)) |
0f6b9e98 RW |
390 | |
391 | (and meta | |
392 | (let ((version (assoc-ref meta "Version"))) | |
393 | ;; CRAN does not provide signatures. | |
394 | (upstream-source | |
7d27a025 | 395 | (package (package-name package)) |
0f6b9e98 | 396 | (version version) |
d1c11608 | 397 | (urls (cran-uri upstream-name version)))))) |
d882c235 | 398 | |
d0bd632f RW |
399 | (define (latest-bioconductor-release package) |
400 | "Return an <upstream-source> for the latest release of PACKAGE." | |
401 | ||
402 | (define upstream-name | |
7d27a025 | 403 | (package->upstream-name package)) |
d0bd632f RW |
404 | |
405 | (define meta | |
406 | (fetch-description %bioconductor-svn-url upstream-name)) | |
407 | ||
408 | (and meta | |
409 | (let ((version (assoc-ref meta "Version"))) | |
410 | ;; Bioconductor does not provide signatures. | |
411 | (upstream-source | |
7d27a025 | 412 | (package (package-name package)) |
d0bd632f | 413 | (version version) |
9916ae15 | 414 | (urls (list (bioconductor-uri upstream-name version))))))) |
d0bd632f | 415 | |
d882c235 LC |
416 | (define (cran-package? package) |
417 | "Return true if PACKAGE is an R package from CRAN." | |
d0bd632f | 418 | (and (string-prefix? "r-" (package-name package)) |
db427602 MO |
419 | ;; Check if the upstream name can be extracted from package uri. |
420 | (package->upstream-name package) | |
421 | ;; Check if package uri(s) are prefixed by "mirror://cran". | |
d0bd632f RW |
422 | (match (and=> (package-source package) origin-uri) |
423 | ((? string? uri) | |
424 | (string-prefix? "mirror://cran" uri)) | |
425 | ((? list? uris) | |
426 | (any (cut string-prefix? "mirror://cran" <>) uris)) | |
427 | (_ #f)))) | |
428 | ||
429 | (define (bioconductor-package? package) | |
430 | "Return true if PACKAGE is an R package from Bioconductor." | |
5ae63362 RW |
431 | (let ((predicate (lambda (uri) |
432 | (and (string-prefix? "http://bioconductor.org" uri) | |
433 | ;; Data packages are not listed in SVN | |
434 | (not (string-contains uri "/data/annotation/")))))) | |
435 | (and (string-prefix? "r-" (package-name package)) | |
436 | (match (and=> (package-source package) origin-uri) | |
437 | ((? string? uri) | |
438 | (predicate uri)) | |
439 | ((? list? uris) | |
440 | (any predicate uris)) | |
441 | (_ #f))))) | |
442 | ||
443 | (define (bioconductor-data-package? package) | |
444 | "Return true if PACKAGE is an R data package from Bioconductor." | |
445 | (let ((predicate (lambda (uri) | |
446 | (and (string-prefix? "http://bioconductor.org" uri) | |
447 | (string-contains uri "/data/annotation/"))))) | |
448 | (and (string-prefix? "r-" (package-name package)) | |
449 | (match (and=> (package-source package) origin-uri) | |
450 | ((? string? uri) | |
451 | (predicate uri)) | |
452 | ((? list? uris) | |
453 | (any predicate uris)) | |
454 | (_ #f))))) | |
d882c235 LC |
455 | |
456 | (define %cran-updater | |
7e6b490d AK |
457 | (upstream-updater |
458 | (name 'cran) | |
459 | (description "Updater for CRAN packages") | |
460 | (pred cran-package?) | |
d0bd632f RW |
461 | (latest latest-cran-release))) |
462 | ||
463 | (define %bioconductor-updater | |
464 | (upstream-updater | |
465 | (name 'bioconductor) | |
466 | (description "Updater for Bioconductor packages") | |
467 | (pred bioconductor-package?) | |
468 | (latest latest-bioconductor-release))) | |
d882c235 LC |
469 | |
470 | ;;; cran.scm ends here |