Merge branch 'master' into core-updates-frozen

4 files changed, 147 insertions, 79 deletions

diff --git a/guix/import/cran.scm b/guix/import/cran.scm
index 420cd3b63a..1389576cad 100644
--- a/guix/import/cran.scm
+++ b/guix/import/cran.scm
@@ -229,26 +229,61 @@ bioconductor package NAME, or #F if the package is unknown."
                 (let ((store-directory
                        (add-to-store store (basename url) #t "sha256" dir)))
                   (values store-directory changeset)))))))
-        (else (download-to-store store url)))))))
-
-(define (fetch-description repository name)
+        (else
+         (match url
+           ((? string?)
+            (download-to-store store url))
+           ((urls ...)
+            ;; Try all the URLs.  A use case where this is useful is when one
+            ;; of the URLs is the /Archive CRAN URL.
+            (any (cut download-to-store store <>) urls)))))))))
+
+(define (fetch-description-from-tarball url)
+  "Fetch the tarball at URL, extra its 'DESCRIPTION' file, parse it, and
+return the resulting alist."
+  (match (download url)
+    (#f #f)
+    (tarball
+     (call-with-temporary-directory
+      (lambda (dir)
+        (parameterize ((current-error-port (%make-void-port "rw+"))
+                       (current-output-port (%make-void-port "rw+")))
+          (and (zero? (system* "tar" "--wildcards" "-x"
+                               "--strip-components=1"
+                               "-C" dir
+                               "-f" tarball "*/DESCRIPTION"))
+               (description->alist
+                (call-with-input-file (string-append dir "/DESCRIPTION")
+                  read-string)))))))))
+
+(define* (fetch-description repository name #:optional version)
   "Return an alist of the contents of the DESCRIPTION file for the R package
-NAME in the given REPOSITORY, or #f in case of failure.  NAME is
+NAME at VERSION in the given REPOSITORY, or #f in case of failure.  NAME is
 case-sensitive."
   (case repository
     ((cran)
-     (let ((url (string-append %cran-url name "/DESCRIPTION")))
-       (guard (c ((http-get-error? c)
-                  (warning (G_ "failed to retrieve package information \
+     (guard (c ((http-get-error? c)
+                (warning (G_ "failed to retrieve package information \
 from ~a: ~a (~a)~%")
-                           (uri->string (http-get-error-uri c))
-                           (http-get-error-code c)
-                           (http-get-error-reason c))
-                  #f))
-         (let* ((port   (http-fetch url))
-                (result (description->alist (read-string port))))
-           (close-port port)
-           result))))
+                         (uri->string (http-get-error-uri c))
+                         (http-get-error-code c)
+                         (http-get-error-reason c))
+                #f))
+       ;; When VERSION is true, we have to download the tarball to get at its
+       ;; 'DESCRIPTION' file; only the latest one is directly accessible over
+       ;; HTTP.
+       (if version
+           (let ((urls (list (string-append "mirror://cran/src/contrib/"
+                                            name "_" version ".tar.gz")
+                             (string-append "mirror://cran/src/contrib/Archive/"
+                                            name "/"
+                                            name "_" version ".tar.gz"))))
+             (fetch-description-from-tarball urls))
+           (let* ((url    (string-append %cran-url name "/DESCRIPTION"))
+                  (port   (http-fetch url))
+                  (result (description->alist (read-string port))))
+             (close-port port)
+             result))))
     ((bioconductor)
      ;; Currently, the bioconductor project does not offer a way to access a
      ;; package's DESCRIPTION file over HTTP, so we determine the version,
@@ -257,22 +292,13 @@ from ~a: ~a (~a)~%")
                           (and (latest-bioconductor-package-version name) #t)
                           (and (latest-bioconductor-package-version name 'annotation) 'annotation)
                           (and (latest-bioconductor-package-version name 'experiment) 'experiment)))
+                ;; TODO: Honor VERSION.
                 (version (latest-bioconductor-package-version name type))
                 (url     (car (bioconductor-uri name version type)))
-                (tarball (download url)))
-       (call-with-temporary-directory
-        (lambda (dir)
-          (parameterize ((current-error-port (%make-void-port "rw+"))
-                         (current-output-port (%make-void-port "rw+")))
-            (and (zero? (system* "tar" "--wildcards" "-x"
-                                 "--strip-components=1"
-                                 "-C" dir
-                                 "-f" tarball "*/DESCRIPTION"))
-                 (and=> (description->alist (with-input-from-file
-                                                (string-append dir "/DESCRIPTION") read-string))
-                        (lambda (meta)
-                          (if (boolean? type) meta
-                              (cons `(bioconductor-type . ,type) meta))))))))))
+                (meta    (fetch-description-from-tarball url)))
+       (if (boolean? type)
+           meta
+           (cons `(bioconductor-type . ,type) meta))))
     ((git)
      (and (string-prefix? "http" name)
           ;; Download the git repository at "NAME"
@@ -485,7 +511,7 @@ from the alist META, which was derived from the R package's DESCRIPTION file."
                                         ((bioconductor)
                                          (list (assoc-ref meta 'bioconductor-type)))
                                         (else '())))
-                          ((url rest ...) url)
+                          ((urls ...) urls)
                           ((? string? url) url)
                           (_ #f)))))
          (git?       (assoc-ref meta 'git))
@@ -592,7 +618,7 @@ from the alist META, which was derived from the R package's DESCRIPTION file."
    (lambda* (package-name #:key (repo 'cran) version)
      "Fetch the metadata for PACKAGE-NAME from REPO and return the `package'
 s-expression corresponding to that package, or #f on failure."
-     (let ((description (fetch-description repo package-name)))
+     (let ((description (fetch-description repo package-name version)))
        (if description
            (description->package repo description)
            (case repo
@@ -610,8 +636,9 @@ s-expression corresponding to that package, or #f on failure."
                       (&message
                        (message "couldn't find meta-data for R package")))))))))))
 
-(define* (cran-recursive-import package-name #:key (repo 'cran))
+(define* (cran-recursive-import package-name #:key (repo 'cran) version)
   (recursive-import package-name
+                    #:version version
                     #:repo repo
                     #:repo->guix-package cran->guix-package
                     #:guix-name cran-guix-name))
diff --git a/guix/import/print.scm b/guix/import/print.scm
index c1739f35e3..66016145cb 100644
--- a/guix/import/print.scm
+++ b/guix/import/print.scm
@@ -26,6 +26,7 @@
   #:use-module (guix build-system)
   #:use-module (gnu packages)
   #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-26)
   #:use-module (guix import utils)
   #:use-module (ice-9 control)
   #:use-module (ice-9 match)
@@ -39,9 +40,6 @@
            (_ #f))
          inputs))
 
-;; FIXME: the quasiquoted arguments field may contain embedded package
-;; objects, e.g. in #:disallowed-references; they will just be printed with
-;; their usual #<package ...> representation, not as variable names.
 (define (package->code package)
   "Return an S-expression representing the source code that produces PACKAGE
 when evaluated."
@@ -81,6 +79,11 @@ when evaluated."
       (file-type (quote ,(search-path-specification-file-type spec)))
       (file-pattern ,(search-path-specification-file-pattern spec))))
 
+  (define (factorized-uri-code uri version)
+    (match (factorize-uri uri version)
+      ((? string? uri) uri)
+      ((factorized ...) `(string-append ,@factorized))))
+
   (define (source->code source version)
     (let ((uri       (origin-uri source))
           (method    (origin-method source))
@@ -98,9 +101,14 @@ when evaluated."
                              (guix hg-download)
                              (guix svn-download)))
                       (procedure-name method)))
-         (uri (string-append ,@(match (factorize-uri uri version)
-                                 ((? string? uri) (list uri))
-                                 (factorized factorized))))
+         (uri ,(if version
+                   (match uri
+                     ((? string? uri)
+                      (factorized-uri-code uri version))
+                     ((lst ...)
+                      `(list
+                        ,@(map (cut factorized-uri-code <> version) uri))))
+                   uri))
          ,(if (equal? (content-hash-algorithm hash) 'sha256)
               `(sha256 (base32 ,(bytevector->nix-base32-string
                                  (content-hash-value hash))))
@@ -110,36 +118,62 @@ when evaluated."
          ;; FIXME: in order to be able to throw away the directory prefix,
          ;; we just assume that the patch files can be found with
          ;; "search-patches".
-         ,@(if (null? patches) '()
-               `((patches (search-patches ,@(map basename patches))))))))
+         ,@(cond ((null? patches)
+                  '())
+                 ((every string? patches)
+                  `((patches (search-patches ,@(map basename patches)))))
+                 (else
+                  `((patches (list ,@(map (match-lambda
+                                            ((? string? file)
+                                             `(search-patch ,file))
+                                            ((? origin? origin)
+                                             (source->code origin #f)))
+                                          patches)))))))))
+
+  (define (variable-reference module name)
+    ;; FIXME: using '@ certainly isn't pretty, but it avoids having to import
+    ;; the individual package modules.
+    (list '@ module name))
+
+  (define (object->code obj quoted?)
+    (match obj
+      ((? package? package)
+       (let* ((module (package-module-name package))
+              (name   (variable-name package module)))
+         (if quoted?
+             (list 'unquote (variable-reference module name))
+             (variable-reference module name))))
+      ((? origin? origin)
+       (let ((code (source->code origin #f)))
+         (if quoted?
+             (list 'unquote code)
+             code)))
+      ((lst ...)
+       (let ((lst (map (cut object->code <> #t) lst)))
+         (if quoted?
+             lst
+             (list 'quasiquote lst))))
+      (obj
+       obj)))
 
   (define (inputs->code inputs)
     (if (redundant-input-labels? inputs)
         `(list ,@(map (match-lambda    ;no need for input labels ("new style")
                         ((_ package)
-                         (let ((module (package-module-name package)))
-                           `(@ ,module ,(variable-name package module))))
+                         (let* ((module (package-module-name package))
+                                (name   (variable-name package module)))
+                           (variable-reference module name)))
                         ((_ package output)
-                         (let ((module (package-module-name package)))
+                         (let* ((module (package-module-name package))
+                                (name   (variable-name package module)))
                            (list 'quasiquote
                                  (list
                                   (list 'unquote
-                                        `(@ ,module
-                                            ,(variable-name package module)))
+                                        (variable-reference module name))
                                   output)))))
                       inputs))
         (list 'quasiquote                  ;preserve input labels (deprecated)
-              (map (match-lambda
-                     ((label pkg . out)
-                      (let ((mod (package-module-name pkg)))
-                        (cons* label
-                               ;; FIXME: using '@ certainly isn't pretty, but it
-                               ;; avoids having to import the individual package
-                               ;; modules.
-                               (list 'unquote
-                                     (list '@ mod (variable-name pkg mod)))
-                               out))))
-                   inputs))))
+              (object->code inputs #t))))
 
   (let ((name                (package-name package))
         (version             (package-version package))
@@ -175,7 +209,8 @@ when evaluated."
                                           '-build-system)))
          ,@(match arguments
              (() '())
-             (args `((arguments ,(list 'quasiquote args)))))
+             (_  `((arguments
+                    ,(list 'quasiquote (object->code arguments #t))))))
          ,@(match outputs
              (("out") '())
              (outs `((outputs (list ,@outs)))))
diff --git a/guix/import/pypi.scm b/guix/import/pypi.scm
index d5035b790b..2b33b3b8bc 100644
--- a/guix/import/pypi.scm
+++ b/guix/import/pypi.scm
@@ -128,27 +128,30 @@
   missing-source-error?
   (package  missing-source-error-package))
 
-(define (latest-source-release pypi-package)
-  "Return the latest source release for PYPI-PACKAGE."
-  (let ((releases (assoc-ref (pypi-project-releases pypi-package)
-                             (project-info-version
-                              (pypi-project-info pypi-package)))))
+(define (latest-version project)
+  "Return the latest version of PROJECT, a <pypi-project> record."
+  (project-info-version (pypi-project-info project)))
+
+(define* (source-release pypi-package
+                         #:optional (version (latest-version pypi-package)))
+  "Return the source release of VERSION for PYPI-PACKAGE, a <pypi-project>
+record, by default the latest version."
+  (let ((releases (or (assoc-ref (pypi-project-releases pypi-package) version)
+                      '())))
     (or (find (lambda (release)
                 (string=? "sdist" (distribution-package-type release)))
               releases)
         (raise (condition (&missing-source-error
                            (package pypi-package)))))))
 
-(define (latest-wheel-release pypi-package)
+(define* (wheel-release pypi-package
+                        #:optional (version (latest-version pypi-package)))
   "Return the url of the wheel for the latest release of pypi-package,
 or #f if there isn't any."
-  (let ((releases (assoc-ref (pypi-project-releases pypi-package)
-                             (project-info-version
-                              (pypi-project-info pypi-package)))))
-    (or (find (lambda (release)
-                (string=? "bdist_wheel" (distribution-package-type release)))
-              releases)
-        #f)))
+  (let ((releases (assoc-ref (pypi-project-releases pypi-package) version)))
+    (find (lambda (release)
+            (string=? "bdist_wheel" (distribution-package-type release)))
+          releases)))
 
 (define (python->package-name name)
   "Given the NAME of a package on PyPI, return a Guix-compliant name for the
@@ -477,18 +480,17 @@ VERSION, SOURCE-URL, HOME-PAGE, SYNOPSIS, DESCRIPTION, and LICENSE."
      "Fetch the metadata for PACKAGE-NAME from pypi.org, and return the
 `package' s-expression corresponding to that package, or #f on failure."
      (let* ((project (pypi-fetch package-name))
-            (info    (and project (pypi-project-info project))))
+            (info    (and=> project pypi-project-info))
+            (version (or version (and=> project latest-version))))
        (and project
             (guard (c ((missing-source-error? c)
                        (let ((package (missing-source-error-package c)))
                          (leave (G_ "no source release for pypi package ~a ~a~%")
-                                (project-info-name info)
-                                (project-info-version info)))))
-              (make-pypi-sexp (project-info-name info)
-                              (project-info-version info)
-                              (and=> (latest-source-release project)
+                                (project-info-name info) version))))
+              (make-pypi-sexp (project-info-name info) version
+                              (and=> (source-release project version)
                                      distribution-url)
-                              (and=> (latest-wheel-release project)
+                              (and=> (wheel-release project version)
                                      distribution-url)
                               (project-info-home-page info)
                               (project-info-summary info)
@@ -496,8 +498,9 @@ VERSION, SOURCE-URL, HOME-PAGE, SYNOPSIS, DESCRIPTION, and LICENSE."
                               (string->license
                                (project-info-license info)))))))))
 
-(define (pypi-recursive-import package-name)
+(define* (pypi-recursive-import package-name #:optional version)
   (recursive-import package-name
+                    #:version version
                     #:repo->guix-package pypi->guix-package
                     #:guix-name python->package-name))
 
@@ -531,7 +534,7 @@ VERSION, SOURCE-URL, HOME-PAGE, SYNOPSIS, DESCRIPTION, and LICENSE."
            (let* ((info    (pypi-project-info pypi-package))
                   (version (project-info-version info))
                   (url     (distribution-url
-                            (latest-source-release pypi-package))))
+                            (source-release pypi-package))))
              (upstream-source
               (urls (list url))
               (input-changes
diff --git a/guix/import/utils.scm b/guix/import/utils.scm
index a180742ca3..dc89386ddb 100644
--- a/guix/import/utils.scm
+++ b/guix/import/utils.scm
@@ -152,6 +152,7 @@ of the string VERSION is replaced by the symbol 'version."
     ("CC0-1.0"                     'license:cc0)
     ("CC-BY-2.0"                   'license:cc-by2.0)
     ("CC-BY-3.0"                   'license:cc-by3.0)
+    ("CC-BY-4.0"                   'license:cc-by4.0)
     ("CC-BY-SA-2.0"                'license:cc-by-sa2.0)
     ("CC-BY-SA-3.0"                'license:cc-by-sa3.0)
     ("CC-BY-SA-4.0"                'license:cc-by-sa4.0)
@@ -163,6 +164,7 @@ of the string VERSION is replaced by the symbol 'version."
     ("EPL-1.0"                     'license:epl1.0)
     ("MIT"                         'license:expat)
     ("FTL"                         'license:freetype)
+    ("Freetype"                    'license:freetype)
     ("GFDL-1.1"                    'license:fdl1.1+)
     ("GFDL-1.2"                    'license:fdl1.2+)
     ("GFDL-1.3"                    'license:fdl1.3+)
@@ -179,6 +181,7 @@ of the string VERSION is replaced by the symbol 'version."
     ("GPL-3.0-only"                'license:gpl3)
     ("GPL-3.0+"                    'license:gpl3+)
     ("GPL-3.0-or-later"            'license:gpl3+)
+    ("HPND"                        'license:hpnd)
     ("ISC"                         'license:isc)
     ("IJG"                         'license:ijg)
     ("Imlib2"                      'license:imlib2)