guix/import/cran.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2015, 2016, 2017, 2018, 2019 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/>.
  20
  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-2)
  27   #:use-module (srfi srfi-26)
  28   #:use-module (srfi srfi-34)
  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 (gcrypt 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             cran-recursive-import
  47             %cran-updater
  48             %bioconductor-updater
  49
  50             cran-package?
  51             bioconductor-package?
  52             bioconductor-data-package?
  53             bioconductor-experiment-package?))
  54
  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:
  62
  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)))
  87
  88
  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)))
 112
 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<?)))
 118
 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)))))))
 127
 128 (define %cran-url "https://cran.r-project.org/web/packages/")
 129 (define %bioconductor-url "https://bioconductor.org/packages/")
 130
 131 ;; The latest Bioconductor release is 3.9.  Bioconductor packages should be
 132 ;; updated together.
 133 (define %bioconductor-version "3.9")
 134
 135 (define %bioconductor-packages-list-url
 136   (string-append "https://bioconductor.org/packages/"
 137                  %bioconductor-version "/bioc/src/contrib/PACKAGES"))
 138
 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)))))))
 155
 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")))
 163
 164 ;; Little helper to download URLs only once.
 165 (define download
 166   (memoize
 167    (lambda (url)
 168      (with-store store (download-to-store store url)))))
 169
 170 (define (fetch-description repository name)
 171   "Return an alist of the contents of the DESCRIPTION file for the R package
 172 NAME in the given REPOSITORY, or #f in case of failure.  NAME is
 173 case-sensitive."
 174   (case repository
 175     ((cran)
 176      (let ((url (string-append %cran-url name "/DESCRIPTION")))
 177        (guard (c ((http-get-error? c)
 178                   (format (current-error-port)
 179                           "error: failed to retrieve package information \
 180 from ~s: ~a (~s)~%"
 181                           (uri->string (http-get-error-uri c))
 182                           (http-get-error-code c)
 183                           (http-get-error-reason c))
 184                   #f))
 185          (description->alist (read-string (http-fetch url))))))
 186     ((bioconductor)
 187      ;; Currently, the bioconductor project does not offer a way to access a
 188      ;; package's DESCRIPTION file over HTTP, so we determine the version,
 189      ;; download the source tarball, and then extract the DESCRIPTION file.
 190      (and-let* ((version (latest-bioconductor-package-version name))
 191                 (url     (car (bioconductor-uri name version)))
 192                 (tarball (download url)))
 193        (call-with-temporary-directory
 194         (lambda (dir)
 195           (parameterize ((current-error-port (%make-void-port "rw+"))
 196                          (current-output-port (%make-void-port "rw+")))
 197             (and (zero? (system* "tar" "--wildcards" "-x"
 198                                  "--strip-components=1"
 199                                  "-C" dir
 200                                  "-f" tarball "*/DESCRIPTION"))
 201                  (description->alist (with-input-from-file
 202                                          (string-append dir "/DESCRIPTION") read-string))))))))))
 203
 204 (define (listify meta field)
 205   "Look up FIELD in the alist META.  If FIELD contains a comma-separated
 206 string, turn it into a list and strip off parenthetic expressions.  Return the
 207 empty list when the FIELD cannot be found."
 208   (let ((value (assoc-ref meta field)))
 209     (if (not value)
 210         '()
 211         ;; Strip off parentheses
 212         (let ((items (string-split (regexp-substitute/global
 213                                     #f "( *\\([^\\)]+\\)) *"
 214                                     value 'pre 'post)
 215                                    #\,)))
 216           (remove (lambda (item)
 217                     (or (string-null? item)
 218                         ;; When there is whitespace inside of items it is
 219                         ;; probably because this was not an actual list to
 220                         ;; begin with.
 221                         (string-any char-set:whitespace item)))
 222                   (map string-trim-both items))))))
 223
 224 (define default-r-packages
 225   (list "base"
 226         "compiler"
 227         "grDevices"
 228         "graphics"
 229         "grid"
 230         "methods"
 231         "parallel"
 232         "splines"
 233         "stats"
 234         "stats4"
 235         "tcltk"
 236         "tools"
 237         "translations"
 238         "utils"))
 239
 240 (define cran-guix-name (cut guix-name "r-" <>))
 241
 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")))
 251
 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))))))
 272
 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*"))
 279
 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*"))
 286
 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    (download 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 ,(cran-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                            (cran-guix-name name)))
 331               `((properties ,`(,'quasiquote ((,'upstream-name . ,name)))))
 332               '())
 333         (build-system r-build-system)
 334         ,@(maybe-inputs sysdepends)
 335         ,@(maybe-inputs (map cran-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)))
 350
 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      (let ((description (fetch-description repo package-name)))
 357        (if (and (not description)
 358                 (eq? repo 'bioconductor))
 359            ;; Retry import from CRAN
 360            (cran->guix-package package-name 'cran)
 361            (and description
 362                 (description->package repo description)))))))
 363
 364 (define* (cran-recursive-import package-name #:optional (repo 'cran))
 365   (recursive-import package-name repo
 366                     #:repo->guix-package cran->guix-package
 367                     #:guix-name cran-guix-name))
 368
 369 \f
 370 ;;;
 371 ;;; Updater.
 372 ;;;
 373
 374 (define (package->upstream-name package)
 375   "Return the upstream name of the PACKAGE."
 376   (let* ((properties (package-properties package))
 377          (upstream-name (and=> properties
 378                                (cut assoc-ref <> 'upstream-name))))
 379     (if upstream-name
 380         upstream-name
 381         (match (package-source package)
 382           ((? origin? origin)
 383            (match (origin-uri origin)
 384              ((or (? string? url) (url _ ...))
 385               (let ((end   (string-rindex url #\_))
 386                     (start (string-rindex url #\/)))
 387                 ;; The URL ends on
 388                 ;; (string-append "/" name "_" version ".tar.gz")
 389                 (and start end (substring url (+ start 1) end))))
 390              (_ #f)))
 391           (_ #f)))))
 392
 393 (define (latest-cran-release pkg)
 394   "Return an <upstream-source> for the latest release of the package PKG."
 395
 396   (define upstream-name
 397     (package->upstream-name pkg))
 398
 399   (define meta
 400     (fetch-description 'cran upstream-name))
 401
 402   (and meta
 403        (let ((version (assoc-ref meta "Version")))
 404          ;; CRAN does not provide signatures.
 405          (upstream-source
 406           (package (package-name pkg))
 407           (version version)
 408           (urls (cran-uri upstream-name version))
 409           (input-changes
 410            (changed-inputs pkg
 411                            (description->package 'cran meta)))))))
 412
 413 (define (latest-bioconductor-release pkg)
 414   "Return an <upstream-source> for the latest release of the package PKG."
 415
 416   (define upstream-name
 417     (package->upstream-name pkg))
 418
 419   (define version
 420     (latest-bioconductor-package-version upstream-name))
 421
 422   (and version
 423        ;; Bioconductor does not provide signatures.
 424        (upstream-source
 425         (package (package-name pkg))
 426         (version version)
 427         (urls (bioconductor-uri upstream-name version))
 428         (input-changes
 429          (changed-inputs
 430           pkg
 431           (cran->guix-package upstream-name 'bioconductor))))))
 432
 433 (define (cran-package? package)
 434   "Return true if PACKAGE is an R package from CRAN."
 435   (and (string-prefix? "r-" (package-name package))
 436        ;; Check if the upstream name can be extracted from package uri.
 437        (package->upstream-name package)
 438        ;; Check if package uri(s) are prefixed by "mirror://cran".
 439        (match (and=> (package-source package) origin-uri)
 440          ((? string? uri)
 441           (string-prefix? "mirror://cran" uri))
 442          ((? list? uris)
 443           (any (cut string-prefix? "mirror://cran" <>) uris))
 444          (_ #f))))
 445
 446 (define (bioconductor-package? package)
 447   "Return true if PACKAGE is an R package from Bioconductor."
 448   (let ((predicate (lambda (uri)
 449                      (and (string-prefix? "https://bioconductor.org" uri)
 450                           ;; Data packages are neither listed in SVN nor on
 451                           ;; the Github mirror, so we have to exclude them
 452                           ;; from the set of bioconductor packages that can be
 453                           ;; updated automatically.
 454                           (not (string-contains uri "/data/annotation/"))
 455                           ;; Experiment packages are in a separate repository.
 456                           (not (string-contains uri "/data/experiment/"))))))
 457     (and (string-prefix? "r-" (package-name package))
 458          (match (and=> (package-source package) origin-uri)
 459            ((? string? uri)
 460             (predicate uri))
 461            ((? list? uris)
 462             (any predicate uris))
 463            (_ #f)))))
 464
 465 (define (bioconductor-data-package? package)
 466   "Return true if PACKAGE is an R data package from Bioconductor."
 467   (let ((predicate (lambda (uri)
 468                      (and (string-prefix? "https://bioconductor.org" uri)
 469                           (string-contains uri "/data/annotation/")))))
 470     (and (string-prefix? "r-" (package-name package))
 471          (match (and=> (package-source package) origin-uri)
 472            ((? string? uri)
 473             (predicate uri))
 474            ((? list? uris)
 475             (any predicate uris))
 476            (_ #f)))))
 477
 478 (define (bioconductor-experiment-package? package)
 479   "Return true if PACKAGE is an R experiment package from Bioconductor."
 480   (let ((predicate (lambda (uri)
 481                      (and (string-prefix? "https://bioconductor.org" uri)
 482                           (string-contains uri "/data/experiment/")))))
 483     (and (string-prefix? "r-" (package-name package))
 484          (match (and=> (package-source package) origin-uri)
 485            ((? string? uri)
 486             (predicate uri))
 487            ((? list? uris)
 488             (any predicate uris))
 489            (_ #f)))))
 490
 491 (define %cran-updater
 492   (upstream-updater
 493    (name 'cran)
 494    (description "Updater for CRAN packages")
 495    (pred cran-package?)
 496    (latest latest-cran-release)))
 497
 498 (define %bioconductor-updater
 499   (upstream-updater
 500    (name 'bioconductor)
 501    (description "Updater for Bioconductor packages")
 502    (pred bioconductor-package?)
 503    (latest latest-bioconductor-release)))
 504
 505 ;;; cran.scm ends here