Merge branch 'master' into python-tests

6 files changed, 379 insertions, 65 deletions

diff --git a/guix/import/cran.scm b/guix/import/cran.scm
index 3fb2e213b0..463a25514e 100644
--- a/guix/import/cran.scm
+++ b/guix/import/cran.scm
@@ -23,6 +23,11 @@
   #:use-module ((ice-9 rdelim) #:select (read-string))
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-26)
+  #:use-module (srfi srfi-34)
+  #:use-module (srfi srfi-41)
+  #:use-module (ice-9 receive)
+  #:use-module (web uri)
+  #:use-module (guix combinators)
   #:use-module (guix http-client)
   #:use-module (guix hash)
   #:use-module (guix store)
@@ -32,8 +37,10 @@
   #:use-module ((guix build-system r) #:select (cran-uri bioconductor-uri))
   #:use-module (guix upstream)
   #:use-module (guix packages)
+  #:use-module (gnu packages)
   #:export (cran->guix-package
             bioconductor->guix-package
+            recursive-import
             %cran-updater
             %bioconductor-updater))
 
@@ -51,19 +58,21 @@
    ("Artistic-2.0" 'artistic2.0)
    ("Apache License 2.0" 'asl2.0)
    ("BSD_2_clause" 'bsd-2)
+   ("BSD_2_clause + file LICENSE" 'bsd-2)
    ("BSD_3_clause" 'bsd-3)
+   ("BSD_3_clause + file LICENSE" 'bsd-3)
    ("GPL" (list 'gpl2+ 'gpl3+))
    ("GPL (>= 2)" 'gpl2+)
    ("GPL (>= 3)" 'gpl3+)
-   ("GPL-2" 'gpl2+)
-   ("GPL-3" 'gpl3+)
-   ("LGPL-2" 'lgpl2.0+)
-   ("LGPL-2.1" 'lgpl2.1+)
-   ("LGPL-3" 'lgpl3+)
+   ("GPL-2" 'gpl2)
+   ("GPL-3" 'gpl3)
+   ("LGPL-2" 'lgpl2.0)
+   ("LGPL-2.1" 'lgpl2.1)
+   ("LGPL-3" 'lgpl3)
    ("LGPL (>= 2)" 'lgpl2.0+)
    ("LGPL (>= 3)" 'lgpl3+)
-   ("MIT" 'x11)
-   ("MIT + file LICENSE" 'x11)
+   ("MIT" 'expat)
+   ("MIT + file LICENSE" 'expat)
    ((x) (string->license x))
    ((lst ...) `(list ,@(map string->license lst)))
    (_ #f)))
@@ -121,10 +130,18 @@ package definition."
 
 (define (fetch-description base-url name)
   "Return an alist of the contents of the DESCRIPTION file for the R package
-NAME, or #f on failure.  NAME is case-sensitive."
+NAME, or #f in case of failure.  NAME is case-sensitive."
   ;; This API always returns the latest release of the module.
   (let ((url (string-append base-url name "/DESCRIPTION")))
-    (description->alist (read-string (http-fetch url)))))
+    (guard (c ((http-get-error? c)
+               (format (current-error-port)
+                       "error: failed to retrieve package information \
+from ~s: ~a (~s)~%"
+                       (uri->string (http-get-error-uri c))
+                       (http-get-error-code c)
+                       (http-get-error-reason c))
+               #f))
+      (description->alist (read-string (http-fetch url))))))
 
 (define (listify meta field)
   "Look up FIELD in the alist META.  If FIELD contains a comma-separated
@@ -146,14 +163,49 @@ empty list when the FIELD cannot be found."
                         (string-any char-set:whitespace item)))
                   (map string-trim-both items))))))
 
+(define default-r-packages
+  (list "KernSmooth"
+        "MASS"
+        "Matrix"
+        "base"
+        "boot"
+        "class"
+        "cluster"
+        "codetools"
+        "compiler"
+        "datasets"
+        "foreign"
+        "grDevices"
+        "graphics"
+        "grid"
+        "lattice"
+        "methods"
+        "mgcv"
+        "nlme"
+        "nnet"
+        "parallel"
+        "rpart"
+        "spatial"
+        "splines"
+        "stats"
+        "stats4"
+        "survival"
+        "tcltk"
+        "tools"
+        "translations"
+        "utils"))
+
+(define (guix-name name)
+  "Return a Guix package name for a given R package name."
+  (string-append "r-" (string-map (match-lambda
+                                    (#\_ #\-)
+                                    (#\. #\-)
+                                    (chr (char-downcase chr)))
+                                  name)))
+
 (define (description->package repository meta)
   "Return the `package' s-expression for an R package published on REPOSITORY
 from the alist META, which was derived from the R package's DESCRIPTION file."
-  (define (guix-name name)
-    (if (string-prefix? "r-" name)
-        (string-downcase name)
-        (string-append "r-" (string-downcase name))))
-
   (let* ((base-url   (case repository
                        ((cran)         %cran-url)
                        ((bioconductor) %bioconductor-url)))
@@ -174,42 +226,107 @@ from the alist META, which was derived from the R package's DESCRIPTION file."
                        (_ #f)))
          (tarball    (with-store store (download-to-store store source-url)))
          (sysdepends (map string-downcase (listify meta "SystemRequirements")))
-         (propagate  (map guix-name (lset-union equal?
-                                                (listify meta "Imports")
-                                                (listify meta "LinkingTo")
-                                                (delete "R"
-                                                        (listify meta "Depends"))))))
-    `(package
-       (name ,(guix-name name))
-       (version ,version)
-       (source (origin
-                 (method url-fetch)
-                 (uri (,(procedure-name uri-helper) ,name version))
-                 (sha256
-                  (base32
-                   ,(bytevector->nix-base32-string (file-sha256 tarball))))))
-       ,@(if (not (equal? (string-append "r-" name)
-                          (guix-name name)))
-             `((properties ,`(,'quasiquote ((,'upstream-name . ,name)))))
-             '())
-       (build-system r-build-system)
-       ,@(maybe-inputs sysdepends)
-       ,@(maybe-inputs propagate 'propagated-inputs)
-       (home-page ,(if (string-null? home-page)
-                       (string-append base-url name)
-                       home-page))
-       (synopsis ,synopsis)
-       (description ,(beautify-description (assoc-ref meta "Description")))
-       (license ,license))))
-
-(define* (cran->guix-package package-name #:optional (repo 'cran))
-  "Fetch the metadata for PACKAGE-NAME from REPO and return the `package'
+         (propagate  (filter (lambda (name)
+                               (not (member name default-r-packages)))
+                             (lset-union equal?
+                                         (listify meta "Imports")
+                                         (listify meta "LinkingTo")
+                                         (delete "R"
+                                                 (listify meta "Depends"))))))
+    (values
+     `(package
+        (name ,(guix-name name))
+        (version ,version)
+        (source (origin
+                  (method url-fetch)
+                  (uri (,(procedure-name uri-helper) ,name version))
+                  (sha256
+                   (base32
+                    ,(bytevector->nix-base32-string (file-sha256 tarball))))))
+        ,@(if (not (equal? (string-append "r-" name)
+                           (guix-name name)))
+              `((properties ,`(,'quasiquote ((,'upstream-name . ,name)))))
+              '())
+        (build-system r-build-system)
+        ,@(maybe-inputs sysdepends)
+        ,@(maybe-inputs (map guix-name propagate) 'propagated-inputs)
+        (home-page ,(if (string-null? home-page)
+                        (string-append base-url name)
+                        home-page))
+        (synopsis ,synopsis)
+        (description ,(beautify-description (or (assoc-ref meta "Description")
+                                                "")))
+        (license ,license))
+     propagate)))
+
+(define cran->guix-package
+  (memoize
+   (lambda* (package-name #:optional (repo 'cran))
+     "Fetch the metadata for PACKAGE-NAME from REPO and return the `package'
 s-expression corresponding to that package, or #f on failure."
-  (let* ((url (case repo
-                ((cran)         %cran-url)
-                ((bioconductor) %bioconductor-svn-url)))
-         (module-meta (fetch-description url package-name)))
-    (and=> module-meta (cut description->package repo <>))))
+     (let* ((url (case repo
+                   ((cran)         %cran-url)
+                   ((bioconductor) %bioconductor-svn-url)))
+            (module-meta (fetch-description url package-name)))
+       (and=> module-meta (cut description->package repo <>))))))
+
+(define* (recursive-import package-name #:optional (repo 'cran))
+  "Generate a stream of package expressions for PACKAGE-NAME and all its
+dependencies."
+  (receive (package . dependencies)
+      (cran->guix-package package-name repo)
+    (if (not package)
+        stream-null
+
+        ;; Generate a lazy stream of package expressions for all unknown
+        ;; dependencies in the graph.
+        (let* ((make-state (lambda (queue done)
+                             (cons queue done)))
+               (next       (match-lambda
+                             (((next . rest) . done) next)))
+               (imported   (match-lambda
+                             ((queue . done) done)))
+               (done?      (match-lambda
+                             ((queue . done)
+                              (zero? (length queue)))))
+               (unknown?   (lambda* (dependency #:optional (done '()))
+                             (and (not (member dependency
+                                               done))
+                                  (null? (find-packages-by-name
+                                          (guix-name dependency))))))
+               (update     (lambda (state new-queue)
+                             (match state
+                               (((head . tail) . done)
+                                (make-state (lset-difference
+                                             equal?
+                                             (lset-union equal? new-queue tail)
+                                             done)
+                                            (cons head done)))))))
+          (stream-cons
+           package
+           (stream-unfold
+            ;; map: produce a stream element
+            (lambda (state)
+              (cran->guix-package (next state) repo))
+
+            ;; predicate
+            (compose not done?)
+
+            ;; generator: update the queue
+            (lambda (state)
+              (receive (package . dependencies)
+                  (cran->guix-package (next state) repo)
+                (if package
+                    (update state (filter (cut unknown? <>
+                                               (cons (next state)
+                                                     (imported state)))
+                                          (car dependencies)))
+                    ;; TODO: Try the other archives before giving up
+                    (update state (imported state)))))
+
+            ;; initial state
+            (make-state (filter unknown? (car dependencies))
+                        (list package-name))))))))
 
 
 ;;;
diff --git a/guix/import/crate.scm b/guix/import/crate.scm
new file mode 100644
index 0000000000..233a20e983
--- /dev/null
+++ b/guix/import/crate.scm
@@ -0,0 +1,165 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2016 David Craven <david@craven.ch>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Guix is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (guix import crate)
+  #:use-module (guix base32)
+  #:use-module (guix build-system cargo)
+  #:use-module ((guix download) #:prefix download:)
+  #:use-module (guix hash)
+  #:use-module (guix http-client)
+  #:use-module (guix import json)
+  #:use-module (guix import utils)
+  #:use-module ((guix licenses) #:prefix license:)
+  #:use-module (guix monads)
+  #:use-module (guix packages)
+  #:use-module (guix upstream)
+  #:use-module (guix utils)
+  #:use-module (ice-9 match)
+  #:use-module (ice-9 pretty-print) ; recursive
+  #:use-module (json)
+  #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-2)
+  #:use-module (srfi srfi-26)
+  #:export (crate->guix-package
+            guix-package->crate-name
+            %crate-updater))
+
+(define (crate-fetch crate-name callback)
+  "Fetch the metadata for CRATE-NAME from crates.io and call the callback."
+
+  (define (crates->inputs crates)
+    (sort (map (cut assoc-ref <> "crate_id") crates) string-ci<?))
+
+  (define (string->license string)
+    (map spdx-string->license (string-split string #\/)))
+
+  (define (crate-kind-predicate kind)
+    (lambda (dep) (string=? (assoc-ref dep "kind") kind)))
+
+  (and-let* ((crate-json (json-fetch (string-append crate-url crate-name)))
+             (crate (assoc-ref crate-json "crate"))
+             (name (assoc-ref crate "name"))
+             (version (assoc-ref crate "max_version"))
+             (homepage (assoc-ref crate "homepage"))
+             (repository (assoc-ref crate "repository"))
+             (synopsis (assoc-ref crate "description"))
+             (description (assoc-ref crate "description"))
+             (license (string->license (assoc-ref crate "license")))
+             (path (string-append "/" version "/dependencies"))
+             (deps-json (json-fetch (string-append crate-url name path)))
+             (deps (assoc-ref deps-json "dependencies"))
+             (input-crates (filter (crate-kind-predicate "normal") deps))
+             (native-input-crates
+              (filter (lambda (dep)
+                        (not ((crate-kind-predicate "normal") dep))) deps))
+             (inputs (crates->inputs input-crates))
+             (native-inputs (crates->inputs native-input-crates))
+             (home-page (match homepage
+                          (() repository)
+                          (_ homepage))))
+    (callback #:name name #:version version
+              #:inputs inputs #:native-inputs native-inputs
+              #:home-page home-page #:synopsis synopsis
+              #:description description #:license license)))
+
+(define* (make-crate-sexp #:key name version inputs native-inputs
+                          home-page synopsis description license
+                          #:allow-other-keys)
+  "Return the `package' s-expression for a rust package with the given NAME,
+VERSION, INPUTS, NATIVE-INPUTS, HOME-PAGE, SYNOPSIS, DESCRIPTION, and LICENSE."
+  (let* ((port (http-fetch (crate-uri name version)))
+         (guix-name (crate-name->package-name name))
+         (inputs (map crate-name->package-name inputs))
+         (native-inputs (map crate-name->package-name native-inputs))
+         (pkg `(package
+                   (name ,guix-name)
+                   (version ,version)
+                   (source (origin
+                             (method url-fetch)
+                             (uri (crate-uri ,name version))
+                             (file-name (string-append name "-" version ".tar.gz"))
+                             (sha256
+                              (base32
+                               ,(bytevector->nix-base32-string (port-sha256 port))))))
+                   (build-system cargo-build-system)
+                   ,@(maybe-native-inputs native-inputs "src")
+                   ,@(maybe-inputs inputs "src")
+                   (home-page ,(match home-page
+                                 (() "")
+                                 (_ home-page)))
+                   (synopsis ,synopsis)
+                   (description ,(beautify-description description))
+                   (license ,(match license
+                               (() #f)
+                               ((license) license)
+                               (_ `(list ,@license)))))))
+         (close-port port)
+         pkg))
+
+(define (crate->guix-package crate-name)
+  "Fetch the metadata for CRATE-NAME from crates.io, and return the
+`package' s-expression corresponding to that package, or #f on failure."
+  (crate-fetch crate-name make-crate-sexp))
+
+(define (guix-package->crate-name package)
+  "Return the crate name of PACKAGE."
+  (and-let* ((origin (package-source package))
+             (uri (origin-uri origin))
+             (crate-url? uri)
+             (len (string-length crate-url))
+             (path (xsubstring uri len))
+             (parts (string-split path #\/)))
+    (match parts
+      ((name _ ...) name))))
+
+(define (crate-name->package-name name)
+  (string-append "rust-" (string-join (string-split name #\_) "-")))
+
+;;;
+;;; Updater
+;;;
+
+(define (crate-package? package)
+  "Return true if PACKAGE is a Rust crate from crates.io."
+  (let ((source-url (and=> (package-source package) origin-uri))
+        (fetch-method (and=> (package-source package) origin-method)))
+    (and (eq? fetch-method download:url-fetch)
+         (match source-url
+           ((? string?)
+            (crate-url? source-url))
+           ((source-url ...)
+            (any crate-url? source-url))))))
+
+(define (latest-release package)
+  "Return an <upstream-source> for the latest release of PACKAGE."
+  (let* ((crate-name (guix-package->crate-name package))
+         (callback (lambda* (#:key version #:allow-other-keys) version))
+         (version (crate-fetch crate-name callback))
+         (url (crate-uri crate-name version)))
+    (upstream-source
+     (package (package-name package))
+     (version version)
+     (urls (list url)))))
+
+(define %crate-updater
+  (upstream-updater
+   (name 'crates)
+   (description "Updater for crates.io packages")
+   (pred crate-package?)
+   (latest latest-release)))
+
diff --git a/guix/import/elpa.scm b/guix/import/elpa.scm
index 320a09e8c6..96cf5bbae6 100644
--- a/guix/import/elpa.scm
+++ b/guix/import/elpa.scm
@@ -89,7 +89,13 @@ NAMES (strings)."
   "Fetch URL, store the content in a temporary file and call PROC with that
 file.  Returns the value returned by PROC.  On error call ERROR-THUNK and
 return its value or leave if it's false."
-  (proc (http-fetch/cached (string->uri url))))
+  (catch #t
+    (lambda ()
+      (proc (http-fetch/cached (string->uri url))))
+    (lambda (key . args)
+      (if error-thunk
+          (error-thunk)
+          (leave (_ "~A: download failed~%") url)))))
 
 (define (is-elpa-package? name elpa-pkg-spec)
   "Return true if the string NAME corresponds to the name of the package
@@ -222,7 +228,7 @@ type '<elpa-package>'."
                         (bytevector->nix-base32-string (file-sha256 tarball))
                         "failed to download package")))))
        (build-system emacs-build-system)
-       ,@(maybe-inputs 'inputs dependencies)
+       ,@(maybe-inputs 'propagated-inputs dependencies)
        (home-page ,(elpa-package-home-page pkg))
        (synopsis ,(elpa-package-synopsis pkg))
        (description ,(elpa-package-description pkg))
diff --git a/guix/import/github.scm b/guix/import/github.scm
index 0843ddeefd..01452b12e3 100644
--- a/guix/import/github.scm
+++ b/guix/import/github.scm
@@ -23,23 +23,12 @@
   #:use-module (guix utils)
   #:use-module ((guix download) #:prefix download:)
   #:use-module (guix import utils)
+  #:use-module (guix import json)
   #:use-module (guix packages)
   #:use-module (guix upstream)
   #:use-module (web uri)
   #:export (%github-updater))
 
-(define (json-fetch* url)
-  "Return a list/hash representation of the JSON resource URL, or #f on
-failure."
-  (call-with-output-file "/dev/null"
-    (lambda (null)
-      (with-error-to-port null
-        (lambda ()
-          (call-with-temporary-output-file
-           (lambda (temp port)
-             (and (url-fetch url temp)
-                  (call-with-input-file temp json->scm)))))))))
-
 (define (find-extension url)
   "Return the extension of the archive e.g. '.tar.gz' given a URL, or
 false if none is recognized"
@@ -136,7 +125,7 @@ the package e.g. 'bedtools2'.  Return #f if there is no releases"
                    "https://api.github.com/repos/"
                    (github-user-slash-repository url)
                    "/releases"))
-         (json (json-fetch*
+         (json (json-fetch
                 (if token
                     (string-append api-url "?access_token=" token)
                     api-url))))
diff --git a/guix/import/pypi.scm b/guix/import/pypi.scm
index 9794ff9757..7cce0fc594 100644
--- a/guix/import/pypi.scm
+++ b/guix/import/pypi.scm
@@ -303,7 +303,8 @@ VERSION, SOURCE-URL, HOME-PAGE, SYNOPSIS, DESCRIPTION, and LICENSE."
   "Return true if PACKAGE is a Python package from PyPI."
 
   (define (pypi-url? url)
-    (string-prefix? "https://pypi.python.org/" url))
+    (or (string-prefix? "https://pypi.python.org/" url)
+        (string-prefix? "https://pypi.io/packages" url)))
 
   (let ((source-url (and=> (package-source package) origin-uri))
         (fetch-method (and=> (package-source package) origin-method)))
diff --git a/guix/import/utils.scm b/guix/import/utils.scm
index 057c2d9c7d..be1980d08f 100644
--- a/guix/import/utils.scm
+++ b/guix/import/utils.scm
@@ -22,6 +22,7 @@
   #:use-module (guix base32)
   #:use-module ((guix build download) #:prefix build:)
   #:use-module (guix hash)
+  #:use-module (guix http-client)
   #:use-module ((guix licenses) #:prefix license:)
   #:use-module (guix utils)
   #:use-module (ice-9 match)
@@ -36,6 +37,10 @@
             url-fetch
             guix-hash-url
 
+            maybe-inputs
+            maybe-native-inputs
+            package->definition
+
             spdx-string->license
             license->symbol
 
@@ -205,3 +210,34 @@ into a proper sentence and by using two spaces between sentences."
     ;; Use double spacing between sentences
     (regexp-substitute/global #f "\\. \\b"
                               cleaned 'pre ".  " 'post)))
+
+(define* (package-names->package-inputs names #:optional (output #f))
+  (map (lambda (input)
+         (cons* input (list 'unquote (string->symbol input))
+                            (or (and output (list output))
+                                '())))
+       names))
+
+(define* (maybe-inputs package-names #:optional (output #f))
+  "Given a list of PACKAGE-NAMES, tries to generate the 'inputs' field of a
+package definition."
+  (match (package-names->package-inputs package-names output)
+    (()
+     '())
+    ((package-inputs ...)
+     `((inputs (,'quasiquote ,package-inputs))))))
+
+(define* (maybe-native-inputs package-names #:optional (output #f))
+  "Given a list of PACKAGE-NAMES, tries to generate the 'inputs' field of a
+package definition."
+  (match (package-names->package-inputs package-names output)
+    (()
+     '())
+    ((package-inputs ...)
+     `((native-inputs (,'quasiquote ,package-inputs))))))
+
+(define (package->definition guix-package)
+  (match guix-package
+    (('package ('name (? string? name)) _ ...)
+     `(define-public ,(string->symbol name)
+        ,guix-package))))