cran.scm 29 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701702703704705706707708709710711
  1. ;;; GNU Guix --- Functional package management for GNU
  2. ;;; Copyright © 2015, 2016, 2017, 2018, 2019, 2020 Ricardo Wurmus <rekado@elephly.net>
  3. ;;; Copyright © 2015, 2016, 2017, 2019, 2020 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/>.
  20. (define-module (guix import cran)
  21. #:use-module (ice-9 match)
  22. #:use-module (ice-9 regex)
  23. #:use-module (ice-9 popen)
  24. #:use-module ((ice-9 rdelim) #:select (read-string read-line))
  25. #:use-module (srfi srfi-1)
  26. #:use-module (srfi srfi-2)
  27. #:use-module (srfi srfi-11)
  28. #:use-module (srfi srfi-26)
  29. #:use-module (srfi srfi-34)
  30. #:use-module (ice-9 receive)
  31. #:use-module (web uri)
  32. #:use-module (guix memoization)
  33. #:use-module (guix http-client)
  34. #:use-module (gcrypt hash)
  35. #:use-module (guix store)
  36. #:use-module ((guix serialization) #:select (write-file))
  37. #:use-module (guix base32)
  38. #:use-module ((guix download) #:select (download-to-store))
  39. #:use-module (guix import utils)
  40. #:use-module ((guix build utils)
  41. #:select (find-files
  42. delete-file-recursively
  43. with-directory-excursion))
  44. #:use-module (guix utils)
  45. #:use-module (guix git)
  46. #:use-module ((guix build-system r) #:select (cran-uri bioconductor-uri))
  47. #:use-module (guix ui)
  48. #:use-module (guix upstream)
  49. #:use-module (guix packages)
  50. #:use-module (gnu packages)
  51. #:export (cran->guix-package
  52. bioconductor->guix-package
  53. cran-recursive-import
  54. %cran-updater
  55. %bioconductor-updater
  56. %bioconductor-version
  57. cran-package?
  58. bioconductor-package?
  59. bioconductor-data-package?
  60. bioconductor-experiment-package?
  61. description->alist
  62. description->package))
  63. ;;; Commentary:
  64. ;;;
  65. ;;; Generate a package declaration template for the latest version of an R
  66. ;;; package on CRAN, using the DESCRIPTION file downloaded from
  67. ;;; cran.r-project.org.
  68. ;;;
  69. ;;; Code:
  70. (define string->license
  71. (match-lambda
  72. ("AGPL-3" 'agpl3+)
  73. ("Artistic-2.0" 'artistic2.0)
  74. ("Apache License 2.0" 'asl2.0)
  75. ("BSD_2_clause" 'bsd-2)
  76. ("BSD_2_clause + file LICENSE" 'bsd-2)
  77. ("BSD_3_clause" 'bsd-3)
  78. ("BSD_3_clause + file LICENSE" 'bsd-3)
  79. ("GPL" '(list gpl2+ gpl3+))
  80. ("GPL (>= 2)" 'gpl2+)
  81. ("GPL (>= 3)" 'gpl3+)
  82. ("GPL-2" 'gpl2)
  83. ("GPL-3" 'gpl3)
  84. ("LGPL-2" 'lgpl2.0)
  85. ("LGPL-2.1" 'lgpl2.1)
  86. ("LGPL-3" 'lgpl3)
  87. ("LGPL (>= 2)" 'lgpl2.0+)
  88. ("LGPL (>= 2.1)" 'lgpl2.1+)
  89. ("LGPL (>= 3)" 'lgpl3+)
  90. ("MIT" 'expat)
  91. ("MIT + file LICENSE" 'expat)
  92. ((x) (string->license x))
  93. ((lst ...) `(list ,@(map string->license lst)))
  94. (_ #f)))
  95. (define (description->alist description)
  96. "Convert a DESCRIPTION string into an alist."
  97. (let ((lines (string-split description #\newline))
  98. (parse (lambda (line acc)
  99. (if (string-null? line) acc
  100. ;; Keys usually start with a capital letter and end with
  101. ;; ":". There are some exceptions, unfortunately (such
  102. ;; as "biocViews"). There are no blanks in a key.
  103. (if (string-match "^[A-Za-z][^ :]+:( |\n|$)" line)
  104. ;; New key/value pair
  105. (let* ((pos (string-index line #\:))
  106. (key (string-take line pos))
  107. (value (string-drop line (+ 1 pos))))
  108. (cons (cons key
  109. (string-trim-both value))
  110. acc))
  111. ;; This is a continuation of the previous pair
  112. (match-let ((((key . value) . rest) acc))
  113. (cons (cons key (string-join
  114. (list value
  115. (string-trim-both line))))
  116. rest)))))))
  117. (fold parse '() lines)))
  118. (define (format-inputs names)
  119. "Generate a sorted list of package inputs from a list of package NAMES."
  120. (map (lambda (name)
  121. (list name (list 'unquote (string->symbol name))))
  122. (sort names string-ci<?)))
  123. (define* (maybe-inputs package-inputs #:optional (type 'inputs))
  124. "Given a list of PACKAGE-INPUTS, tries to generate the TYPE field of a
  125. package definition."
  126. (match package-inputs
  127. (()
  128. '())
  129. ((package-inputs ...)
  130. `((,type (,'quasiquote ,(format-inputs package-inputs)))))))
  131. (define %cran-url "https://cran.r-project.org/web/packages/")
  132. (define %bioconductor-url "https://bioconductor.org/packages/")
  133. ;; The latest Bioconductor release is 3.11. Bioconductor packages should be
  134. ;; updated together.
  135. (define %bioconductor-version "3.11")
  136. (define* (bioconductor-packages-list-url #:optional type)
  137. (string-append "https://bioconductor.org/packages/"
  138. %bioconductor-version
  139. (match type
  140. ('annotation "/data/annotation")
  141. ('experiment "/data/experiment")
  142. (_ "/bioc"))
  143. "/src/contrib/PACKAGES"))
  144. (define* (bioconductor-packages-list #:optional type)
  145. "Return the latest version of package NAME for the current bioconductor
  146. release."
  147. (let ((url (string->uri (bioconductor-packages-list-url type))))
  148. (guard (c ((http-get-error? c)
  149. (format (current-error-port)
  150. "error: failed to retrieve list of packages from ~s: ~a (~s)~%"
  151. (uri->string (http-get-error-uri c))
  152. (http-get-error-code c)
  153. (http-get-error-reason c))
  154. #f))
  155. ;; Split the big list on empty lines, then turn each chunk into an
  156. ;; alist of attributes.
  157. (map (lambda (chunk)
  158. (description->alist (string-join chunk "\n")))
  159. (let* ((port (http-fetch/cached url))
  160. (lines (read-lines port)))
  161. (close-port port)
  162. (chunk-lines lines))))))
  163. (define* (latest-bioconductor-package-version name #:optional type)
  164. "Return the version string corresponding to the latest release of the
  165. bioconductor package NAME, or #F if the package is unknown."
  166. (and=> (find (lambda (meta)
  167. (string=? (assoc-ref meta "Package") name))
  168. (bioconductor-packages-list type))
  169. (cut assoc-ref <> "Version")))
  170. ;; XXX taken from (guix scripts hash)
  171. (define (vcs-file? file stat)
  172. (case (stat:type stat)
  173. ((directory)
  174. (member (basename file) '(".bzr" ".git" ".hg" ".svn" "CVS")))
  175. ((regular)
  176. ;; Git sub-modules have a '.git' file that is a regular text file.
  177. (string=? (basename file) ".git"))
  178. (else
  179. #f)))
  180. ;; Little helper to download URLs only once.
  181. (define download
  182. (memoize
  183. (lambda* (url #:key method)
  184. (with-store store
  185. (cond
  186. ((eq? method 'git)
  187. (latest-repository-commit store url))
  188. ((eq? method 'hg)
  189. (call-with-temporary-directory
  190. (lambda (dir)
  191. (unless (zero? (system* "hg" "clone" url dir))
  192. (leave (G_ "~A: hg download failed~%") url))
  193. (with-directory-excursion dir
  194. (let* ((port (open-pipe* OPEN_READ "hg" "id" "--id"))
  195. (changeset (string-trim-right (read-string port))))
  196. (close-pipe port)
  197. (for-each delete-file-recursively
  198. (find-files dir "^\\.hg$" #:directories? #t))
  199. (let ((store-directory
  200. (add-to-store store (basename url) #t "sha256" dir)))
  201. (values store-directory changeset)))))))
  202. (else (download-to-store store url)))))))
  203. (define (fetch-description repository name)
  204. "Return an alist of the contents of the DESCRIPTION file for the R package
  205. NAME in the given REPOSITORY, or #f in case of failure. NAME is
  206. case-sensitive."
  207. (case repository
  208. ((cran)
  209. (let ((url (string-append %cran-url name "/DESCRIPTION")))
  210. (guard (c ((http-get-error? c)
  211. (format (current-error-port)
  212. "error: failed to retrieve package information \
  213. from ~s: ~a (~s)~%"
  214. (uri->string (http-get-error-uri c))
  215. (http-get-error-code c)
  216. (http-get-error-reason c))
  217. #f))
  218. (let* ((port (http-fetch url))
  219. (result (description->alist (read-string port))))
  220. (close-port port)
  221. result))))
  222. ((bioconductor)
  223. ;; Currently, the bioconductor project does not offer a way to access a
  224. ;; package's DESCRIPTION file over HTTP, so we determine the version,
  225. ;; download the source tarball, and then extract the DESCRIPTION file.
  226. (and-let* ((type (or
  227. (and (latest-bioconductor-package-version name) #t)
  228. (and (latest-bioconductor-package-version name 'annotation) 'annotation)
  229. (and (latest-bioconductor-package-version name 'experiment) 'experiment)))
  230. (version (latest-bioconductor-package-version name type))
  231. (url (car (bioconductor-uri name version type)))
  232. (tarball (download url)))
  233. (call-with-temporary-directory
  234. (lambda (dir)
  235. (parameterize ((current-error-port (%make-void-port "rw+"))
  236. (current-output-port (%make-void-port "rw+")))
  237. (and (zero? (system* "tar" "--wildcards" "-x"
  238. "--strip-components=1"
  239. "-C" dir
  240. "-f" tarball "*/DESCRIPTION"))
  241. (and=> (description->alist (with-input-from-file
  242. (string-append dir "/DESCRIPTION") read-string))
  243. (lambda (meta)
  244. (if (boolean? type) meta
  245. (cons `(bioconductor-type . ,type) meta))))))))))
  246. ((git)
  247. (and (string-prefix? "http" name)
  248. ;; Download the git repository at "NAME"
  249. (call-with-values
  250. (lambda () (download name #:method 'git))
  251. (lambda (dir commit)
  252. (and=> (description->alist (with-input-from-file
  253. (string-append dir "/DESCRIPTION") read-string))
  254. (lambda (meta)
  255. (cons* `(git . ,name)
  256. `(git-commit . ,commit)
  257. meta)))))))
  258. ((hg)
  259. (and (string-prefix? "http" name)
  260. ;; Download the mercurial repository at "NAME"
  261. (call-with-values
  262. (lambda () (download name #:method 'hg))
  263. (lambda (dir changeset)
  264. (and=> (description->alist (with-input-from-file
  265. (string-append dir "/DESCRIPTION") read-string))
  266. (lambda (meta)
  267. (cons* `(hg . ,name)
  268. `(hg-changeset . ,changeset)
  269. meta)))))))))
  270. (define (listify meta field)
  271. "Look up FIELD in the alist META. If FIELD contains a comma-separated
  272. string, turn it into a list and strip off parenthetic expressions. Return the
  273. empty list when the FIELD cannot be found."
  274. (let ((value (assoc-ref meta field)))
  275. (if (not value)
  276. '()
  277. ;; Strip off parentheses
  278. (let ((items (string-split (regexp-substitute/global
  279. #f "( *\\([^\\)]+\\)) *"
  280. value 'pre 'post)
  281. #\,)))
  282. (remove (lambda (item)
  283. (or (string-null? item)
  284. ;; When there is whitespace inside of items it is
  285. ;; probably because this was not an actual list to
  286. ;; begin with.
  287. (string-any char-set:whitespace item)))
  288. (map string-trim-both items))))))
  289. ;; Trick Guile 3 so that it keeps the 'listify' binding accessible *and*
  290. ;; private even though this module is declarative.
  291. (set! listify listify)
  292. (define default-r-packages
  293. (list "base"
  294. "compiler"
  295. "datasets"
  296. "grDevices"
  297. "graphics"
  298. "grid"
  299. "methods"
  300. "parallel"
  301. "splines"
  302. "stats"
  303. "stats4"
  304. "tcltk"
  305. "tools"
  306. "translations"
  307. "utils"))
  308. ;; The field for system dependencies is often abused to specify non-package
  309. ;; dependencies (such as c++11). This list is used to ignore them.
  310. (define invalid-packages
  311. (list "c++11"))
  312. (define cran-guix-name (cut guix-name "r-" <>))
  313. (define (tarball-needs-fortran? tarball)
  314. "Check if the TARBALL contains Fortran source files."
  315. (define (check pattern)
  316. (parameterize ((current-error-port (%make-void-port "rw+"))
  317. (current-output-port (%make-void-port "rw+")))
  318. (zero? (system* "tar" "--wildcards" "--list" pattern "-f" tarball))))
  319. (or (check "*.f90")
  320. (check "*.f95")
  321. (check "*.f")))
  322. (define (directory-needs-fortran? dir)
  323. "Check if the directory DIR contains Fortran source files."
  324. (match (find-files dir "\\.f(90|95)?")
  325. (() #f)
  326. (_ #t)))
  327. (define (needs-fortran? thing tarball?)
  328. "Check if the THING contains Fortran source files."
  329. (if tarball?
  330. (tarball-needs-fortran? thing)
  331. (directory-needs-fortran? thing)))
  332. (define (files-match-pattern? directory regexp . file-patterns)
  333. "Return #T if any of the files matching FILE-PATTERNS in the DIRECTORY match
  334. the given REGEXP."
  335. (let ((pattern (make-regexp regexp)))
  336. (any (lambda (file)
  337. (call-with-input-file file
  338. (lambda (port)
  339. (let loop ()
  340. (let ((line (read-line port)))
  341. (cond
  342. ((eof-object? line) #f)
  343. ((regexp-exec pattern line) #t)
  344. (else (loop))))))))
  345. (apply find-files directory file-patterns))))
  346. (define (tarball-files-match-pattern? tarball regexp . file-patterns)
  347. "Return #T if any of the files represented by FILE-PATTERNS in the TARBALL
  348. match the given REGEXP."
  349. (call-with-temporary-directory
  350. (lambda (dir)
  351. (parameterize ((current-error-port (%make-void-port "rw+")))
  352. (apply system* "tar"
  353. "xf" tarball "-C" dir
  354. `("--wildcards" ,@file-patterns)))
  355. (files-match-pattern? dir regexp))))
  356. (define (directory-needs-zlib? dir)
  357. "Return #T if any of the Makevars files in the src directory DIR contain a
  358. zlib linker flag."
  359. (files-match-pattern? dir "-lz" "(Makevars.*|configure.*)"))
  360. (define (tarball-needs-zlib? tarball)
  361. "Return #T if any of the Makevars files in the src directory of the TARBALL
  362. contain a zlib linker flag."
  363. (tarball-files-match-pattern?
  364. tarball "-lz"
  365. "*/src/Makevars*" "*/src/configure*" "*/configure*"))
  366. (define (needs-zlib? thing tarball?)
  367. "Check if the THING contains files indicating a dependency on zlib."
  368. (if tarball?
  369. (tarball-needs-zlib? thing)
  370. (directory-needs-zlib? thing)))
  371. (define (directory-needs-pkg-config? dir)
  372. "Return #T if any of the Makevars files in the src directory DIR reference
  373. the pkg-config tool."
  374. (files-match-pattern? dir "pkg-config"
  375. "(Makevars.*|configure.*)"))
  376. (define (tarball-needs-pkg-config? tarball)
  377. "Return #T if any of the Makevars files in the src directory of the TARBALL
  378. reference the pkg-config tool."
  379. (tarball-files-match-pattern?
  380. tarball "pkg-config"
  381. "*/src/Makevars*" "*/src/configure*" "*/configure*"))
  382. (define (needs-pkg-config? thing tarball?)
  383. "Check if the THING contains files indicating a dependency on pkg-config."
  384. (if tarball?
  385. (tarball-needs-pkg-config? thing)
  386. (directory-needs-pkg-config? thing)))
  387. (define (needs-knitr? meta)
  388. (member "knitr" (listify meta "VignetteBuilder")))
  389. ;; XXX adapted from (guix scripts hash)
  390. (define (file-hash file select? recursive?)
  391. ;; Compute the hash of FILE.
  392. (if recursive?
  393. (let-values (((port get-hash) (open-sha256-port)))
  394. (write-file file port #:select? select?)
  395. (force-output port)
  396. (get-hash))
  397. (call-with-input-file file port-sha256)))
  398. (define (description->package repository meta)
  399. "Return the `package' s-expression for an R package published on REPOSITORY
  400. from the alist META, which was derived from the R package's DESCRIPTION file."
  401. (let* ((base-url (case repository
  402. ((cran) %cran-url)
  403. ((bioconductor) %bioconductor-url)
  404. ((git) #f)
  405. ((hg) #f)))
  406. (uri-helper (case repository
  407. ((cran) cran-uri)
  408. ((bioconductor) bioconductor-uri)
  409. ((git) #f)
  410. ((hg) #f)))
  411. (name (assoc-ref meta "Package"))
  412. (synopsis (assoc-ref meta "Title"))
  413. (version (assoc-ref meta "Version"))
  414. (license (string->license (assoc-ref meta "License")))
  415. ;; Some packages have multiple home pages. Some have none.
  416. (home-page (case repository
  417. ((git) (assoc-ref meta 'git))
  418. ((hg) (assoc-ref meta 'hg))
  419. (else (match (listify meta "URL")
  420. ((url rest ...) url)
  421. (_ (string-append base-url name))))))
  422. (source-url (case repository
  423. ((git) (assoc-ref meta 'git))
  424. ((hg) (assoc-ref meta 'hg))
  425. (else
  426. (match (apply uri-helper name version
  427. (case repository
  428. ((bioconductor)
  429. (list (assoc-ref meta 'bioconductor-type)))
  430. (else '())))
  431. ((url rest ...) url)
  432. ((? string? url) url)
  433. (_ #f)))))
  434. (git? (assoc-ref meta 'git))
  435. (hg? (assoc-ref meta 'hg))
  436. (source (download source-url #:method (cond
  437. (git? 'git)
  438. (hg? 'hg)
  439. (else #f))))
  440. (sysdepends (append
  441. (if (needs-zlib? source (not (or git? hg?))) '("zlib") '())
  442. (filter (lambda (name)
  443. (not (member name invalid-packages)))
  444. (map string-downcase (listify meta "SystemRequirements")))))
  445. (propagate (filter (lambda (name)
  446. (not (member name (append default-r-packages
  447. invalid-packages))))
  448. (lset-union equal?
  449. (listify meta "Imports")
  450. (listify meta "LinkingTo")
  451. (delete "R"
  452. (listify meta "Depends")))))
  453. (package
  454. `(package
  455. (name ,(cran-guix-name name))
  456. (version ,(case repository
  457. ((git)
  458. `(git-version ,version revision commit))
  459. ((hg)
  460. `(string-append ,version "-" revision "." changeset))
  461. (else version)))
  462. (source (origin
  463. (method ,(cond
  464. (git? 'git-fetch)
  465. (hg? 'hg-fetch)
  466. (else 'url-fetch)))
  467. (uri ,(case repository
  468. ((git)
  469. `(git-reference
  470. (url ,(assoc-ref meta 'git))
  471. (commit commit)))
  472. ((hg)
  473. `(hg-reference
  474. (url ,(assoc-ref meta 'hg))
  475. (changeset changeset)))
  476. (else
  477. `(,(procedure-name uri-helper) ,name version
  478. ,@(or (and=> (assoc-ref meta 'bioconductor-type)
  479. (lambda (type)
  480. (list (list 'quote type))))
  481. '())))))
  482. ,@(cond
  483. (git?
  484. '((file-name (git-file-name name version))))
  485. (hg?
  486. '((file-name (string-append name "-" version "-checkout"))))
  487. (else '()))
  488. (sha256
  489. (base32
  490. ,(bytevector->nix-base32-string
  491. (case repository
  492. ((git)
  493. (file-hash source (negate vcs-file?) #t))
  494. ((hg)
  495. (file-hash source (negate vcs-file?) #t))
  496. (else (file-sha256 source))))))))
  497. ,@(if (not (and git? hg?
  498. (equal? (string-append "r-" name)
  499. (cran-guix-name name))))
  500. `((properties ,`(,'quasiquote ((,'upstream-name . ,name)))))
  501. '())
  502. (build-system r-build-system)
  503. ,@(maybe-inputs sysdepends)
  504. ,@(maybe-inputs (map cran-guix-name propagate) 'propagated-inputs)
  505. ,@(maybe-inputs
  506. `(,@(if (needs-fortran? source (not (or git? hg?)))
  507. '("gfortran") '())
  508. ,@(if (needs-pkg-config? source (not (or git? hg?)))
  509. '("pkg-config") '())
  510. ,@(if (needs-knitr? meta)
  511. '("r-knitr") '()))
  512. 'native-inputs)
  513. (home-page ,(if (string-null? home-page)
  514. (string-append base-url name)
  515. home-page))
  516. (synopsis ,synopsis)
  517. (description ,(beautify-description (or (assoc-ref meta "Description")
  518. "")))
  519. (license ,license))))
  520. (values
  521. (case repository
  522. ((git)
  523. `(let ((commit ,(assoc-ref meta 'git-commit))
  524. (revision "1"))
  525. ,package))
  526. ((hg)
  527. `(let ((changeset ,(assoc-ref meta 'hg-changeset))
  528. (revision "1"))
  529. ,package))
  530. (else package))
  531. propagate)))
  532. (define cran->guix-package
  533. (memoize
  534. (lambda* (package-name #:optional (repo 'cran))
  535. "Fetch the metadata for PACKAGE-NAME from REPO and return the `package'
  536. s-expression corresponding to that package, or #f on failure."
  537. (let ((description (fetch-description repo package-name)))
  538. (if description
  539. (description->package repo description)
  540. (case repo
  541. ((git)
  542. ;; Retry import from Bioconductor
  543. (cran->guix-package package-name 'bioconductor))
  544. ((hg)
  545. ;; Retry import from Bioconductor
  546. (cran->guix-package package-name 'bioconductor))
  547. ((bioconductor)
  548. ;; Retry import from CRAN
  549. (cran->guix-package package-name 'cran))
  550. (else (values #f '()))))))))
  551. (define* (cran-recursive-import package-name #:optional (repo 'cran))
  552. (recursive-import package-name repo
  553. #:repo->guix-package cran->guix-package
  554. #:guix-name cran-guix-name))
  555. ;;;
  556. ;;; Updater.
  557. ;;;
  558. (define (package->upstream-name package)
  559. "Return the upstream name of the PACKAGE."
  560. (let* ((properties (package-properties package))
  561. (upstream-name (and=> properties
  562. (cut assoc-ref <> 'upstream-name))))
  563. (if upstream-name
  564. upstream-name
  565. (match (package-source package)
  566. ((? origin? origin)
  567. (match (origin-uri origin)
  568. ((or (? string? url) (url _ ...))
  569. (let ((end (string-rindex url #\_))
  570. (start (string-rindex url #\/)))
  571. ;; The URL ends on
  572. ;; (string-append "/" name "_" version ".tar.gz")
  573. (and start end (substring url (+ start 1) end))))
  574. (_ #f)))
  575. (_ #f)))))
  576. (define (latest-cran-release pkg)
  577. "Return an <upstream-source> for the latest release of the package PKG."
  578. (define upstream-name
  579. (package->upstream-name pkg))
  580. (define meta
  581. (fetch-description 'cran upstream-name))
  582. (and meta
  583. (let ((version (assoc-ref meta "Version")))
  584. ;; CRAN does not provide signatures.
  585. (upstream-source
  586. (package (package-name pkg))
  587. (version version)
  588. (urls (cran-uri upstream-name version))
  589. (input-changes
  590. (changed-inputs pkg
  591. (description->package 'cran meta)))))))
  592. (define (latest-bioconductor-release pkg)
  593. "Return an <upstream-source> for the latest release of the package PKG."
  594. (define upstream-name
  595. (package->upstream-name pkg))
  596. (define version
  597. (latest-bioconductor-package-version upstream-name))
  598. (and version
  599. ;; Bioconductor does not provide signatures.
  600. (upstream-source
  601. (package (package-name pkg))
  602. (version version)
  603. (urls (bioconductor-uri upstream-name version))
  604. (input-changes
  605. (changed-inputs
  606. pkg
  607. (cran->guix-package upstream-name 'bioconductor))))))
  608. (define (cran-package? package)
  609. "Return true if PACKAGE is an R package from CRAN."
  610. (and (string-prefix? "r-" (package-name package))
  611. ;; Check if the upstream name can be extracted from package uri.
  612. (package->upstream-name package)
  613. ;; Check if package uri(s) are prefixed by "mirror://cran".
  614. ((url-predicate (cut string-prefix? "mirror://cran" <>)) package)))
  615. (define (bioconductor-package? package)
  616. "Return true if PACKAGE is an R package from Bioconductor."
  617. (let ((predicate (lambda (uri)
  618. (and (string-prefix? "https://bioconductor.org" uri)
  619. ;; Data packages are neither listed in SVN nor on
  620. ;; the Github mirror, so we have to exclude them
  621. ;; from the set of bioconductor packages that can be
  622. ;; updated automatically.
  623. (not (string-contains uri "/data/annotation/"))
  624. ;; Experiment packages are in a separate repository.
  625. (not (string-contains uri "/data/experiment/"))))))
  626. (and (string-prefix? "r-" (package-name package))
  627. ((url-predicate predicate) package))))
  628. (define (bioconductor-data-package? package)
  629. "Return true if PACKAGE is an R data package from Bioconductor."
  630. (let ((predicate (lambda (uri)
  631. (and (string-prefix? "https://bioconductor.org" uri)
  632. (string-contains uri "/data/annotation/")))))
  633. (and (string-prefix? "r-" (package-name package))
  634. ((url-predicate predicate) package))))
  635. (define (bioconductor-experiment-package? package)
  636. "Return true if PACKAGE is an R experiment package from Bioconductor."
  637. (let ((predicate (lambda (uri)
  638. (and (string-prefix? "https://bioconductor.org" uri)
  639. (string-contains uri "/data/experiment/")))))
  640. (and (string-prefix? "r-" (package-name package))
  641. ((url-predicate predicate) package))))
  642. (define %cran-updater
  643. (upstream-updater
  644. (name 'cran)
  645. (description "Updater for CRAN packages")
  646. (pred cran-package?)
  647. (latest latest-cran-release)))
  648. (define %bioconductor-updater
  649. (upstream-updater
  650. (name 'bioconductor)
  651. (description "Updater for Bioconductor packages")
  652. (pred bioconductor-package?)
  653. (latest latest-bioconductor-release)))
  654. ;;; cran.scm ends here