Merge branch 'staging' into core-updates

4 files changed, 146 insertions, 88 deletions

diff --git a/guix/import/cpan.scm b/guix/import/cpan.scm
index 08bed8767c..d0ff64ed05 100644
--- a/guix/import/cpan.scm
+++ b/guix/import/cpan.scm
@@ -2,7 +2,7 @@
 ;;; Copyright © 2014 Eric Bavier <bavier@member.fsf.org>
 ;;; Copyright © 2015 Mark H Weaver <mhw@netris.org>
 ;;; Copyright © 2016 Alex Sassmannshausen <alex@pompo.co>
-;;; Copyright © 2017 Tobias Geerinckx-Rice <me@tobias.gr>
+;;; Copyright © 2017, 2018 Tobias Geerinckx-Rice <me@tobias.gr>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -117,7 +117,7 @@ or #f on failure.  MODULE should be e.g. \"Test::Script\""
   (json-fetch-alist (string-append "https://fastapi.metacpan.org/v1/release/" name)))
 
 (define (cpan-home name)
-  (string-append "http://search.cpan.org/dist/" name "/"))
+  (string-append "https://metacpan.org/release/" name))
 
 (define (cpan-source-url meta)
   "Return the download URL for a module's source tarball."
diff --git a/guix/import/github.scm b/guix/import/github.scm
index ef226911b9..af9f56e1dc 100644
--- a/guix/import/github.scm
+++ b/guix/import/github.scm
@@ -1,6 +1,6 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2016 Ben Woodcroft <donttrustben@gmail.com>
-;;; Copyright © 2017 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2017, 2018 Ludovic Courtès <ludo@gnu.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -120,41 +120,73 @@ repository separated by a forward slash, from a string URL of the form
   ;; limit, or #f.
   (make-parameter (getenv "GUIX_GITHUB_TOKEN")))
 
+(define (fetch-releases-or-tags url)
+  "Fetch the list of \"releases\" or, if it's empty, the list of tags for the
+repository at URL.  Return the corresponding JSON dictionaries (hash tables),
+or #f if the information could not be retrieved.
+
+We look at both /releases and /tags because the \"release\" feature of GitHub
+is little used; often, people simply provide a tag.  What's confusing is that
+tags show up in the \"Releases\" tab of the web UI.  For instance,
+'https://github.com/aconchillo/guile-json/releases' shows a number of
+\"releases\" (really: tags), whereas
+'https://api.github.com/repos/aconchillo/guile-json/releases' returns the
+empty list."
+  (define release-url
+    (string-append "https://api.github.com/repos/"
+                   (github-user-slash-repository url)
+                   "/releases"))
+  (define tag-url
+    (string-append "https://api.github.com/repos/"
+                   (github-user-slash-repository url)
+                   "/tags"))
+
+  (define headers
+    ;; Ask for version 3 of the API as suggested at
+    ;; <https://developer.github.com/v3/>.
+    `((Accept . "application/vnd.github.v3+json")
+      (user-agent . "GNU Guile")))
+
+  (define (decorate url)
+    (if (%github-token)
+        (string-append url "?access_token=" (%github-token))
+        url))
+
+  (match (json-fetch (decorate release-url) #:headers headers)
+    (()
+     ;; We got the empty list, presumably because the user didn't use GitHub's
+     ;; "release" mechanism, but hopefully they did use Git tags.
+     (json-fetch (decorate tag-url) #:headers headers))
+    (x x)))
+
 (define (latest-released-version url package-name)
   "Return a string of the newest released version name given a string URL like
 'https://github.com/arq5x/bedtools2/archive/v2.24.0.tar.gz' and the name of
 the package e.g. 'bedtools2'.  Return #f if there is no releases"
-  (let* ((token (%github-token))
-         (api-url (string-append
-                   "https://api.github.com/repos/"
-                   (github-user-slash-repository url)
-                   "/releases"))
-         (json (json-fetch
-                (if token
-                    (string-append api-url "?access_token=" token)
-                    api-url))))
+  (let* ((json (fetch-releases-or-tags url)))
     (if (eq? json #f)
-        (if token
+        (if (%github-token)
             (error "Error downloading release information through the GitHub
 API when using a GitHub token")
             (error "Error downloading release information through the GitHub
 API. This may be fixed by using an access token and setting the environment
 variable GUIX_GITHUB_TOKEN, for instance one procured from
 https://github.com/settings/tokens"))
-        (let ((proper-releases
-               (filter
-                (lambda (x)
-                  ;; example pre-release:
-                  ;; https://github.com/wwood/OrfM/releases/tag/v0.5.1
-                  ;; or an all-prerelease set
-                  ;; https://github.com/powertab/powertabeditor/releases
-                  (not (hash-ref x "prerelease")))
-                json)))
-          (match proper-releases
-            (()                       ;empty release list
+        (let loop ((releases
+                    (filter
+                     (lambda (x)
+                       ;; example pre-release:
+                       ;; https://github.com/wwood/OrfM/releases/tag/v0.5.1
+                       ;; or an all-prerelease set
+                       ;; https://github.com/powertab/powertabeditor/releases
+                       (not (hash-ref x "prerelease")))
+                     json)))
+          (match releases
+            (()                                   ;empty release list
              #f)
-            ((release . rest)         ;one or more releases
-             (let ((tag (hash-ref release "tag_name"))
+            ((release . rest)                     ;one or more releases
+             (let ((tag (or (hash-ref release "tag_name") ;a "release"
+                            (hash-ref release "name")))   ;a tag
                    (name-length (string-length package-name)))
                ;; some tags include the name of the package e.g. "fdupes-1.51"
                ;; so remove these
@@ -164,8 +196,16 @@ https://github.com/settings/tokens"))
                    (substring tag (+ name-length 1))
                    ;; some tags start with a "v" e.g. "v0.25.0"
                    ;; where some are just the version number
-                   (if (eq? (string-ref tag 0) #\v)
-                       (substring tag 1) tag)))))))))
+                   (if (string-prefix? "v" tag)
+                       (substring tag 1)
+
+                       ;; Finally, reject tags that don't start with a digit:
+                       ;; they may not represent a release.
+                       (if (and (not (string-null? tag))
+                                (char-set-contains? char-set:digit
+                                                    (string-ref tag 0)))
+                           tag
+                           (loop rest)))))))))))
 
 (define (latest-release pkg)
   "Return an <upstream-source> for the latest release of PKG."
diff --git a/guix/import/hackage.scm b/guix/import/hackage.scm
index 3b138f8c98..3c00f680bf 100644
--- a/guix/import/hackage.scm
+++ b/guix/import/hackage.scm
@@ -30,15 +30,17 @@
   #:use-module ((guix utils) #:select (package-name->name+version
                                        canonical-newline-port))
   #:use-module (guix http-client)
-  #:use-module ((guix import utils) #:select (factorize-uri))
+  #:use-module ((guix import utils) #:select (factorize-uri recursive-import))
   #:use-module (guix import cabal)
   #:use-module (guix store)
   #:use-module (guix hash)
   #:use-module (guix base32)
+  #:use-module (guix memoization)
   #:use-module (guix upstream)
   #:use-module (guix packages)
   #:use-module ((guix utils) #:select (call-with-temporary-output-file))
   #:export (hackage->guix-package
+            hackage-recursive-import
             %hackage-updater
 
             guix-package->hackage-name
@@ -205,32 +207,34 @@ representation of a Cabal file as produced by 'read-cabal'."
   (define source-url
     (hackage-source-url name version))
 
+  (define hackage-dependencies
+    ((compose (cut filter-dependencies <>
+                   (cabal-package-name cabal))
+              (cut cabal-dependencies->names <>))
+     cabal))
+
+  (define hackage-native-dependencies
+    ((compose (cut filter-dependencies <>
+                   (cabal-package-name cabal))
+              ;; FIXME: Check include-test-dependencies?
+              (lambda (cabal)
+                (append (if include-test-dependencies?
+                            (cabal-test-dependencies->names cabal)
+                            '())
+                        (cabal-custom-setup-dependencies->names cabal))))
+     cabal))
+
   (define dependencies
-    (let ((names
-           (map hackage-name->package-name
-                ((compose (cut filter-dependencies <>
-                               (cabal-package-name cabal))
-                          (cut cabal-dependencies->names <>))
-                 cabal))))
-      (map (lambda (name)
-             (list name (list 'unquote (string->symbol name))))
-           names)))
+    (map (lambda (name)
+           (list name (list 'unquote (string->symbol name))))
+         (map hackage-name->package-name
+              hackage-dependencies)))
 
   (define native-dependencies
-    (let ((names
-           (map hackage-name->package-name
-                ((compose (cut filter-dependencies <>
-                               (cabal-package-name cabal))
-                          ;; FIXME: Check include-test-dependencies?
-                          (lambda (cabal)
-                            (append (if include-test-dependencies?
-                                        (cabal-test-dependencies->names cabal)
-                                        '())
-                                    (cabal-custom-setup-dependencies->names cabal))))
-                 cabal))))
-      (map (lambda (name)
-             (list name (list 'unquote (string->symbol name))))
-           names)))
+    (map (lambda (name)
+           (list name (list 'unquote (string->symbol name))))
+         (map hackage-name->package-name
+              hackage-native-dependencies)))
   
   (define (maybe-inputs input-type inputs)
     (match inputs
@@ -247,31 +251,35 @@ representation of a Cabal file as produced by 'read-cabal'."
 
   (let ((tarball (with-store store
                    (download-to-store store source-url))))
-    `(package
-       (name ,(hackage-name->package-name name))
-       (version ,version)
-       (source (origin
-                 (method url-fetch)
-                 (uri (string-append ,@(factorize-uri source-url version)))
-                 (sha256
-                  (base32
-                   ,(if tarball
-                        (bytevector->nix-base32-string (file-sha256 tarball))
-                        "failed to download tar archive")))))
-       (build-system haskell-build-system)
-       ,@(maybe-inputs 'inputs dependencies)
-       ,@(maybe-inputs 'native-inputs native-dependencies)
-       ,@(maybe-arguments)
-       (home-page ,(cabal-package-home-page cabal))
-       (synopsis ,(cabal-package-synopsis cabal))
-       (description ,(cabal-package-description cabal))
-       (license ,(string->license (cabal-package-license cabal))))))
+    (values
+     `(package
+        (name ,(hackage-name->package-name name))
+        (version ,version)
+        (source (origin
+                  (method url-fetch)
+                  (uri (string-append ,@(factorize-uri source-url version)))
+                  (sha256
+                   (base32
+                    ,(if tarball
+                         (bytevector->nix-base32-string (file-sha256 tarball))
+                         "failed to download tar archive")))))
+        (build-system haskell-build-system)
+        ,@(maybe-inputs 'inputs dependencies)
+        ,@(maybe-inputs 'native-inputs native-dependencies)
+        ,@(maybe-arguments)
+        (home-page ,(cabal-package-home-page cabal))
+        (synopsis ,(cabal-package-synopsis cabal))
+        (description ,(cabal-package-description cabal))
+        (license ,(string->license (cabal-package-license cabal))))
+     (append hackage-dependencies hackage-native-dependencies))))
 
-(define* (hackage->guix-package package-name #:key
-                                (include-test-dependencies? #t)
-                                (port #f)
-                                (cabal-environment '()))
-  "Fetch the Cabal file for PACKAGE-NAME from hackage.haskell.org, or, if the
+(define hackage->guix-package
+  (memoize
+   (lambda* (package-name #:key
+                          (include-test-dependencies? #t)
+                          (port #f)
+                          (cabal-environment '()))
+     "Fetch the Cabal file for PACKAGE-NAME from hackage.haskell.org, or, if the
 called with keyword parameter PORT, from PORT.  Return the `package'
 S-expression corresponding to that package, or #f on failure.
 CABAL-ENVIRONMENT is an alist defining the environment in which the Cabal
@@ -281,13 +289,19 @@ symbol 'true' or 'false'.  The value associated with other keys has to conform
 to the Cabal file format definition.  The default value associated with the
 keys \"os\", \"arch\" and \"impl\" is \"linux\", \"x86_64\" and \"ghc\"
 respectively."
-  (let ((cabal-meta (if port
-                        (read-cabal (canonical-newline-port port))
-                        (hackage-fetch package-name))))
-    (and=> cabal-meta (compose (cut hackage-module->sexp <>
-                                    #:include-test-dependencies? 
-                                    include-test-dependencies?)
-                               (cut eval-cabal <> cabal-environment)))))
+     (let ((cabal-meta (if port
+                           (read-cabal (canonical-newline-port port))
+                           (hackage-fetch package-name))))
+       (and=> cabal-meta (compose (cut hackage-module->sexp <>
+                                       #:include-test-dependencies?
+                                       include-test-dependencies?)
+                                  (cut eval-cabal <> cabal-environment)))))))
+
+(define* (hackage-recursive-import package-name . args)
+  (recursive-import package-name #f
+                    #:repo->guix-package (lambda (name repo)
+                                           (apply hackage->guix-package (cons name args)))
+                    #:guix-name hackage-name->package-name))
 
 (define (hackage-package? package)
   "Return #t if PACKAGE is a Haskell package from Hackage."
diff --git a/guix/import/json.scm b/guix/import/json.scm
index 3f2ab1e3ea..4f96a513df 100644
--- a/guix/import/json.scm
+++ b/guix/import/json.scm
@@ -1,6 +1,7 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2014 David Thompson <davet@gnu.org>
 ;;; Copyright © 2015, 2016 Eric Bavier <bavier@member.fsf.org>
+;;; Copyright © 2018 Ludovic Courtès <ludo@gnu.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -25,17 +26,20 @@
   #:export (json-fetch
             json-fetch-alist))
 
-(define (json-fetch url)
+(define* (json-fetch url
+                     ;; Note: many websites returns 403 if we omit a
+                     ;; 'User-Agent' header.
+                     #:key (headers `((user-agent . "GNU Guile")
+                                      (Accept . "application/json"))))
   "Return a representation of the JSON resource URL (a list or hash table), or
-#f if URL returns 403 or 404."
+#f if URL returns 403 or 404.  HEADERS is a list of HTTP headers to pass in
+the query."
   (guard (c ((and (http-get-error? c)
                   (let ((error (http-get-error-code c)))
                     (or (= 403 error)
                         (= 404 error))))
              #f))
-    ;; Note: many websites returns 403 if we omit a 'User-Agent' header.
-    (let* ((port   (http-fetch url #:headers '((user-agent . "GNU Guile")
-                                               (Accept . "application/json"))))
+    (let* ((port   (http-fetch url #:headers headers))
            (result (json->scm port)))
       (close-port port)
       result)))