From 6692d8454a89e542d85d2b6a93adfd373aeec39c Mon Sep 17 00:00:00 2001 From: nee Date: Wed, 25 Oct 2017 20:44:54 +0200 Subject: guix: records: Add match-record. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit * guix/records.scm: New syntax-rule. Signed-off-by: Ludovic Courtès --- guix/records.scm | 18 +++++++++++++++++- 1 file changed, 17 insertions(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/records.scm b/guix/records.scm index 7de5fccef6..1f00e16603 100644 --- a/guix/records.scm +++ b/guix/records.scm @@ -26,7 +26,8 @@ #:export (define-record-type* alist->record object->fields - recutils->alist)) + recutils->alist + match-record)) ;;; Commentary: ;;; @@ -375,4 +376,19 @@ pairs. Stop upon an empty line (after consuming it) or EOF." (else (error "unmatched line" line)))))))) +(define-syntax match-record + (syntax-rules () + "Bind each FIELD of a RECORD of the given TYPE to it's FIELD name. +The current implementation does not support thunked and delayed fields." + ((_ record type (field fields ...) body ...) + (if (eq? (struct-vtable record) type) + ;; TODO compute indices and report wrong-field-name errors at + ;; expansion time + ;; TODO support thunked and delayed fields + (let ((field ((record-accessor type 'field) record))) + (match-record record type (fields ...) body ...)) + (throw 'wrong-type-arg record))) + ((_ record type () body ...) + (begin body ...)))) + ;;; records.scm ends here -- cgit v1.2.3 From 0ad5f8098292a3ed759b249acd48dc7107086c12 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 6 Nov 2017 18:05:09 +0100 Subject: Fix ambiguous imports. * gnu/packages/ocaml.scm: Hide 'zip' from (srfi srfi-1). * guix/git.scm: Select 'mkdir-p' from (guix build utils). --- gnu/packages/ocaml.scm | 2 +- guix/git.scm | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) (limited to 'guix') diff --git a/gnu/packages/ocaml.scm b/gnu/packages/ocaml.scm index 5b2536ae67..fbcb1def4d 100644 --- a/gnu/packages/ocaml.scm +++ b/gnu/packages/ocaml.scm @@ -65,7 +65,7 @@ #:use-module (guix packages) #:use-module (guix svn-download) #:use-module (guix utils) - #:use-module (srfi srfi-1)) + #:use-module ((srfi srfi-1) #:hide (zip))) ;; A shortcut for files from ocaml forge. Downloaded files are computed from ;; their number, not their name. diff --git a/guix/git.scm b/guix/git.scm index 406c817341..e73f4b9855 100644 --- a/guix/git.scm +++ b/guix/git.scm @@ -21,7 +21,7 @@ #:use-module (git object) #:use-module (guix base32) #:use-module (guix hash) - #:use-module (guix build utils) + #:use-module ((guix build utils) #:select (mkdir-p)) #:use-module (guix store) #:use-module (guix utils) #:use-module (rnrs bytevectors) -- cgit v1.2.3 From c9405c461b1b37740bc0bb33c7043313978c0014 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sun, 5 Nov 2017 12:49:57 +0100 Subject: compile: Fix VPATH builds. Fixes . Reported by Eric Bavier . * guix/build/compile.scm (relative-file): New procedure. (load-files): Use it before calling 'file-name->module-name'. (compile-files): Likewise before calling 'scm->go'. * guix/build/pull.scm (build-guix): Remove 'with-directory-excursion' and file name hack from ce33c3af76b0e5c68cc42dddf2b9c4b017386fd8. Pass OUT to 'all-scheme-files'. --- guix/build/compile.scm | 28 ++++++++++++++--------- guix/build/pull.scm | 61 +++++++++++++++++++++----------------------------- 2 files changed, 44 insertions(+), 45 deletions(-) (limited to 'guix') diff --git a/guix/build/compile.scm b/guix/build/compile.scm index ea0c36fa33..8b5a2faf84 100644 --- a/guix/build/compile.scm +++ b/guix/build/compile.scm @@ -77,6 +77,12 @@ "Strip the \".scm\" suffix from FILE, and append \".go\"." (string-append (string-drop-right file 4) ".go")) +(define (relative-file directory file) + "Return FILE relative to DIRECTORY, if possible." + (if (string-prefix? (string-append directory "/") file) + (string-drop file (+ 1 (string-length directory))) + file)) + (define* (load-files directory files #:key (report-load (const #f)) @@ -93,13 +99,14 @@ (report-load #f total completed)) *unspecified*) ((file files ...) - (report-load file total completed) - (format debug-port "~%loading '~a'...~%" file) + (let ((file (relative-file directory file))) + (report-load file total completed) + (format debug-port "~%loading '~a'...~%" file) - (parameterize ((current-warning-port debug-port)) - (resolve-interface (file-name->module-name file))) + (parameterize ((current-warning-port debug-port)) + (resolve-interface (file-name->module-name file))) - (loop files (+ 1 completed)))))) + (loop files (+ 1 completed))))))) (define-syntax-rule (with-augmented-search-path path item body ...) "Within the dynamic extent of BODY, augment PATH by adding ITEM to the @@ -135,11 +142,12 @@ files are for HOST, a GNU triplet such as \"x86_64-linux-gnu\"." (with-fluids ((*current-warning-prefix* "")) (with-target host (lambda () - (compile-file file - #:output-file (string-append build-directory "/" - (scm->go file)) - #:opts (append warning-options - (optimization-options file)))))) + (let ((relative (relative-file source-directory file))) + (compile-file file + #:output-file (string-append build-directory "/" + (scm->go relative)) + #:opts (append warning-options + (optimization-options relative))))))) (with-mutex progress-lock (set! completed (+ 1 completed)))) diff --git a/guix/build/pull.scm b/guix/build/pull.scm index 3573241a7e..a011e366f6 100644 --- a/guix/build/pull.scm +++ b/guix/build/pull.scm @@ -121,41 +121,32 @@ containing the source code. Write any debugging output to DEBUG-PORT." ;; Compile the .scm files. Hide warnings. (parameterize ((current-warning-port (%make-void-port "w"))) - (with-directory-excursion out - ;; Filter out files depending on Guile-SSH when Guile-SSH is missing. - (let ((files (filter has-all-its-dependencies? - (all-scheme-files ".")))) - (compile-files out out - - ;; XXX: 'compile-files' except ready-to-use relative - ;; file names. - (map (lambda (file) - (if (string-prefix? "./" file) - (string-drop file 2) - file)) - files) - - #:workers (parallel-job-count) - - ;; Disable warnings. - #:warning-options '() - - #:report-load - (lambda (file total completed) - (display #\cr log-port) - (format log-port - "loading...\t~5,1f% of ~d files" ;FIXME: i18n - (* 100. (/ completed total)) total) - (force-output log-port) - (format debug-port "~%loading '~a'...~%" file)) - - #:report-compilation - (lambda (file total completed) - (display #\cr log-port) - (format log-port "compiling...\t~5,1f% of ~d files" ;FIXME: i18n - (* 100. (/ completed total)) total) - (force-output log-port) - (format debug-port "~%compiling '~a'...~%" file))))))) + ;; Filter out files depending on Guile-SSH when Guile-SSH is missing. + (let ((files (filter has-all-its-dependencies? + (all-scheme-files out)))) + (compile-files out out files + + #:workers (parallel-job-count) + + ;; Disable warnings. + #:warning-options '() + + #:report-load + (lambda (file total completed) + (display #\cr log-port) + (format log-port + "loading...\t~5,1f% of ~d files" ;FIXME: i18n + (* 100. (/ completed total)) total) + (force-output log-port) + (format debug-port "~%loading '~a'...~%" file)) + + #:report-compilation + (lambda (file total completed) + (display #\cr log-port) + (format log-port "compiling...\t~5,1f% of ~d files" ;FIXME: i18n + (* 100. (/ completed total)) total) + (force-output log-port) + (format debug-port "~%compiling '~a'...~%" file)))))) (newline) #t) -- cgit v1.2.3 From 8e57e416c0a6431a14d487ff8b69dece76d37c03 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 6 Nov 2017 23:22:03 +0100 Subject: refresh: Account for hidden packages. Suggested by Marius Bakke in . * guix/scripts/refresh.scm (all-packages): Pass #:select? to 'fold-packages'. --- guix/scripts/refresh.scm | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/scripts/refresh.scm b/guix/scripts/refresh.scm index 852b44b38d..a8fe993e33 100644 --- a/guix/scripts/refresh.scm +++ b/guix/scripts/refresh.scm @@ -273,7 +273,8 @@ the latest known version of ~a (~a)~%") (define (all-packages) "Return the list of all the distro's packages." - (fold-packages cons '())) + (fold-packages cons '() + #:select? (const #t))) ;include hidden packages (define (list-dependents packages) "List all the things that would need to be rebuilt if PACKAGES are changed." -- cgit v1.2.3 From 6b46b04f919881e0122e201db4590ba5da77aa88 Mon Sep 17 00:00:00 2001 From: Ricardo Wurmus Date: Mon, 6 Nov 2017 16:53:39 +0100 Subject: import: utils: Add string helpers. * guix/import/utils.scm (read-lines, chunk-lines): New procedures. --- guix/import/utils.scm | 28 +++++++++++++++++++++++++++- 1 file changed, 27 insertions(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/import/utils.scm b/guix/import/utils.scm index 1e2f0c809d..d4cef6b503 100644 --- a/guix/import/utils.scm +++ b/guix/import/utils.scm @@ -34,6 +34,8 @@ #:use-module (guix download) #:use-module (gnu packages) #:use-module (ice-9 match) + #:use-module (ice-9 rdelim) + #:use-module (ice-9 receive) #:use-module (ice-9 regex) #:use-module (srfi srfi-1) #:use-module (srfi srfi-11) @@ -56,7 +58,10 @@ snake-case beautify-description - alist->package)) + alist->package + + read-lines + chunk-lines)) (define (factorize-uri uri version) "Factorize URI, a package tarball URI as a string, such that any occurrences @@ -329,3 +334,24 @@ the expected fields of an object." (or (module-ref (resolve-interface '(guix licenses) #:prefix 'license:) (spdx-string->license l)) (license:fsdg-compatible l)))))) + +(define* (read-lines #:optional (port (current-input-port))) + "Read lines from PORT and return them as a list." + (let loop ((line (read-line port)) + (lines '())) + (if (eof-object? line) + (reverse lines) + (loop (read-line port) + (cons line lines))))) + +(define* (chunk-lines lines #:optional (pred string-null?)) + "Return a list of chunks, each of which is a list of lines. The chunks are +separated by PRED." + (let loop ((rest lines) + (parts '())) + (receive (before after) + (break pred rest) + (let ((res (cons before parts))) + (if (null? after) + (reverse res) + (loop (cdr after) res)))))) -- cgit v1.2.3 From 84dfdc5759a780cea25c6fd4c7cb0f33ba20bd8b Mon Sep 17 00:00:00 2001 From: Ricardo Wurmus Date: Mon, 6 Nov 2017 17:09:06 +0100 Subject: import: cran: Add support for Bioconductor 3.6. * guix/import/cran.scm (%bioconductor-version, %bioconductor-packages-list-url): New variables. (bioconductor-packages-list, latest-bioconductor-package-version): New procedures. --- guix/import/cran.scm | 32 +++++++++++++++++++++++++++++++- 1 file changed, 31 insertions(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/import/cran.scm b/guix/import/cran.scm index 9b08ebfb63..bcfc0d9355 100644 --- a/guix/import/cran.scm +++ b/guix/import/cran.scm @@ -128,11 +128,41 @@ package definition." (define %cran-url "http://cran.r-project.org/web/packages/") (define %bioconductor-url "https://bioconductor.org/packages/") -;; The latest Bioconductor release is 3.5. Bioconductor packages should be +;; The latest Bioconductor release is 3.6. Bioconductor packages should be ;; updated together. (define (bioconductor-mirror-url name) (string-append "https://raw.githubusercontent.com/Bioconductor-mirror/" name "/release-3.5")) +(define %bioconductor-version "3.6") + +(define %bioconductor-packages-list-url + (string-append "https://bioconductor.org/packages/" + %bioconductor-version "/bioc/src/contrib/PACKAGES")) + +(define (bioconductor-packages-list) + "Return the latest version of package NAME for the current bioconductor +release." + (let ((url (string->uri %bioconductor-packages-list-url))) + (guard (c ((http-get-error? c) + (format (current-error-port) + "error: failed to retrieve list of packages from ~s: ~a (~s)~%" + (uri->string (http-get-error-uri c)) + (http-get-error-code c) + (http-get-error-reason c)) + #f)) + ;; Split the big list on empty lines, then turn each chunk into an + ;; alist of attributes. + (map (lambda (chunk) + (description->alist (string-join chunk "\n"))) + (chunk-lines (read-lines (http-fetch/cached url))))))) + +(define (latest-bioconductor-package-version name) + "Return the version string corresponding to the latest release of the +bioconductor package NAME, or #F if the package is unknown." + (and=> (find (lambda (meta) + (string=? (assoc-ref meta "Package") name)) + (bioconductor-packages-list)) + (cut assoc-ref <> "Version"))) (define (fetch-description repository name) "Return an alist of the contents of the DESCRIPTION file for the R package -- cgit v1.2.3 From 27baf509569392dc4c15906eb848c8313a818c9e Mon Sep 17 00:00:00 2001 From: Ricardo Wurmus Date: Mon, 6 Nov 2017 17:10:41 +0100 Subject: import: cran: Use Bioconductor 3.6 helpers. * guix/import/cran.scm (bioconductor-mirror-url): Remove procedure. (fetch-description): Extract DESCRIPTION file from tarball for Bioconductor packages. (latest-bioconductor-release): Use latest-bioconductor-package-version. --- guix/import/cran.scm | 61 +++++++++++++++++++++++++++++++--------------------- 1 file changed, 36 insertions(+), 25 deletions(-) (limited to 'guix') diff --git a/guix/import/cran.scm b/guix/import/cran.scm index bcfc0d9355..5622f759e0 100644 --- a/guix/import/cran.scm +++ b/guix/import/cran.scm @@ -130,9 +130,6 @@ package definition." ;; The latest Bioconductor release is 3.6. Bioconductor packages should be ;; updated together. -(define (bioconductor-mirror-url name) - (string-append "https://raw.githubusercontent.com/Bioconductor-mirror/" - name "/release-3.5")) (define %bioconductor-version "3.6") (define %bioconductor-packages-list-url @@ -168,20 +165,35 @@ bioconductor package NAME, or #F if the package is unknown." "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 case-sensitive." - ;; This API always returns the latest release of the module. - (let ((url (string-append (case repository - ((cran) (string-append %cran-url name)) - ((bioconductor) (bioconductor-mirror-url name))) - "/DESCRIPTION"))) - (guard (c ((http-get-error? c) - (format (current-error-port) - "error: failed to retrieve package information \ + (case repository + ((cran) + (let ((url (string-append %cran-url name "/DESCRIPTION"))) + (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)))))) + (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)))))) + ((bioconductor) + ;; Currently, the bioconductor project does not offer a way to access a + ;; package's DESCRIPTION file over HTTP, so we determine the version, + ;; download the source tarball, and then extract the DESCRIPTION file. + (let* ((version (latest-bioconductor-package-version name)) + (url (bioconductor-uri name version)) + (tarball (with-store store (download-to-store store 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")) + (description->alist (with-input-from-file + (string-append dir "/DESCRIPTION") read-string)))))))))) (define (listify meta field) "Look up FIELD in the alist META. If FIELD contains a comma-separated @@ -449,16 +461,15 @@ dependencies." (define upstream-name (package->upstream-name package)) - (define meta - (fetch-description 'bioconductor upstream-name)) + (define version + (latest-bioconductor-package-version upstream-name)) - (and meta - (let ((version (assoc-ref meta "Version"))) - ;; Bioconductor does not provide signatures. - (upstream-source - (package (package-name package)) - (version version) - (urls (list (bioconductor-uri upstream-name version))))))) + (and version + ;; Bioconductor does not provide signatures. + (upstream-source + (package (package-name package)) + (version version) + (urls (list (bioconductor-uri upstream-name version)))))) (define (cran-package? package) "Return true if PACKAGE is an R package from CRAN." -- cgit v1.2.3 From 25e51b1c45374ca0dd1898fd5acaefe4fc3cd815 Mon Sep 17 00:00:00 2001 From: Ricardo Wurmus Date: Mon, 6 Nov 2017 17:49:47 +0100 Subject: guix: Add archive support for bioconductor-uri. * guix/build-system/r.scm (bioconductor-uri): Also return the archive URL. * guix/import/cran.scm (latest-bioconductor-release, fetch-description): Adjust because bioconductor-uri now returns a list. --- guix/build-system/r.scm | 9 ++++++--- guix/import/cran.scm | 4 ++-- 2 files changed, 8 insertions(+), 5 deletions(-) (limited to 'guix') diff --git a/guix/build-system/r.scm b/guix/build-system/r.scm index 2c8a89f8de..6bdb7061eb 100644 --- a/guix/build-system/r.scm +++ b/guix/build-system/r.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2015 Ricardo Wurmus +;;; Copyright © 2015, 2017 Ricardo Wurmus ;;; ;;; This file is part of GNU Guix. ;;; @@ -50,8 +50,11 @@ available via the first URI, the second URI points to the archived version." (define (bioconductor-uri name version) "Return a URI string for the R package archive on Bioconductor for the release corresponding to NAME and VERSION." - (string-append "https://bioconductor.org/packages/release/bioc/src/contrib/" - name "_" version ".tar.gz")) + (list (string-append "https://bioconductor.org/packages/release/bioc/src/contrib/" + name "_" version ".tar.gz") + ;; TODO: use %bioconductor-version from (guix import cran) + (string-append "https://bioconductor.org/packages/3.6/bioc/src/contrib/Archive/" + name "_" version ".tar.gz"))) (define %r-build-system-modules ;; Build-side modules imported by default. diff --git a/guix/import/cran.scm b/guix/import/cran.scm index 5622f759e0..ec2b7e6029 100644 --- a/guix/import/cran.scm +++ b/guix/import/cran.scm @@ -182,7 +182,7 @@ from ~s: ~a (~s)~%" ;; package's DESCRIPTION file over HTTP, so we determine the version, ;; download the source tarball, and then extract the DESCRIPTION file. (let* ((version (latest-bioconductor-package-version name)) - (url (bioconductor-uri name version)) + (url (car (bioconductor-uri name version))) (tarball (with-store store (download-to-store store url)))) (call-with-temporary-directory (lambda (dir) @@ -469,7 +469,7 @@ dependencies." (upstream-source (package (package-name package)) (version version) - (urls (list (bioconductor-uri upstream-name version)))))) + (urls (bioconductor-uri upstream-name version))))) (define (cran-package? package) "Return true if PACKAGE is an R package from CRAN." -- cgit v1.2.3 From 37eed374d92e0fbb29701b072c3a39433fbba16d Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 8 Nov 2017 10:13:45 +0100 Subject: ui: Introduce (guix i18n). * guix/ui.scm (G_, N_, _P, %gettext-domain, %package-text-domain): Move to... * guix/i18n.scm: ... here. New file. --- Makefile.am | 1 + guix/i18n.scm | 51 +++++++++++++++++++++++++++++++++++++++++++++++++++ guix/ui.scm | 27 +++------------------------ 3 files changed, 55 insertions(+), 24 deletions(-) create mode 100644 guix/i18n.scm (limited to 'guix') diff --git a/Makefile.am b/Makefile.am index 41fb9ba388..7ad95cec75 100644 --- a/Makefile.am +++ b/Makefile.am @@ -103,6 +103,7 @@ MODULES = \ guix/store.scm \ guix/cvs-download.scm \ guix/svn-download.scm \ + guix/i18n.scm \ guix/ui.scm \ guix/build/ant-build-system.scm \ guix/build/download.scm \ diff --git a/guix/i18n.scm b/guix/i18n.scm new file mode 100644 index 0000000000..f81e6b38ec --- /dev/null +++ b/guix/i18n.scm @@ -0,0 +1,51 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017 Ludovic Courtès +;;; +;;; 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 . + +(define-module (guix i18n) + #:use-module (srfi srfi-26) + #:export (G_ + N_ + P_ + %gettext-domain + %package-text-domain)) + +;;; Commentary: +;;; +;;; Internationalization support. +;;; +;;; Code: + +(define %gettext-domain + ;; Text domain for strings used in the tools. + "guix") + +(define %package-text-domain + ;; Text domain for package synopses and descriptions. + "guix-packages") + +(define G_ (cut gettext <> %gettext-domain)) +(define N_ (cut ngettext <> <> <> %gettext-domain)) + +(define (P_ msgid) + "Return the translation of the package description or synopsis MSGID." + ;; Descriptions/synopses might occasionally be empty strings, even if that + ;; is something we try to avoid. Since (gettext "") can return a non-empty + ;; string, explicitly check for that case. + (if (string-null? msgid) + msgid + (gettext msgid %package-text-domain))) diff --git a/guix/ui.scm b/guix/ui.scm index 3c8734a7d5..40371e4710 100644 --- a/guix/ui.scm +++ b/guix/ui.scm @@ -26,6 +26,7 @@ ;;; along with GNU Guix. If not, see . (define-module (guix ui) + #:use-module (guix i18n) #:use-module (guix gexp) #:use-module (guix utils) #:use-module (guix store) @@ -55,10 +56,8 @@ #:use-module (texinfo) #:use-module (texinfo plain-text) #:use-module (texinfo string-utils) - #:export (G_ - N_ - P_ - report-error + #:re-export (G_ N_ P_) ;backward compatibility + #:export (report-error leave make-user-module load* @@ -111,26 +110,6 @@ ;;; ;;; Code: -(define %gettext-domain - ;; Text domain for strings used in the tools. - "guix") - -(define %package-text-domain - ;; Text domain for package synopses and descriptions. - "guix-packages") - -(define G_ (cut gettext <> %gettext-domain)) -(define N_ (cut ngettext <> <> <> %gettext-domain)) - -(define (P_ msgid) - "Return the translation of the package description or synopsis MSGID." - ;; Descriptions/synopses might occasionally be empty strings, even if that - ;; is something we try to avoid. Since (gettext "") can return a non-empty - ;; string, explicitly check for that case. - (if (string-null? msgid) - msgid - (gettext msgid %package-text-domain))) - (define-syntax-rule (define-diagnostic name prefix) "Create a diagnostic macro (i.e., NAME), which will prepend PREFIX to all messages." -- cgit v1.2.3 From 23735137eb666e9fe2e848563615bca5bcea1282 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 8 Nov 2017 11:16:25 +0100 Subject: ui: Define and honor '&error-location' and '&fix-hint' conditions. * guix/utils.scm (&error-location, &fix-hint): New condition types. * guix/ui.scm (report-load-error): Handle them. (call-with-error-handling): Honor '&error-location'. --- guix/ui.scm | 23 +++++++++++++++++++---- guix/utils.scm | 17 +++++++++++++++++ 2 files changed, 36 insertions(+), 4 deletions(-) (limited to 'guix') diff --git a/guix/ui.scm b/guix/ui.scm index 40371e4710..a1152605e6 100644 --- a/guix/ui.scm +++ b/guix/ui.scm @@ -251,10 +251,20 @@ ARGS is the list of arguments received by the 'throw' handler." (location->string loc) message))) (('srfi-34 obj) (if (message-condition? obj) - (report-error (G_ "~a~%") - (gettext (condition-message obj) - %gettext-domain)) - (report-error (G_ "exception thrown: ~s~%") obj))) + (if (error-location? obj) + (format (current-error-port) + (G_ "~a: error: ~a~%") + (location->string (error-location obj)) + (gettext (condition-message obj) + %gettext-domain)) + (report-error (G_ "~a~%") + (gettext (condition-message obj) + %gettext-domain))) + (report-error (G_ "exception thrown: ~s~%") obj)) + (when (fix-hint? obj) + (format (current-error-port) (G_ "hint: ~a~%") + (fill-paragraph (texi->plain-text (condition-fix-hint obj)) + (terminal-columns) 8)))) ((error args ...) (report-error (G_ "failed to load '~a':~%") file) (apply display-error frame (current-error-port) args)))) @@ -517,6 +527,11 @@ interpreted." directories:~{ ~a~}~%") (file-search-error-file-name c) (file-search-error-search-path c))) + ((and (error-location? c) (message-condition? c)) + (format (current-error-port) + (G_ "~a: error: ~a~%") + (location->string (error-location c)) + (gettext (condition-message c) %gettext-domain))) ((message-condition? c) ;; Normally '&message' error conditions have an i18n'd message. (leave (G_ "~a~%") diff --git a/guix/utils.scm b/guix/utils.scm index eb1ec29b32..c0ffed172a 100644 --- a/guix/utils.scm +++ b/guix/utils.scm @@ -28,6 +28,7 @@ #:use-module (srfi srfi-9) #:use-module (srfi srfi-11) #:use-module (srfi srfi-26) + #:use-module (srfi srfi-35) #:use-module (srfi srfi-39) #:use-module (ice-9 binary-ports) #:autoload (rnrs io ports) (make-custom-binary-input-port) @@ -60,6 +61,14 @@ source-properties->location location->source-properties + &error-location + error-location? + error-location + + &fix-hint + fix-hint? + condition-fix-hint + nix-system->gnu-triplet gnu-triplet->nix-system %current-system @@ -750,6 +759,14 @@ a location object." (column . ,(location-column loc)) (filename . ,(location-file loc)))) +(define-condition-type &error-location &error + error-location? + (location error-location)) ; + +(define-condition-type &fix-hint &condition + fix-hint? + (hint condition-fix-hint)) ;string + ;;; Local Variables: ;;; eval: (put 'call-with-progress-reporter 'scheme-indent-function 1) ;;; End: -- cgit v1.2.3 From 935542fbde17f0bc865cbcbb8d9f632bd592cc96 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 9 Nov 2017 23:27:56 +0100 Subject: ui: Add 'display-hint'. * guix/ui.scm (known-variable-definition): New procedure. (report-load-error): Use it. --- guix/ui.scm | 11 ++++++++--- 1 file changed, 8 insertions(+), 3 deletions(-) (limited to 'guix') diff --git a/guix/ui.scm b/guix/ui.scm index a1152605e6..02f3638f3a 100644 --- a/guix/ui.scm +++ b/guix/ui.scm @@ -229,6 +229,13 @@ messages." (else #t)))))) +(define* (display-hint message #:optional (port (current-error-port))) + "Display MESSAGE, a l10n message possibly containing Texinfo markup, to +PORT." + (format port (G_ "hint: ~a~%") + (fill-paragraph (texi->plain-text message) + (terminal-columns) 8))) + (define* (report-load-error file args #:optional frame) "Report the failure to load FILE, a user-provided Scheme file. ARGS is the list of arguments received by the 'throw' handler." @@ -262,9 +269,7 @@ ARGS is the list of arguments received by the 'throw' handler." %gettext-domain))) (report-error (G_ "exception thrown: ~s~%") obj)) (when (fix-hint? obj) - (format (current-error-port) (G_ "hint: ~a~%") - (fill-paragraph (texi->plain-text (condition-fix-hint obj)) - (terminal-columns) 8)))) + (display-hint (condition-fix-hint obj)))) ((error args ...) (report-error (G_ "failed to load '~a':~%") file) (apply display-error frame (current-error-port) args)))) -- cgit v1.2.3 From a2985bb101faac9f085176e0329488b91b81dfb5 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 9 Nov 2017 23:29:39 +0100 Subject: ui: Provide hints for unbound-variable errors. * guix/ui.scm (known-variable-definition): New procedure. (report-load-error): Handle 'unbound-variable'. --- guix/ui.scm | 42 ++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 42 insertions(+) (limited to 'guix') diff --git a/guix/ui.scm b/guix/ui.scm index 02f3638f3a..9f790b6451 100644 --- a/guix/ui.scm +++ b/guix/ui.scm @@ -229,6 +229,38 @@ messages." (else #t)))))) +(define (known-variable-definition variable) + "Search among the currently loaded modules one that defines a variable named +VARIABLE and return it, or #f if none was found." + (define (modulelist (lambda (name module) + module) + (module-submodules head))))) + (match (module-local-variable head variable) + (#f (loop next suggestions)) + (_ + (match (module-name head) + (('gnu _ ...) head) ;must be that one + (_ (loop next (cons head suggestions))))))))))) + (define* (display-hint message #:optional (port (current-error-port))) "Display MESSAGE, a l10n message possibly containing Texinfo markup, to PORT." @@ -256,6 +288,16 @@ ARGS is the list of arguments received by the 'throw' handler." (let ((loc (source-properties->location properties))) (format (current-error-port) (G_ "~a: error: ~a~%") (location->string loc) message))) + (('unbound-variable proc message (variable) _ ...) + (match args + ((key . args) + (print-exception (current-error-port) frame key args))) + (match (known-variable-definition variable) + (#f + (display-hint (G_ "Did you forget a @code{use-modules} form?"))) + (module + (display-hint (format #f (G_ "Try adding @code{(use-modules ~a)}.") + (module-name module)))))) (('srfi-34 obj) (if (message-condition? obj) (if (error-location? obj) -- cgit v1.2.3 From dc856223f5eab57d8a4881782ec0f50abd12afa3 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 9 Nov 2017 23:31:18 +0100 Subject: ui: Add an 'unbound-variable' exception printer. * guix/ui.scm (print-unbound-variable-error): New variable. Use it as the 'unbound-variable' printer. --- guix/ui.scm | 12 ++++++++++++ 1 file changed, 12 insertions(+) (limited to 'guix') diff --git a/guix/ui.scm b/guix/ui.scm index 9f790b6451..05782a537e 100644 --- a/guix/ui.scm +++ b/guix/ui.scm @@ -149,6 +149,18 @@ messages." (report-error args ...) (exit 1))) +(define (print-unbound-variable-error port key args default-printer) + ;; Print unbound variable errors more nicely, and in the right language. + (match args + ((proc message (variable) _ ...) + ;; We can always omit PROC because when it's useful (i.e., different from + ;; "module-lookup"), it gets displayed before. + (format port (G_ "~a: unbound variable") variable)) + (_ + (default-printer)))) + +(set-exception-printer! 'unbound-variable print-unbound-variable-error) + (define (make-user-module modules) "Return a new user module with the additional MODULES loaded." ;; Module in which the machine description file is loaded. -- cgit v1.2.3 From 195f0d05c3f64e17e84b2683a7045a14ec578d61 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 10 Nov 2017 12:59:55 +0100 Subject: git: Work around wrong default argument of 'clone'. Fixes . Reported by Benjamin Andresen . * guix/git.scm (clone*): Pass second argument to 'clone'. --- guix/git.scm | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/git.scm b/guix/git.scm index e73f4b9855..ad4fc30c4b 100644 --- a/guix/git.scm +++ b/guix/git.scm @@ -55,7 +55,10 @@ make sure no empty directory is left behind." (with-throw-handler #t (lambda () (mkdir-p directory) - (clone url directory)) + + ;; Note: Explicitly pass options to work around the invalid default + ;; value in Guile-Git: . + (clone url directory (clone-init-options))) (lambda _ (false-if-exception (rmdir directory))))) -- cgit v1.2.3 From 59da6f04f45b36696a9385babab3080d7d854fba Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 10 Nov 2017 23:07:49 +0100 Subject: download: Work around bogus HTTP handling in Guile 2.2 <= 2.2.2. Reported by Konrad Hinsen at . * guix/build/download.scm (write-request-line) [guile-2.2]: New procedure. --- guix/build/download.scm | 50 +++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 50 insertions(+) (limited to 'guix') diff --git a/guix/build/download.scm b/guix/build/download.scm index 61c9c6d3f1..790576b235 100644 --- a/guix/build/download.scm +++ b/guix/build/download.scm @@ -513,6 +513,56 @@ port if PORT is a TLS session record port." (let ((declare-relative-uri-header! (variable-ref var))) (declare-relative-uri-header! "Location"))))) +;; XXX: Work around broken proxy handling on Guile 2.2 <= 2.2.2, fixed in +;; Guile commit 7d0d9e2c25c1e872cfc7d14ab5139915f1813d56. See bug report at +;; . +(cond-expand + (guile-2.2 + (when (<= (string->number (micro-version)) 2) + (let () + (define put-symbol (@@ (web http) put-symbol)) + (define put-non-negative-integer + (@@ (web http) put-non-negative-integer)) + (define write-http-version + (@@ (web http) write-http-version)) + + (define (write-request-line method uri version port) + "Write the first line of an HTTP request to PORT." + (put-symbol port method) + (put-char port #\space) + (when (http-proxy-port? port) + (let ((scheme (uri-scheme uri)) + (host (uri-host uri)) + (host-port (uri-port uri))) + (when (and scheme host) + (put-symbol port scheme) + (put-string port "://") + (cond + ((string-index host #\:) ;<---- The fix is here! + (put-char #\[ port) + (put-string port host + (put-char port #\]))) + (else + (put-string port host))) + (unless ((@@ (web uri) default-port?) scheme host-port) + (put-char port #\:) + (put-non-negative-integer port host-port))))) + (let ((path (uri-path uri)) + (query (uri-query uri))) + (if (string-null? path) + (put-string port "/") + (put-string port path)) + (when query + (put-string port "?") + (put-string port query))) + (put-char port #\space) + (write-http-version version port) + (put-string port "\r\n")) + + (module-set! (resolve-module '(web http)) 'write-request-line + write-request-line)))) + (else #t)) + (define (resolve-uri-reference ref base) "Resolve the URI reference REF, interpreted relative to the BASE URI, into a target URI, according to the algorithm specified in RFC 3986 section 5.2.2. -- cgit v1.2.3 From 65a19abf3fad2dee86cc3585124ca2f85cf115b7 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sat, 11 Nov 2017 15:17:52 +0100 Subject: download: Work around more bogus HTTP handling in Guile 2.2 <= 2.2.2. Reported by Mark H Weaver at . * guix/build/download.scm (guile-2.2) [write-request-line]: Backport Guile commit 6ad28ae3bc6a6d9e95ab7d70510d12c97673a143. --- guix/build/download.scm | 9 +++++---- 1 file changed, 5 insertions(+), 4 deletions(-) (limited to 'guix') diff --git a/guix/build/download.scm b/guix/build/download.scm index 790576b235..a65c7b9964 100644 --- a/guix/build/download.scm +++ b/guix/build/download.scm @@ -514,7 +514,8 @@ port if PORT is a TLS session record port." (declare-relative-uri-header! "Location"))))) ;; XXX: Work around broken proxy handling on Guile 2.2 <= 2.2.2, fixed in -;; Guile commit 7d0d9e2c25c1e872cfc7d14ab5139915f1813d56. See bug report at +;; Guile commits 7d0d9e2c25c1e872cfc7d14ab5139915f1813d56 and +;; 6ad28ae3bc6a6d9e95ab7d70510d12c97673a143. See bug report at ;; . (cond-expand (guile-2.2 @@ -539,9 +540,9 @@ port if PORT is a TLS session record port." (put-string port "://") (cond ((string-index host #\:) ;<---- The fix is here! - (put-char #\[ port) - (put-string port host - (put-char port #\]))) + (put-char port #\[) ;<---- And here! + (put-string port host) + (put-char port #\])) (else (put-string port host))) (unless ((@@ (web uri) default-port?) scheme host-port) -- cgit v1.2.3 From b1488c76536c991c363aff7fd08dc6a49b8fbb30 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sat, 11 Nov 2017 18:38:27 +0100 Subject: git: Check whether 'clone-init-options' is defined. This is a followup to 195f0d05c3f64e17e84b2683a7045a14ec578d61. * guix/git.scm (clone*): Check whether 'clone-init-options' is defined before using it. --- guix/git.scm | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/git.scm b/guix/git.scm index ad4fc30c4b..7a83b56216 100644 --- a/guix/git.scm +++ b/guix/git.scm @@ -58,7 +58,10 @@ make sure no empty directory is left behind." ;; Note: Explicitly pass options to work around the invalid default ;; value in Guile-Git: . - (clone url directory (clone-init-options))) + (if (module-defined? (resolve-interface '(git)) + 'clone-init-options) + (clone url directory (clone-init-options)) + (clone url directory))) (lambda _ (false-if-exception (rmdir directory))))) -- cgit v1.2.3 From ecc585711e5120bfa0e9f9839d560d831f40c1a1 Mon Sep 17 00:00:00 2001 From: Leo Famulari Date: Sun, 12 Nov 2017 17:40:52 -0500 Subject: download: Try FTP servers last. * guix/download.scm (%mirrors)[savannah, kernel.org, apache, xorg, imagemagick]: Re-arrange so that FTP is last. --- guix/download.scm | 38 +++++++++++++++++++------------------- 1 file changed, 19 insertions(+), 19 deletions(-) (limited to 'guix') diff --git a/guix/download.scm b/guix/download.scm index 17dac3f8ef..95829f5be4 100644 --- a/guix/download.scm +++ b/guix/download.scm @@ -95,17 +95,17 @@ "http://hackage.haskell.org/") (savannah "http://download.savannah.gnu.org/releases/" - "ftp://ftp.twaren.net/Unix/NonGNU/" - "ftp://mirror.csclub.uwaterloo.ca/nongnu/" - "ftp://mirror.publicns.net/pub/nongnu/" - "ftp://savannah.c3sl.ufpr.br/" "http://ftp.cc.uoc.gr/mirrors/nongnu.org/" "http://ftp.twaren.net/Unix/NonGNU/" "http://mirror.csclub.uwaterloo.ca/nongnu/" "http://nongnu.askapache.com/" "http://savannah.c3sl.ufpr.br/" "http://download.savannah.gnu.org/releases-noredirect/" - "http://download-mirror.savannah.gnu.org/releases/") + "http://download-mirror.savannah.gnu.org/releases/" + "ftp://ftp.twaren.net/Unix/NonGNU/" + "ftp://mirror.csclub.uwaterloo.ca/nongnu/" + "ftp://mirror.publicns.net/pub/nongnu/" + "ftp://savannah.c3sl.ufpr.br/") (sourceforge ; https://sourceforge.net/p/forge/documentation/Mirrors/ "http://downloads.sourceforge.net/project/" "http://ufpr.dl.sourceforge.net/project/" @@ -134,26 +134,26 @@ "http://ramses.wh2.tu-dresden.de/pub/mirrors/kernel.org/" "http://linux-kernel.uio.no/pub/" "http://kernel.osuosl.org/pub/" - "ftp://ftp.funet.fi/pub/mirrors/ftp.kernel.org/pub/" "http://ftp.be.debian.org/pub/" - "http://mirror.linux.org.au/") + "http://mirror.linux.org.au/" + "ftp://ftp.funet.fi/pub/mirrors/ftp.kernel.org/pub/") (apache ; from http://www.apache.org/mirrors/dist.html "http://www.eu.apache.org/dist/" "http://www.us.apache.org/dist/" - "ftp://gd.tuwien.ac.at/pub/infosys/servers/http/apache/dist/" "http://apache.belnet.be/" "http://mirrors.ircam.fr/pub/apache/" "http://apache-mirror.rbc.ru/pub/apache/" + "ftp://gd.tuwien.ac.at/pub/infosys/servers/http/apache/dist/" ;; As a last resort, try the archive. "http://archive.apache.org/dist/") (xorg ; from http://www.x.org/wiki/Releases/Download "http://www.x.org/releases/" ; main mirrors - "ftp://mirror.csclub.uwaterloo.ca/x.org/" ; North America - "ftp://xorg.mirrors.pair.com/" - "http://mirror.csclub.uwaterloo.ca/x.org/" + "http://mirror.csclub.uwaterloo.ca/x.org/" ; North America "http://xorg.mirrors.pair.com/" "http://mirror.us.leaseweb.net/xorg/" + "ftp://mirror.csclub.uwaterloo.ca/x.org/" + "ftp://xorg.mirrors.pair.com/" "ftp://artfiles.org/x.org/" ; Europe "ftp://ftp.chg.ru/pub/X11/x.org/" "ftp://ftp.fu-berlin.de/unix/X11/FTP.X.ORG/" @@ -169,12 +169,12 @@ "ftp://mirror.switch.ch/mirror/X11/" "ftp://mirrors.ircam.fr/pub/x.org/" "ftp://x.mirrors.skynet.be/pub/ftp.x.org/" - "ftp://ftp.cs.cuhk.edu.hk/pub/X11" ; East Asia + "http://x.cs.pu.edu.tw/" ; East Asia + "ftp://ftp.cs.cuhk.edu.hk/pub/X11" "ftp://ftp.u-aizu.ac.jp/pub/x11/x.org/" "ftp://ftp.yz.yamagata-u.ac.jp/pub/X11/x.org/" "ftp://ftp.kaist.ac.kr/x.org/" "ftp://mirrors.go-part.com/xorg/" - "http://x.cs.pu.edu.tw/" "ftp://ftp.is.co.za/pub/x.org") ; South Africa (cpan "http://www.cpan.org/" @@ -249,18 +249,18 @@ ;; mirrors keeping old versions at the top level "ftp://sunsite.icm.edu.pl/packages/ImageMagick/" ;; mirrors moving old versions to "legacy" - "ftp://mirror.aarnet.edu.au/pub/imagemagick/" + "http://mirrors-usa.go-parts.com/mirrors/ImageMagick/" "http://mirror.checkdomain.de/imagemagick/" + "http://ftp.surfnet.nl/pub/ImageMagick/" + "http://mirror.searchdaimon.com/ImageMagick" + "http://mirror.is.co.za/pub/imagemagick/" + "http://www.imagemagick.org/download/" + "ftp://mirror.aarnet.edu.au/pub/imagemagick/" "ftp://ftp.kddlabs.co.jp/graphics/ImageMagick/" "ftp://ftp.u-aizu.ac.jp/pub/graphics/image/ImageMagick/imagemagick.org/" "ftp://ftp.nluug.nl/pub/ImageMagick/" - "http://ftp.surfnet.nl/pub/ImageMagick/" - "http://mirror.searchdaimon.com/ImageMagick" "ftp://ftp.tpnet.pl/pub/graphics/ImageMagick/" - "http://mirror.is.co.za/pub/imagemagick/" - "http://mirrors-usa.go-parts.com/mirrors/ImageMagick/" "ftp://ftp.fifi.org/pub/ImageMagick/" - "http://www.imagemagick.org/download/" ;; one legacy location as a last resort "http://www.imagemagick.org/download/legacy/") (debian -- cgit v1.2.3 From d0b87779f0a104b4b926a8290ed362c5b8e05cf6 Mon Sep 17 00:00:00 2001 From: Leo Famulari Date: Sun, 12 Nov 2017 17:47:53 -0500 Subject: download: Use HTTPS for the first ImageMagick mirror. * guix/download.scm (%mirrors)[imagemagick]: Use HTTPS for . --- guix/download.scm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/download.scm b/guix/download.scm index 95829f5be4..8a0b19c012 100644 --- a/guix/download.scm +++ b/guix/download.scm @@ -247,7 +247,7 @@ ;; from http://www.imagemagick.org/script/download.php ;; (without mirrors that are unavailable or not up to date) ;; mirrors keeping old versions at the top level - "ftp://sunsite.icm.edu.pl/packages/ImageMagick/" + "https://sunsite.icm.edu.pl/packages/ImageMagick/" ;; mirrors moving old versions to "legacy" "http://mirrors-usa.go-parts.com/mirrors/ImageMagick/" "http://mirror.checkdomain.de/imagemagick/" -- cgit v1.2.3 From 412716eff2d898f28636f68cb8761862f416cac3 Mon Sep 17 00:00:00 2001 From: Leo Famulari Date: Tue, 14 Nov 2017 16:29:13 -0500 Subject: grafts: Clarify the status of the workaround for . * guix/build/graft.scm (mkdir-p*): Annotate. --- guix/build/graft.scm | 1 + 1 file changed, 1 insertion(+) (limited to 'guix') diff --git a/guix/build/graft.scm b/guix/build/graft.scm index 3dce486adf..e567bff4f4 100644 --- a/guix/build/graft.scm +++ b/guix/build/graft.scm @@ -214,6 +214,7 @@ an exception is caught." (print-exception port #f key args) (primitive-exit 1)))))) +;; We need this as long as we support Guile < 2.0.13. (define* (mkdir-p* dir #:optional (mode #o755)) "This is a variant of 'mkdir-p' that works around by passing MODE explicitly in each 'mkdir' call." -- cgit v1.2.3 From 9f8605958ef86a0054a04297917ca32ed58d9d56 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 14 Nov 2017 09:51:50 +0100 Subject: download: Pass the timeout to 'ftp-retr'. This ensures the timeout applies when connecting to the port returned by PASV. * guix/ftp-client.scm (ftp-list): Add #:timeout parameter. Use 'connect*' instead of 'connect' and pass TIMEOUT. (ftp-retr): Likewise. * guix/build/download.scm (ftp-fetch): Pass TIMEOUT to 'ftp-retr'. --- guix/build/download.scm | 3 ++- guix/ftp-client.scm | 11 ++++++----- 2 files changed, 8 insertions(+), 6 deletions(-) (limited to 'guix') diff --git a/guix/build/download.scm b/guix/build/download.scm index a65c7b9964..90de269f9b 100644 --- a/guix/build/download.scm +++ b/guix/build/download.scm @@ -130,7 +130,8 @@ out if the connection could not be established in less than TIMEOUT seconds." (_ (ftp-open (uri-host uri) #:timeout timeout)))) (size (false-if-exception (ftp-size conn (uri-path uri)))) (in (ftp-retr conn (basename (uri-path uri)) - (dirname (uri-path uri))))) + (dirname (uri-path uri)) + #:timeout timeout))) (call-with-output-file file (lambda (out) (dump-port* in out diff --git a/guix/ftp-client.scm b/guix/ftp-client.scm index 054a00ad7f..0b8f61c276 100644 --- a/guix/ftp-client.scm +++ b/guix/ftp-client.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2010, 2011, 2012, 2013, 2014, 2015, 2016 Ludovic Courtès +;;; Copyright © 2010, 2011, 2012, 2013, 2014, 2015, 2016, 2017 Ludovic Courtès ;;; ;;; This file is part of GNU Guix. ;;; @@ -228,7 +228,7 @@ TIMEOUT, an ETIMEDOUT error is raised." (sockaddr:scopeid sa))) (else #f)))) -(define* (ftp-list conn #:optional directory) +(define* (ftp-list conn #:optional directory #:key timeout) (if directory (ftp-chdir conn directory)) @@ -236,7 +236,7 @@ TIMEOUT, an ETIMEDOUT error is raised." (ai (ftp-connection-addrinfo conn)) (s (socket (addrinfo:fam ai) (addrinfo:socktype ai) (addrinfo:protocol ai)))) - (connect s (address-with-port (addrinfo:addr ai) port)) + (connect* s (address-with-port (addrinfo:addr ai) port) timeout) (setvbuf s _IOLBF) (dynamic-wind @@ -270,7 +270,8 @@ TIMEOUT, an ETIMEDOUT error is raised." (or (eqv? code 226) (throw 'ftp-error conn "LIST" code message))))))) -(define* (ftp-retr conn file #:optional directory) +(define* (ftp-retr conn file #:optional directory + #:key timeout) "Retrieve FILE from DIRECTORY (or, if omitted, the current directory) from FTP connection CONN. Return a binary port to that file. The returned port must be closed before CONN can be used for other purposes." @@ -291,7 +292,7 @@ must be closed before CONN can be used for other purposes." (or (eqv? code 226) (throw 'ftp-error conn "LIST" code message)))) - (connect s (address-with-port (addrinfo:addr ai) port)) + (connect* s (address-with-port (addrinfo:addr ai) port) timeout) (setvbuf s _IOLBF) (%ftp-command (string-append "RETR " file) -- cgit v1.2.3 From 866f37fb7e4f3e0bd695a951071383cdff3da8cd Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 15 Nov 2017 09:59:29 +0100 Subject: download: Improve efficiency of 'write-request' over TLS. This is another instance of . The Microsoft-IIS/7.5 server at static.nvd.nist.gov would sometimes hang when receiving our requests byte by byte. * guix/build/download.scm (tls-wrap) [!guile-2.0]: Add 'setvbuf' call. --- guix/build/download.scm | 7 +++++++ 1 file changed, 7 insertions(+) (limited to 'guix') diff --git a/guix/build/download.scm b/guix/build/download.scm index 90de269f9b..4490d225e6 100644 --- a/guix/build/download.scm +++ b/guix/build/download.scm @@ -306,6 +306,13 @@ host name without trailing dot." ;; never be closed. So we use `fileno', but keep a weak reference to ;; PORT, so the file descriptor gets closed when RECORD is GC'd. (register-tls-record-port record port) + + ;; Write HTTP requests line by line rather than byte by byte: + ;; . This is not possible on Guile 2.0. + (cond-expand + (guile-2.0 #f) + (else (setvbuf record 'line))) + record))) (define (ensure-uri uri-or-string) ;XXX: copied from (web http) -- cgit v1.2.3 From 7482b98120b5e3380129719f13254b90b18553b9 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 15 Nov 2017 10:23:38 +0100 Subject: cve: Use 'http-fetch/cached' instead of having custom caching. That way CVE fetching benefits from 'If-Modified-Since' handling. * guix/http-client.scm (http-fetch/cached): Add #:write-cache and #:cache-miss parameters and honor them. * guix/cve.scm (%current-year-ttl, %past-year-ttl): Reduce. (call-with-cve-port): Remove. (write-cache): New procedure. (fetch-vulnerabilities): Rewrite in terms of 'http-fetch/cached'. --- guix/cve.scm | 94 ++++++++++++++++++---------------------------------- guix/http-client.scm | 13 ++++++-- 2 files changed, 42 insertions(+), 65 deletions(-) (limited to 'guix') diff --git a/guix/cve.scm b/guix/cve.scm index 38e59944c8..070acfeb3e 100644 --- a/guix/cve.scm +++ b/guix/cve.scm @@ -19,7 +19,6 @@ (define-module (guix cve) #:use-module (guix utils) #:use-module (guix http-client) - #:use-module ((guix build utils) #:select (mkdir-p)) #:use-module (sxml ssax) #:use-module (web uri) #:use-module (srfi srfi-1) @@ -68,24 +67,11 @@ (define %current-year-ttl ;; According to , feeds are ;; updated "approximately every two hours." - (* 3600 3)) + (* 60 30)) (define %past-year-ttl ;; Update the previous year's database more and more infrequently. - (* 3600 24 2 (date-month %now))) - -(define (call-with-cve-port uri ttl proc) - "Pass PROC an input port from which to read the CVE stream." - (let ((port (http-fetch uri))) - (dynamic-wind - (const #t) - (lambda () - (call-with-decompressed-port 'gzip port - (lambda (port) - (setvbuf port _IOFBF 65536) - (proc port)))) - (lambda () - (close-port port))))) + (* 3600 24 (date-month %now))) (define %cpe-package-rx ;; For applications: "cpe:/a:VENDOR:PACKAGE:VERSION", or sometimes @@ -194,40 +180,27 @@ vulnerability objects." (('v id (packages ...)) (vulnerability id packages)))) -(define (fetch-vulnerabilities year ttl) - "Return the list of for YEAR, assuming the on-disk cache has -the given TTL (fetch from the NIST web site when TTL has expired)." - ;; Note: We used to keep the original XML files in cache but parsing it - ;; would take typically ~15s for a year of data. Thus, we instead store a - ;; summarized version thereof as an sexp, which can be parsed in 1s or so. - (define cache - (string-append (cache-directory) "/cve/" (number->string year))) - - (define (do-fetch) - (call-with-cve-port (yearly-feed-uri year) ttl - (lambda (port) - ;; XXX: The SSAX "error port" is used to send pointless warnings such as - ;; "warning: Skipping PI". Turn that off. - (format (current-error-port) "fetching CVE database for ~a...~%" year) +(define (write-cache input cache) + "Read vulnerabilities as gzipped XML from INPUT, and write it as a compact +sexp to CACHE." + (call-with-decompressed-port 'gzip input + (lambda (input) + ;; XXX: The SSAX "error port" is used to send pointless warnings such as + ;; "warning: Skipping PI". Turn that off. + (define vulns (parameterize ((current-ssax-error-port (%make-void-port "w"))) - (xml->vulnerabilities port))))) + (xml->vulnerabilities input))) - (define (update-cache) - (mkdir-p (dirname cache)) - (let ((vulns (do-fetch))) - (with-atomic-file-output cache - (lambda (port) - (write `(vulnerabilities - 1 ;format version - ,(map vulnerability->sexp vulns)) - port))) - vulns)) + (write `(vulnerabilities + 1 ;format version + ,(map vulnerability->sexp vulns)) + cache)))) - (define (old? file) - ;; Return true if PORT has passed TTL. - (let* ((s (stat file)) - (now (current-time time-utc))) - (< (+ (stat:mtime s) ttl) (time-second now)))) +(define (fetch-vulnerabilities year ttl) + "Return the list of for YEAR, assuming the on-disk cache has +the given TTL (fetch from the NIST web site when TTL has expired)." + (define (cache-miss uri) + (format (current-error-port) "fetching CVE database for ~a...~%" year)) (define (read* port) ;; Disable read options to avoid populating the source property weak @@ -242,17 +215,18 @@ the given TTL (fetch from the NIST web site when TTL has expired)." (lambda () (read-options options))))) - (catch 'system-error - (lambda () - (if (old? cache) - (update-cache) - (match (call-with-input-file cache read*) - (('vulnerabilities 1 vulns) - (map sexp->vulnerability vulns)) - (x - (update-cache))))) - (lambda args - (update-cache)))) + ;; Note: We used to keep the original XML files in cache but parsing it + ;; would take typically ~15s for a year of data. Thus, we instead store a + ;; summarized version thereof as an sexp, which can be parsed in 1s or so. + (let* ((port (http-fetch/cached (yearly-feed-uri year) + #:ttl ttl + #:write-cache write-cache + #:cache-miss cache-miss)) + (sexp (read* port))) + (close-port port) + (match sexp + (('vulnerabilities 1 vulns) + (map sexp->vulnerability vulns))))) (define (current-vulnerabilities) "Return the current list of Common Vulnerabilities and Exposures (CVE) as @@ -307,8 +281,4 @@ vulnerabilities affecting the given package version." package table))) -;;; Local Variables: -;;; eval: (put 'call-with-cve-port 'scheme-indent-function 2) -;;; End: - ;;; cve.scm ends here diff --git a/guix/http-client.scm b/guix/http-client.scm index 59788c1f38..bab31875d1 100644 --- a/guix/http-client.scm +++ b/guix/http-client.scm @@ -302,9 +302,15 @@ Raise an '&http-get-error' condition if downloading fails." (base64-encode digest 0 (bytevector-length digest) #f #f base64url-alphabet)))) -(define* (http-fetch/cached uri #:key (ttl (%http-cache-ttl)) text?) +(define* (http-fetch/cached uri #:key (ttl (%http-cache-ttl)) text? + (write-cache dump-port) + (cache-miss (const #t))) "Like 'http-fetch', return an input port, but cache its contents in -~/.cache/guix. The cache remains valid for TTL seconds." +~/.cache/guix. The cache remains valid for TTL seconds. + +Call WRITE-CACHE with the HTTP input port and the cache output port to write +the data to cache. Call CACHE-MISS with URI just before fetching data from +URI." (let ((file (cache-file-for-uri uri))) (define (update-cache cache-port) (define cache-time @@ -327,11 +333,12 @@ Raise an '&http-get-error' condition if downloading fails." (raise c)))) (let ((port (http-fetch uri #:text? text? #:headers headers))) + (cache-miss uri) (mkdir-p (dirname file)) (when cache-port (close-port cache-port)) (with-atomic-file-output file - (cut dump-port port <>)) + (cut write-cache port <>)) (close-port port) (open-input-file file)))) -- cgit v1.2.3 From 304a53f67aa4970dec98586e74c45487b0cd68ae Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 15 Nov 2017 17:38:21 +0100 Subject: ui: Add source file name to the package search metrics. * guix/ui.scm (%package-metrics): Include 'package-location'. Increase score of the other fields. --- guix/ui.scm | 11 ++++++++--- 1 file changed, 8 insertions(+), 3 deletions(-) (limited to 'guix') diff --git a/guix/ui.scm b/guix/ui.scm index 05782a537e..0fc5ab63ad 100644 --- a/guix/ui.scm +++ b/guix/ui.scm @@ -1121,9 +1121,14 @@ score, the more relevant OBJ is to REGEXPS." (define %package-metrics ;; Metrics used to compute the "relevance score" of a package against a set ;; of regexps. - `((,package-name . 3) - (,package-synopsis-string . 2) - (,package-description-string . 1))) + `((,package-name . 4) + (,package-synopsis-string . 3) + (,package-description-string . 2) + (,(lambda (type) + (match (and=> (package-location type) location-file) + ((? string? file) (basename file ".scm")) + (#f ""))) + . 1))) (define (package-relevance package regexps) "Return a score denoting the relevance of PACKAGE for REGEXPS. A score of -- cgit v1.2.3 From 232b3d31016439b5600e47d845ffb7c9a4ee4723 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 17 Nov 2017 10:10:30 +0100 Subject: workers: 'pool-idle?' returns true only if the workers are idle. Fixes . Reported by Eric Bavier . * guix/workers.scm ()[busy]: New field. (worker-thunk): Add #:idle and #:busy and use them. (make-pool): Pass #:busy and #:idle to 'worker-thunk'. Pass a 'busy' value to '%make-pool'. * guix/workers.scm (pool-idle?): Check whether 'pool-busy' returns zero and adjust docstring. --- guix/workers.scm | 24 +++++++++++++++++------- 1 file changed, 17 insertions(+), 7 deletions(-) (limited to 'guix') diff --git a/guix/workers.scm b/guix/workers.scm index 846f5e50a9..0f6f54bab0 100644 --- a/guix/workers.scm +++ b/guix/workers.scm @@ -45,12 +45,13 @@ ;;; Code: (define-record-type - (%make-pool queue mutex condvar workers) + (%make-pool queue mutex condvar workers busy) pool? (queue pool-queue) (mutex pool-mutex) (condvar pool-condition-variable) - (workers pool-workers)) + (workers pool-workers) + (busy pool-busy)) (define-syntax-rule (without-mutex mutex exp ...) (dynamic-wind @@ -62,12 +63,14 @@ (lock-mutex mutex)))) (define* (worker-thunk mutex condvar pop-queue - #:key (thread-name "guix worker")) + #:key idle busy (thread-name "guix worker")) "Return the thunk executed by worker threads." (define (loop) (match (pop-queue) (#f ;empty queue - (wait-condition-variable condvar mutex)) + (idle) + (wait-condition-variable condvar mutex) + (busy)) ((? procedure? proc) ;; Release MUTEX while executing PROC. (without-mutex mutex @@ -97,19 +100,24 @@ threads as reported by the operating system." (let* ((mutex (make-mutex)) (condvar (make-condition-variable)) (queue (make-q)) + (busy count) (procs (unfold (cut >= <> count) (lambda (n) (worker-thunk mutex condvar (lambda () (and (not (q-empty? queue)) (q-pop! queue))) + #:busy (lambda () + (set! busy (+ 1 busy))) + #:idle (lambda () + (set! busy (- busy 1))) #:thread-name thread-name)) 1+ 0)) (threads (map (lambda (proc) (call-with-new-thread proc)) procs))) - (%make-pool queue mutex condvar threads))) + (%make-pool queue mutex condvar threads (lambda () busy)))) (define (pool-enqueue! pool thunk) "Enqueue THUNK for future execution by POOL." @@ -118,9 +126,11 @@ threads as reported by the operating system." (signal-condition-variable (pool-condition-variable pool)))) (define (pool-idle? pool) - "Return true if POOL doesn't have any task in its queue." + "Return true if POOL doesn't have any task in its queue and all the workers +are currently idle (i.e., waiting for a task)." (with-mutex (pool-mutex pool) - (q-empty? (pool-queue pool)))) + (and (q-empty? (pool-queue pool)) + (zero? ((pool-busy pool)))))) (define-syntax-rule (eventually pool exp ...) "Run EXP eventually on one of the workers of POOL." -- cgit v1.2.3 From d5ce7bcfa2f4d9a1d3da669ade155cc7042f84ec Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 17 Nov 2017 10:47:56 +0100 Subject: workers: Display backtrace in pre-unwind handler. * guix/workers.scm (worker-thunk): Add (const #f) as the 'catch' handler, and move previous handler as pre-unwind handler. Protect against 'make-stack' returning #f. --- guix/workers.scm | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/workers.scm b/guix/workers.scm index 0f6f54bab0..3cd683c96d 100644 --- a/guix/workers.scm +++ b/guix/workers.scm @@ -75,12 +75,14 @@ ;; Release MUTEX while executing PROC. (without-mutex mutex (catch #t proc + (const #f) (lambda (key . args) ;; XXX: In Guile 2.0 ports are not thread-safe, so this could ;; crash (Guile 2.2 is fine). (display-backtrace (make-stack #t) (current-error-port)) (print-exception (current-error-port) - (stack-ref (make-stack #t) 0) + (and=> (make-stack #t) + (cut stack-ref <> 0)) key args)))))) (loop)) -- cgit v1.2.3 From d8e257113c48b3b748de43458295331f120d04c3 Mon Sep 17 00:00:00 2001 From: Leo Famulari Date: Tue, 14 Nov 2017 11:46:22 -0500 Subject: build-system/go: Don't let Go executables refer to the Go compiler. * guix/build/go-build-system.scm (remove-store-reference, remove-go-references): New procedures. (%standard-phases): Add 'remove-go-references' phase. * guix/build-system/go.scm (go-build): Add allow-go-reference? key. --- guix/build-system/go.scm | 2 ++ guix/build/go-build-system.scm | 60 ++++++++++++++++++++++++++++++++++++++++-- 2 files changed, 60 insertions(+), 2 deletions(-) (limited to 'guix') diff --git a/guix/build-system/go.scm b/guix/build-system/go.scm index ec447d2a28..cf91163275 100644 --- a/guix/build-system/go.scm +++ b/guix/build-system/go.scm @@ -82,6 +82,7 @@ (import-path "") (unpack-path "") (tests? #t) + (allow-go-reference? #f) (system (%current-system)) (guile #f) (imported-modules %go-build-system-modules) @@ -107,6 +108,7 @@ #:import-path ,import-path #:unpack-path ,unpack-path #:tests? ,tests? + #:allow-go-reference? ,allow-go-reference? #:inputs %build-inputs))) (define guile-for-build diff --git a/guix/build/go-build-system.scm b/guix/build/go-build-system.scm index d175f3b76a..eaad9d8751 100644 --- a/guix/build/go-build-system.scm +++ b/guix/build/go-build-system.scm @@ -22,6 +22,8 @@ #:use-module (guix build utils) #:use-module (ice-9 match) #:use-module (srfi srfi-1) + #:use-module (rnrs io ports) + #:use-module (rnrs bytevectors) #:export (%standard-phases go-build)) @@ -197,13 +199,66 @@ respectively." (define* (install #:key outputs #:allow-other-keys) "Install the compiled libraries. `go install` installs these files to -$GOPATH/pkg, so we have to copy them into the output direcotry manually. +$GOPATH/pkg, so we have to copy them into the output directory manually. Compiled executable files should have already been installed to the store based on $GOBIN in the build phase." (when (file-exists? "pkg") (copy-recursively "pkg" (string-append (assoc-ref outputs "out") "/pkg"))) #t) +(define* (remove-store-reference file file-name + #:optional (store (%store-directory))) + "Remove from FILE occurrences of FILE-NAME in STORE; return #t when FILE-NAME +is encountered in FILE, #f otherwise. This implementation reads FILE one byte at +a time, which is slow. Instead, we should use the Boyer-Moore string search +algorithm; there is an example in (guix build grafts)." + (define pattern + (string-take file-name + (+ 34 (string-length (%store-directory))))) + + (with-fluids ((%default-port-encoding #f)) + (with-atomic-file-replacement file + (lambda (in out) + ;; We cannot use `regexp-exec' here because it cannot deal with + ;; strings containing NUL characters. + (format #t "removing references to `~a' from `~a'...~%" file-name file) + (setvbuf in 'block 65536) + (setvbuf out 'block 65536) + (fold-port-matches (lambda (match result) + (put-bytevector out (string->utf8 store)) + (put-u8 out (char->integer #\/)) + (put-bytevector out + (string->utf8 + "eeeeeeeeeeeeeeeeeeeeeeeeeeeeeeee-")) + #t) + #f + pattern + in + (lambda (char result) + (put-u8 out (char->integer char)) + result)))))) + +(define* (remove-go-references #:key allow-go-reference? + inputs outputs #:allow-other-keys) + "Remove any references to the Go compiler from the compiled Go executable +files in OUTPUTS." +;; We remove this spurious reference to save bandwidth when installing Go +;; executables. It would be better to not embed the reference in the first +;; place, but I'm not sure how to do that. The subject was discussed at: +;; + (if allow-go-reference? + #t + (let ((go (assoc-ref inputs "go")) + (bin "/bin")) + (for-each (lambda (output) + (when (file-exists? (string-append (cdr output) + bin)) + (for-each (lambda (file) + (remove-store-reference file go)) + (find-files (string-append (cdr output) bin))))) + outputs) + #t))) + (define %standard-phases (modify-phases gnu:%standard-phases (delete 'configure) @@ -213,7 +268,8 @@ on $GOBIN in the build phase." (add-before 'build 'setup-environment setup-environment) (replace 'build build) (replace 'check check) - (replace 'install install))) + (replace 'install install) + (add-after 'install 'remove-go-references remove-go-references))) (define* (go-build #:key inputs (phases %standard-phases) #:allow-other-keys #:rest args) -- cgit v1.2.3 From 82af2c2f0f9eaaa1408c4e36d8a4273bf6f05ea1 Mon Sep 17 00:00:00 2001 From: Ricardo Wurmus Date: Sat, 18 Nov 2017 11:16:34 +0100 Subject: build-system: texlive: Only make a union of directories. * guix/build/texlive-build-system.scm (configure): Filter the input directories to ensure that source tarballs are excluded. --- guix/build/texlive-build-system.scm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/build/texlive-build-system.scm b/guix/build/texlive-build-system.scm index c0f262a5c0..f6b9b96b87 100644 --- a/guix/build/texlive-build-system.scm +++ b/guix/build/texlive-build-system.scm @@ -46,7 +46,7 @@ ;; Build a modifiable union of all inputs (but exclude bash) (match inputs (((names . directories) ...) - (union-build out directories + (union-build out (filter directory-exists? directories) #:create-all-directories? #t #:log-port (%make-void-port "w")))) -- cgit v1.2.3 From 965ba54be0674de7d84430622ec35b0de24c7334 Mon Sep 17 00:00:00 2001 From: Julien Lepiller Date: Sun, 5 Nov 2017 12:39:51 +0100 Subject: licenses: Add cddl1.1. * guix/licenses.scm (cddl1.1): New variable. --- guix/licenses.scm | 10 +++++++++- 1 file changed, 9 insertions(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/licenses.scm b/guix/licenses.scm index 6de611da2b..b07d80076e 100644 --- a/guix/licenses.scm +++ b/guix/licenses.scm @@ -42,7 +42,7 @@ cc-by2.0 cc-by3.0 cc-by4.0 cc-by-sa2.0 cc-by-sa3.0 cc-by-sa4.0 cc-sampling-plus-1.0 - cddl1.0 + cddl1.0 cddl1.1 cecill cecill-b cecill-c artistic2.0 clarified-artistic copyleft-next @@ -217,6 +217,14 @@ at URI, which may be a file:// URI pointing the package's tree." "http://directory.fsf.org/wiki/License:CDDLv1.0" "https://www.gnu.org/licenses/license-list#CDDL")) +;; CDDL1.1 is the same as 1.0, except that "Sun Microsystems, Inc" becomes "Oracle", +;; "LOST PROFITS" becoms "LOSS OF GOODWILL" and a section is added between 6.2 +;; and 6.3. +(define cddl1.1 + (license "CDDL 1.1" + "https://oss.oracle.com/licenses/CDDL+GPL-1.1" + "https://www.gnu.org/licenses/license-list#CDDL")) + (define cecill ;copyleft (license "CeCILL" "http://www.cecill.info/licences/Licence_CeCILL_V2.1-en.html" -- cgit v1.2.3