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