diff options
author | Efraim Flashner <efraim@flashner.co.il> | 2017-11-01 10:29:59 +0200 |
---|---|---|
committer | Efraim Flashner <efraim@flashner.co.il> | 2017-11-01 10:29:59 +0200 |
commit | 19b7bba1b5f115168b1669325cd51bc66b9dc4b4 (patch) | |
tree | 7b4e77080fe6fbc3a54b8612adc3c5c27ab81d05 /guix | |
parent | f37931d6632627a24e4eccafa1603ffadb649ff6 (diff) | |
parent | 5010d0e36452882eb95666467bb983efa8cca081 (diff) | |
download | patches-19b7bba1b5f115168b1669325cd51bc66b9dc4b4.tar patches-19b7bba1b5f115168b1669325cd51bc66b9dc4b4.tar.gz |
Merge remote-tracking branch 'origin/master' into core-updates
Diffstat (limited to 'guix')
-rw-r--r-- | guix/build/go-build-system.scm | 2 | ||||
-rw-r--r-- | guix/download.scm | 77 | ||||
-rw-r--r-- | guix/import/cpan.scm | 7 | ||||
-rw-r--r-- | guix/import/elpa.scm | 7 | ||||
-rw-r--r-- | guix/import/github.scm | 11 | ||||
-rw-r--r-- | guix/scripts.scm | 14 | ||||
-rw-r--r-- | guix/scripts/challenge.scm | 19 | ||||
-rw-r--r-- | guix/scripts/gc.scm | 8 | ||||
-rw-r--r-- | guix/scripts/graph.scm | 11 | ||||
-rw-r--r-- | guix/scripts/hash.scm | 9 | ||||
-rw-r--r-- | guix/scripts/lint.scm | 55 | ||||
-rw-r--r-- | guix/scripts/package.scm | 3 | ||||
-rw-r--r-- | guix/scripts/refresh.scm | 8 | ||||
-rw-r--r-- | guix/scripts/size.scm | 3 | ||||
-rwxr-xr-x | guix/scripts/substitute.scm | 19 | ||||
-rw-r--r-- | guix/scripts/weather.scm | 3 |
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) |