Merge remote-tracking branch 'origin/master' into core-updates

16 files changed, 168 insertions, 88 deletions

diff --git a/guix/build/go-build-system.scm b/guix/build/go-build-system.scm
index 72af6ce7b6..d175f3b76a 100644
--- a/guix/build/go-build-system.scm
+++ b/guix/build/go-build-system.scm
@@ -171,7 +171,7 @@ respectively."
       (setenv "GOPATH" (string-append (getcwd) ":" (getenv "GOPATH")))
       (setenv "GOPATH" (getcwd)))
     ;; Where to install compiled executable files ('commands' in Go parlance').
-    (setenv "GOBIN" out)
+    (setenv "GOBIN" (string-append out "/bin"))
     #t))
 
 (define* (build #:key import-path #:allow-other-keys)
diff --git a/guix/download.scm b/guix/download.scm
index 449521c199..1bd4875b10 100644
--- a/guix/download.scm
+++ b/guix/download.scm
@@ -176,28 +176,63 @@
        "ftp://mirrors.go-part.com/xorg/"
        "http://x.cs.pu.edu.tw/"
        "ftp://ftp.is.co.za/pub/x.org")            ; South Africa
-      (cpan                              ; from http://www.cpan.org/SITES.html
-       "http://mirror.ibcp.fr/pub/CPAN/"
-       "ftp://ftp.ciril.fr/pub/cpan/"
-       "ftp://artfiles.org/cpan.org/"
+      (cpan
        "http://www.cpan.org/"
-       "ftp://cpan.rinet.ru/pub/mirror/CPAN/"
-       "ftp://cpan.inode.at/"
-       "ftp://cpan.iht.co.il/"
-       "ftp://ftp.osuosl.org/pub/CPAN/"
-       "ftp://ftp.nara.wide.ad.jp/pub/CPAN/"
-       "http://mirrors.163.com/cpan/"
-       "ftp://cpan.mirror.ac.za/"
-       "http://cpan.mirrors.ionfish.org/"
-       "http://cpan.mirror.dkm.cz/pub/CPAN/"
-       "http://cpan.mirror.iphh.net/"
-       "http://mirrors.teentelecom.net/CPAN/"
-       "http://mirror.teklinks.com/CPAN/"
-       "http://cpan.weepeetelecom.be/"
-       "http://mirrors.xservers.ro/CPAN/"
-       "http://cpan.yimg.com/"
-       "http://mirror.yazd.ac.ir/cpan/"
-       "http://ftp.belnet.be/ftp.cpan.org/")
+       "http://cpan.metacpan.org/"
+       ;; A selection of HTTP mirrors from http://www.cpan.org/SITES.html.
+       ;; Europe.
+       "http://ftp.belnet.be/mirror/ftp.cpan.org/"
+       "http://mirrors.nic.cz/CPAN/"
+       "http://mirror.ibcp.fr/pub/CPAN/"
+       "http://ftp.ntua.gr/pub/lang/perl/"
+       "http://kvin.lv/pub/CPAN/"
+       "http://mirror.as43289.net/pub/CPAN/"
+       "http://cpan.cs.uu.nl/"
+       "http://cpan.uib.no/"
+       "http://cpan-mirror.rbc.ru/pub/CPAN/"
+       "http://mirror.sbb.rs/CPAN/"
+       "http://cpan.lnx.sk/"
+       "http://ftp.rediris.es/mirror/CPAN/"
+       "http://mirror.ox.ac.uk/sites/www.cpan.org/"
+       ;; Africa.
+       "http://mirror.liquidtelecom.com/CPAN/"
+       "http://cpan.mirror.ac.za/"
+       "http://mirror.is.co.za/pub/cpan/"
+       "http://cpan.saix.net/"
+       "http://mirror.ucu.ac.ug/cpan/"
+       ;; North America.
+       "http://mirrors.gossamer-threads.com/CPAN/"
+       "http://mirror.csclub.uwaterloo.ca/CPAN/"
+       "http://mirrors.ucr.ac.cr/CPAN/"
+       "http://www.msg.com.mx/CPAN/"
+       "http://mirrors.namecheap.com/CPAN/"
+       "http://mirror.uic.edu/CPAN/"
+       "http://mirror.datapipe.net/CPAN/"
+       "http://mirror.cc.columbia.edu/pub/software/cpan/"
+       "http://mirror.uta.edu/CPAN/"
+       ;; South America.
+       "http://cpan.mmgdesigns.com.ar/"
+       "http://mirror.nbtelecom.com.br/CPAN/"
+       "http://linorg.usp.br/CPAN/"
+       "http://cpan.dcc.uchile.cl/"
+       "http://mirror.cedia.org.ec/CPAN/"
+       ;; Oceania.
+       "http://cpan.mirror.serversaustralia.com.au/"
+       "http://mirror.waia.asn.au/pub/cpan/"
+       "http://mirror.as24220.net/pub/cpan/"
+       "http://cpan.lagoon.nc/pub/CPAN/"
+       "http://cpan.inspire.net.nz/"
+       ;; Asia.
+       "http://mirror.dhakacom.com/CPAN/"
+       "http://mirrors.ustc.edu.cn/CPAN/"
+       "http://ftp.cuhk.edu.hk/pub/packages/perl/CPAN/"
+       "http://kambing.ui.ac.id/cpan/"
+       "http://cpan.hostiran.ir/"
+       "http://ftp.nara.wide.ad.jp/pub/CPAN/"
+       "http://mirror.neolabs.kz/CPAN/"
+       "http://cpan.nctu.edu.tw/"
+       "http://cpan.ulak.net.tr/"
+       "http://mirrors.vinahost.vn/CPAN/")
       (cran
        ;; Arbitrary mirrors from http://cran.r-project.org/mirrors.html
        ;; This one automatically redirects to servers worldwide
diff --git a/guix/import/cpan.scm b/guix/import/cpan.scm
index 6261e3e924..2ef02c43a4 100644
--- a/guix/import/cpan.scm
+++ b/guix/import/cpan.scm
@@ -2,6 +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>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -115,7 +116,7 @@ or #f on failure.  MODULE should be e.g. \"Test::Script\""
   (json-fetch (string-append "https://fastapi.metacpan.org/v1/release/" name)))
 
 (define (cpan-home name)
-  (string-append "http://search.cpan.org/dist/" name))
+  (string-append "http://search.cpan.org/dist/" name "/"))
 
 (define (cpan-source-url meta)
   "Return the download URL for a module's source tarball."
@@ -242,9 +243,9 @@ META."
                        ;; have not yet had a need for cross-compiled perl
                        ;; modules, however, so we leave it out.
                        (convert-inputs '("configure" "build" "test")))
-       ,@(maybe-inputs 'inputs
+       ,@(maybe-inputs 'propagated-inputs
                        (convert-inputs '("runtime")))
-       (home-page ,(string-append "http://search.cpan.org/dist/" name))
+       (home-page ,(cpan-home name))
        (synopsis ,(assoc-ref meta "abstract"))
        (description fill-in-yourself!)
        (license ,(string->license (assoc-ref meta "license"))))))
diff --git a/guix/import/elpa.scm b/guix/import/elpa.scm
index 858eea88e2..45a419217c 100644
--- a/guix/import/elpa.scm
+++ b/guix/import/elpa.scm
@@ -80,8 +80,11 @@ NAMES (strings)."
                     (cut string-append <> "/archive-contents"))))
     (if url
         ;; Use a relatively small TTL for the archive itself.
-        (parameterize ((%http-cache-ttl (* 6 3600)))
-          (call-with-downloaded-file url read))
+        (let* ((port (http-fetch/cached (string->uri url)
+                                        #:ttl (* 6 3600)))
+               (data (read port)))
+          (close-port port)
+          data)
         (leave (G_ "~A: currently not supported~%") repo))))
 
 (define* (call-with-downloaded-file url proc #:optional (error-thunk #f))
diff --git a/guix/import/github.scm b/guix/import/github.scm
index b249b39067..4b7d53c704 100644
--- a/guix/import/github.scm
+++ b/guix/import/github.scm
@@ -1,5 +1,6 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2016 Ben Woodcroft <donttrustben@gmail.com>
+;;; Copyright © 2017 Ludovic Courtès <ludo@gnu.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -19,6 +20,7 @@
 (define-module (guix import github)
   #:use-module (ice-9 match)
   #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-26)
   #:use-module (srfi srfi-34)
   #:use-module (json)
   #:use-module (guix utils)
@@ -182,7 +184,14 @@ https://github.com/settings/tokens"))
 
 (define (latest-release pkg)
   "Return an <upstream-source> for the latest release of PKG."
-  (let* ((source-uri (origin-uri (package-source pkg)))
+  (define (origin-github-uri origin)
+    (match (origin-uri origin)
+      ((? string? url)
+       url)                                       ;surely a github.com URL
+      ((urls ...)
+       (find (cut string-contains <> "github.com") urls))))
+
+  (let* ((source-uri (origin-github-uri (package-source pkg)))
          (name (package-name pkg))
          (newest-version (latest-released-version source-uri name)))
     (if newest-version
diff --git a/guix/scripts.scm b/guix/scripts.scm
index 9ff7f25548..4a7ae7baa3 100644
--- a/guix/scripts.scm
+++ b/guix/scripts.scm
@@ -67,11 +67,13 @@ reporting."
 
 (define* (parse-command-line args options seeds
                              #:key
+                             (build-options? #t)
                              (argument-handler %default-argument-handler))
-  "Parse the command-line arguments ARGS as well as arguments passed via the
-'GUIX_BUILD_OPTIONS' environment variable according to OPTIONS (a list of
-SRFI-37 options) and return the result, seeded by SEEDS.
-Command-line options take precedence those passed via 'GUIX_BUILD_OPTIONS'.
+  "Parse the command-line arguments ARGS according to OPTIONS (a list of
+SRFI-37 options) and return the result, seeded by SEEDS.  When BUILD-OPTIONS?
+is true, also pass arguments passed via the 'GUIX_BUILD_OPTIONS' environment
+variable.  Command-line options take precedence those passed via
+'GUIX_BUILD_OPTIONS'.
 
 ARGUMENT-HANDLER is called for non-option arguments, like the 'operand-proc'
 parameter of 'args-fold'."
@@ -85,7 +87,9 @@ parameter of 'args-fold'."
 
   (call-with-values
       (lambda ()
-        (parse-options-from (environment-build-options) seeds))
+        (if build-options?
+            (parse-options-from (environment-build-options) seeds)
+            (apply values seeds)))
     (lambda seeds
       ;; ARGS take precedence over what the environment variable specifies.
       (parse-options-from args seeds))))
diff --git a/guix/scripts/challenge.scm b/guix/scripts/challenge.scm
index 681394f9cf..f0693ed8df 100644
--- a/guix/scripts/challenge.scm
+++ b/guix/scripts/challenge.scm
@@ -210,6 +210,20 @@ inconclusive reports."
        (report (G_ "~a contents match:~%") item)
        (report-hashes item local narinfos)))))
 
+(define (summarize-report-list reports)
+  "Display the overall summary of REPORTS."
+  (let ((total         (length reports))
+        (inconclusive  (count comparison-report-inconclusive? reports))
+        (matches       (count comparison-report-match? reports))
+        (discrepancies (count comparison-report-mismatch? reports)))
+    (report (G_ "~h store items were analyzed:~%") total)
+    (report (G_ "  - ~h (~,1f%) were identical~%")
+            matches (* 100. (/ matches total)))
+    (report (G_ "  - ~h (~,1f%) differed~%")
+            discrepancies (* 100. (/ discrepancies total)))
+    (report (G_ "  - ~h (~,1f%) were inconclusive~%")
+            inconclusive (* 100. (/ inconclusive total)))))
+
 
 ;;;
 ;;; Command-line options.
@@ -264,7 +278,8 @@ Challenge the substitutes for PACKAGE... provided by one or more servers.\n"))
 
 (define (guix-challenge . args)
   (with-error-handling
-    (let* ((opts     (parse-command-line args %options (list %default-options)))
+    (let* ((opts     (parse-command-line args %options (list %default-options)
+                                         #:build-options? #f))
            (files    (filter-map (match-lambda
                                    (('argument . file) file)
                                    (_ #f))
@@ -292,6 +307,8 @@ Challenge the substitutes for PACKAGE... provided by one or more servers.\n"))
                                     (reports (compare-contents items urls)))
                  (for-each (cut summarize-report <> #:verbose? verbose?)
                            reports)
+                 (report "\n")
+                 (summarize-report-list reports)
 
                  (exit (cond ((any comparison-report-mismatch? reports) 2)
                              ((every comparison-report-match? reports) 0)
diff --git a/guix/scripts/gc.scm b/guix/scripts/gc.scm
index 0a9719d259..378a47d113 100644
--- a/guix/scripts/gc.scm
+++ b/guix/scripts/gc.scm
@@ -159,12 +159,8 @@ Invoke the garbage collector.\n"))
 (define (guix-gc . args)
   (define (parse-options)
     ;; Return the alist of option values.
-    (args-fold* args %options
-                (lambda (opt name arg result)
-                  (leave (G_ "~A: unrecognized option~%") name))
-                (lambda (arg result)
-                  (alist-cons 'argument arg result))
-                %default-options))
+    (parse-command-line args %options (list %default-options)
+                        #:build-options? #f))
 
   (define (symlink-target file)
     (let ((s (false-if-exception (lstat file))))
diff --git a/guix/scripts/graph.scm b/guix/scripts/graph.scm
index d5be442884..78f09f181b 100644
--- a/guix/scripts/graph.scm
+++ b/guix/scripts/graph.scm
@@ -417,7 +417,7 @@ substitutes."
   ;; TRANSLATORS: Here 'dot' is the name of a program; it must not be
   ;; translated.
   (display (G_ "Usage: guix graph PACKAGE...
-Emit a Graphviz (dot) representation of the dependencies of PACKAGE...\n"))
+Emit a representation of the dependency graph of PACKAGE...\n"))
   (display (G_ "
   -b, --backend=TYPE     produce a graph with the given backend TYPE"))
   (display (G_ "
@@ -447,12 +447,9 @@ Emit a Graphviz (dot) representation of the dependencies of PACKAGE...\n"))
 
 (define (guix-graph . args)
   (with-error-handling
-    (let* ((opts     (args-fold* args %options
-                                 (lambda (opt name arg . rest)
-                                   (leave (G_ "~A: unrecognized option~%") name))
-                                 (lambda (arg result)
-                                   (alist-cons 'argument arg result))
-                                 %default-options))
+    (let* ((opts     (parse-command-line args %options
+                                         (list %default-options)
+                                         #:build-options? #f))
            (backend  (assoc-ref opts 'backend))
            (type     (assoc-ref opts 'node-type))
            (items    (filter-map (match-lambda
diff --git a/guix/scripts/hash.scm b/guix/scripts/hash.scm
index 1fa6bb8d1f..cae5d6bcdf 100644
--- a/guix/scripts/hash.scm
+++ b/guix/scripts/hash.scm
@@ -104,13 +104,8 @@ and 'hexadecimal' can be used as well).\n"))
 (define (guix-hash . args)
   (define (parse-options)
     ;; Return the alist of option values.
-    (args-fold* args %options
-                (lambda (opt name arg result)
-                  (leave (G_ "unrecognized option: ~a~%")
-                         name))
-                (lambda (arg result)
-                  (alist-cons 'argument arg result))
-                %default-options))
+    (parse-command-line args %options (list %default-options)
+                        #:build-options? #f))
 
   (define (vcs-file? file stat)
     (case (stat:type stat)
diff --git a/guix/scripts/lint.scm b/guix/scripts/lint.scm
index a26f92f49c..8840b1acb5 100644
--- a/guix/scripts/lint.scm
+++ b/guix/scripts/lint.scm
@@ -792,35 +792,44 @@ be determined."
     ((? origin?)
      (and=> (origin-actual-file-name patch) basename))))
 
-(define (current-vulnerabilities*)
-  "Like 'current-vulnerabilities', but return the empty list upon networking
-or HTTP errors.  This allows network-less operation and makes problems with
-the NIST server non-fatal.."
+(define (call-with-networking-fail-safe message error-value proc)
+  "Call PROC catching any network-related errors.  Upon a networking error,
+display a message including MESSAGE and return ERROR-VALUE."
   (guard (c ((http-get-error? c)
-             (warning (G_ "failed to retrieve CVE vulnerabilities \
-from ~s: ~a (~s)~%")
+             (warning (G_ "~a: HTTP GET error for ~a: ~a (~s)~%")
+                      message
                       (uri->string (http-get-error-uri c))
                       (http-get-error-code c)
                       (http-get-error-reason c))
-             (warning (G_ "assuming no CVE vulnerabilities~%"))
-             '()))
+             error-value))
     (catch #t
-      (lambda ()
-        (current-vulnerabilities))
+      proc
       (match-lambda*
         (('getaddrinfo-error errcode)
-         (warning (G_ "failed to lookup NIST host: ~a~%")
+         (warning (G_ "~a: host lookup failure: ~a~%")
+                  message
                   (gai-strerror errcode))
-         (warning (G_ "assuming no CVE vulnerabilities~%"))
-         '())
+         error-value)
         (('tls-certificate-error args ...)
-         (warning (G_ "TLS certificate error: ~a")
+         (warning (G_ "~a: TLS certificate error: ~a")
+                  message
                   (tls-certificate-error-string args))
-         (warning (G_ "assuming no CVE vulnerabilities~%"))
-         '())
+         error-value)
         (args
          (apply throw args))))))
 
+(define-syntax-rule (with-networking-fail-safe message error-value exp ...)
+  (call-with-networking-fail-safe message error-value
+                                  (lambda () exp ...)))
+
+(define (current-vulnerabilities*)
+  "Like 'current-vulnerabilities', but return the empty list upon networking
+or HTTP errors.  This allows network-less operation and makes problems with
+the NIST server non-fatal."
+  (with-networking-fail-safe (G_ "while retrieving CVE vulnerabilities")
+                             '()
+                             (current-vulnerabilities)))
+
 (define package-vulnerabilities
   (let ((lookup (delay (vulnerabilities->lookup-proc
                         (current-vulnerabilities*)))))
@@ -860,7 +869,11 @@ from ~s: ~a (~s)~%")
 
 (define (check-for-updates package)
   "Check if there is an update available for PACKAGE."
-  (match (package-latest-release* package (force %updaters))
+  (match (with-networking-fail-safe
+          (format #f (G_ "while retrieving upstream info for '~a'")
+                  (package-name package))
+          #f
+          (package-latest-release* package (force %updaters)))
     ((? upstream-source? source)
      (when (version>? (upstream-source-version source)
                       (package-version package))
@@ -1123,12 +1136,8 @@ run the checkers on all packages.\n"))
 (define (guix-lint . args)
   (define (parse-options)
     ;; Return the alist of option values.
-    (args-fold* args %options
-                (lambda (opt name arg result)
-                  (leave (G_ "~A: unrecognized option~%") name))
-                (lambda (arg result)
-                  (alist-cons 'argument arg result))
-                %default-options))
+    (parse-command-line args %options (list %default-options)
+                        #:build-options? #f))
 
   (let* ((opts (parse-options))
          (args (filter-map (match-lambda
diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm
index 0e365018a9..f972ca2ef7 100644
--- a/guix/scripts/package.scm
+++ b/guix/scripts/package.scm
@@ -738,7 +738,8 @@ processed, #f otherwise."
               (available (fold-packages
                           (lambda (p r)
                             (let ((n (package-name p)))
-                              (if (supported-package? p)
+                              (if (and (supported-package? p)
+                                       (not (package-superseded p)))
                                   (if regexp
                                       (if (regexp-exec regexp n)
                                           (cons p r)
diff --git a/guix/scripts/refresh.scm b/guix/scripts/refresh.scm
index d638d744af..852b44b38d 100644
--- a/guix/scripts/refresh.scm
+++ b/guix/scripts/refresh.scm
@@ -338,12 +338,8 @@ dependent packages are rebuilt: ~{~a~^ ~}~%"
 (define (guix-refresh . args)
   (define (parse-options)
     ;; Return the alist of option values.
-    (args-fold* args %options
-                (lambda (opt name arg result)
-                  (leave (G_ "~A: unrecognized option~%") name))
-                (lambda (arg result)
-                  (alist-cons 'argument arg result))
-                %default-options))
+    (parse-command-line args %options (list %default-options)
+                        #:build-options? #f))
 
   (define (options->updaters opts)
     ;; Return the list of updaters to use.
diff --git a/guix/scripts/size.scm b/guix/scripts/size.scm
index eade184e67..b7b53e43fb 100644
--- a/guix/scripts/size.scm
+++ b/guix/scripts/size.scm
@@ -291,7 +291,8 @@ Report the size of PACKAGE and its dependencies.\n"))
 
 (define (guix-size . args)
   (with-error-handling
-    (let* ((opts     (parse-command-line args %options (list %default-options)))
+    (let* ((opts     (parse-command-line args %options (list %default-options)
+                                         #:build-options? #f))
            (files    (filter-map (match-lambda
                                    (('argument . file) file)
                                    (_ #f))
diff --git a/guix/scripts/substitute.scm b/guix/scripts/substitute.scm
index 1fbeed71e8..2fd2bf8104 100755
--- a/guix/scripts/substitute.scm
+++ b/guix/scripts/substitute.scm
@@ -533,6 +533,20 @@ indicates that PATH is unavailable at CACHE-URL."
         (headers '((User-Agent . "GNU Guile"))))
     (build-request (string->uri url) #:method 'GET #:headers headers)))
 
+(define (at-most max-length lst)
+  "If LST is shorter than MAX-LENGTH, return it; otherwise return its
+MAX-LENGTH first elements."
+  (let loop ((len 0)
+             (lst lst)
+             (result '()))
+    (match lst
+      (()
+       (reverse result))
+      ((head . tail)
+       (if (>= len max-length)
+           (reverse result)
+           (loop (+ 1 len) tail (cons head result)))))))
+
 (define* (http-multiple-get base-uri proc seed requests
                             #:key port (verify-certificate? #t))
   "Send all of REQUESTS to the server at BASE-URI.  Call PROC for each
@@ -553,7 +567,7 @@ initial connection on which HTTP requests are sent."
       (when (file-port? p)
         (setvbuf p _IOFBF (expt 2 16)))
 
-      ;; Send all of REQUESTS in a row.
+      ;; Send REQUESTS, up to a certain number, in a row.
       ;; XXX: Do our own caching to work around inefficiencies when
       ;; communicating over TLS: <http://bugs.gnu.org/22966>.
       (let-values (((buffer get) (open-bytevector-output-port)))
@@ -562,7 +576,8 @@ initial connection on which HTTP requests are sent."
                                'http-proxy-port?)
           (set-http-proxy-port?! buffer (http-proxy-port? p)))
 
-        (for-each (cut write-request <> buffer) requests)
+        (for-each (cut write-request <> buffer)
+                  (at-most 1000 requests))
         (put-bytevector p (get))
         (force-output p))
 
diff --git a/guix/scripts/weather.scm b/guix/scripts/weather.scm
index 4c4dfac8f6..0d4a7fa26b 100644
--- a/guix/scripts/weather.scm
+++ b/guix/scripts/weather.scm
@@ -205,7 +205,8 @@ Report the availability of substitutes.\n"))
 (define (guix-weather . args)
   (with-error-handling
     (let* ((opts     (parse-command-line args %options
-                                         (list %default-options)))
+                                         (list %default-options)
+                                         #:build-options? #f))
            (urls     (assoc-ref opts 'substitute-urls))
            (systems  (match (filter-map (match-lambda
                                           (('system . system) system)