From 81fe131e0fc3c1fcfa29c140071c8cc4cff7cd2f Mon Sep 17 00:00:00 2001 From: Christopher Baines Date: Tue, 22 Aug 2017 18:11:35 +0100 Subject: build: emacs-build-system: Make the install phase more helpful. Modify the install phase to detect when nothing has been installed, and error if this happens. This is preferable to continuing, and allowing the next phase to fail. Also, when nothing can be found to be installed, print out each file that was considered, along with the regular expressions that were used to include and exclude it. * gnu/build/emacs-build-system.scm (install-file?): Add additional error checking and logging. --- guix/build/emacs-build-system.scm | 45 ++++++++++++++++++++++++++++----------- 1 file changed, 32 insertions(+), 13 deletions(-) (limited to 'guix/build') diff --git a/guix/build/emacs-build-system.scm b/guix/build/emacs-build-system.scm index bda699ddf..202ce5392 100644 --- a/guix/build/emacs-build-system.scm +++ b/guix/build/emacs-build-system.scm @@ -110,22 +110,41 @@ store in '.el' files." (define source (getcwd)) - (define (install-file? file stat) - (let ((stripped-file (string-trim (string-drop file (string-length source)) #\/))) - (and (any (cut string-match <> stripped-file) include) - (not (any (cut string-match <> stripped-file) exclude))))) + (define* (install-file? file stat #:key verbose?) + (let* ((stripped-file (string-trim + (string-drop file (string-length source)) #\/))) + (define (match-stripped-file action regex) + (let ((result (string-match regex stripped-file))) + (when (and result verbose?) + (format #t "info: ~A ~A as it matches \"~A\"\n" + stripped-file action regex)) + result)) + + (when verbose? + (format #t "info: considering installing ~A\n" stripped-file)) + + (and (any (cut match-stripped-file "included" <>) include) + (not (any (cut match-stripped-file "excluded" <>) exclude))))) (let* ((out (assoc-ref outputs "out")) (elpa-name-ver (store-directory->elpa-name-version out)) - (target-directory (string-append out %install-suffix "/" elpa-name-ver))) - (for-each - (lambda (file) - (let* ((stripped-file (string-drop file (string-length source))) - (target-file (string-append target-directory stripped-file))) - (format #t "`~a' -> `~a'~%" file target-file) - (install-file file (dirname target-file)))) - (find-files source install-file?))) - #t) + (target-directory (string-append out %install-suffix "/" elpa-name-ver)) + (files-to-install (find-files source install-file?))) + (cond + (files-to-install + (for-each + (lambda (file) + (let* ((stripped-file (string-drop file (string-length source))) + (target-file (string-append target-directory stripped-file))) + (format #t "`~a' -> `~a'~%" file target-file) + (install-file file (dirname target-file)))) + files-to-install) + #t) + (else + (format #t "error: No files found to install.\n") + (find-files source (lambda (file stat) + (install-file? file stat #:verbose? #t))) + #f)))) (define* (move-doc #:key outputs #:allow-other-keys) "Move info files from the ELPA package directory to the info directory." -- cgit v1.3 From 43637673944226412a27967c235046546d7771ed Mon Sep 17 00:00:00 2001 From: Christopher Baines Date: Sun, 3 Sep 2017 19:39:11 +0100 Subject: build: Fix helpful output for emacs-build-system install phase. Detecting when no files were installed was broken when switching to use cond. Test with (not (null? ...)) to fix this. * guix/build/emacs-build-system.scm (install): Fix detecting when no files were installed. --- guix/build/emacs-build-system.scm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'guix/build') diff --git a/guix/build/emacs-build-system.scm b/guix/build/emacs-build-system.scm index 202ce5392..2404dbddb 100644 --- a/guix/build/emacs-build-system.scm +++ b/guix/build/emacs-build-system.scm @@ -131,7 +131,7 @@ store in '.el' files." (target-directory (string-append out %install-suffix "/" elpa-name-ver)) (files-to-install (find-files source install-file?))) (cond - (files-to-install + ((not (null? files-to-install)) (for-each (lambda (file) (let* ((stripped-file (string-drop file (string-length source))) -- cgit v1.3 From 57d28987722cb6b830fae212ea0d6a704580ff9c Mon Sep 17 00:00:00 2001 From: Tobias Geerinckx-Rice Date: Mon, 28 Aug 2017 15:46:10 +0200 Subject: Handle the same HTTP redirects everywhere. * guix/build/download.scm (http-fetch): Complete the hard-coded list of HTTP redirection status codes. * guix/http-client.scm (http-fetch): Likewise. * guix/scripts/lint.scm (probe-uri): Likewise. --- guix/build/download.scm | 5 ++++- guix/http-client.scm | 6 +++++- guix/scripts/lint.scm | 7 ++++++- 3 files changed, 15 insertions(+), 3 deletions(-) (limited to 'guix/build') diff --git a/guix/build/download.scm b/guix/build/download.scm index 6ef623334..bcf22663b 100644 --- a/guix/build/download.scm +++ b/guix/build/download.scm @@ -2,6 +2,7 @@ ;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017 Ludovic Courtès ;;; Copyright © 2015 Mark H Weaver ;;; Copyright © 2015 Steve Sprang +;;; Copyright © 2017 Tobias Geerinckx-Rice ;;; ;;; This file is part of GNU Guix. ;;; @@ -763,7 +764,9 @@ certificates; otherwise simply ignore them." file)) ((301 ; moved permanently 302 ; found (redirection) - 307) ; temporary redirection + 303 ; see other + 307 ; temporary redirection + 308) ; permanent redirection (let ((uri (resolve-uri-reference (response-location resp) uri))) (format #t "following redirection to `~a'...~%" (uri->string uri)) diff --git a/guix/http-client.scm b/guix/http-client.scm index 3c5441c38..5c9342c21 100644 --- a/guix/http-client.scm +++ b/guix/http-client.scm @@ -2,6 +2,7 @@ ;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017 Ludovic Courtès ;;; Copyright © 2015 Mark H Weaver ;;; Copyright © 2012, 2015 Free Software Foundation, Inc. +;;; Copyright © 2017 Tobias Geerinckx-Rice ;;; ;;; This file is part of GNU Guix. ;;; @@ -259,7 +260,10 @@ Raise an '&http-get-error' condition if downloading fails." ((200) (values data (response-content-length resp))) ((301 ; moved permanently - 302) ; found (redirection) + 302 ; found (redirection) + 303 ; see other + 307 ; temporary redirection + 308) ; permanent redirection (let ((uri (resolve-uri-reference (response-location resp) uri))) (close-port port) (format #t (G_ "following redirection to `~a'...~%") diff --git a/guix/scripts/lint.scm b/guix/scripts/lint.scm index aceafc674..57bbeec46 100644 --- a/guix/scripts/lint.scm +++ b/guix/scripts/lint.scm @@ -6,6 +6,7 @@ ;;; Copyright © 2016 Danny Milosavljevic ;;; Copyright © 2016 Hartmut Goebel ;;; Copyright © 2017 Alex Kost +;;; Copyright © 2017 Tobias Geerinckx-Rice ;;; ;;; This file is part of GNU Guix. ;;; @@ -411,7 +412,11 @@ for connections to complete; when TIMEOUT is #f, wait as long as needed." (close-connection port)))) (case (response-code response) - ((301 302 307) + ((301 ; moved permanently + 302 ; found (redirection) + 303 ; see other + 307 ; temporary redirection + 308) ; permanent redirection (let ((location (response-location response))) (if (or (not location) (member location visited)) (values 'http-response response) -- cgit v1.3 From 07c101e2215c43616c2bb28b1cb0743ecfdc7c87 Mon Sep 17 00:00:00 2001 From: Peter Mikkelsen Date: Wed, 13 Sep 2017 14:37:39 +0200 Subject: build-system: Add 'meson-build-system'. * Makefile.am (MODULES): Add 'guix/build-system/meson.scm' and 'guix/build/meson-build-system.scm'. * guix/build-system/meson.scm: New file. * guix/build/meson-build-system.scm: New file. * doc/guix.texi (Build Systems): Add 'meson-build-system'. Signed-off-by: Ludovic Courtès --- Makefile.am | 2 + doc/guix.texi | 55 ++++++++++++ guix/build-system/meson.scm | 178 ++++++++++++++++++++++++++++++++++++++ guix/build/meson-build-system.scm | 150 ++++++++++++++++++++++++++++++++ 4 files changed, 385 insertions(+) create mode 100644 guix/build-system/meson.scm create mode 100644 guix/build/meson-build-system.scm (limited to 'guix/build') diff --git a/Makefile.am b/Makefile.am index a2fb31391..e35bdac30 100644 --- a/Makefile.am +++ b/Makefile.am @@ -79,6 +79,7 @@ MODULES = \ guix/build-system/dub.scm \ guix/build-system/emacs.scm \ guix/build-system/font.scm \ + guix/build-system/meson.scm \ guix/build-system/minify.scm \ guix/build-system/asdf.scm \ guix/build-system/glib-or-gtk.scm \ @@ -106,6 +107,7 @@ MODULES = \ guix/build/cmake-build-system.scm \ guix/build/dub-build-system.scm \ guix/build/emacs-build-system.scm \ + guix/build/meson-build-system.scm \ guix/build/minify-build-system.scm \ guix/build/font-build-system.scm \ guix/build/asdf-build-system.scm \ diff --git a/doc/guix.texi b/doc/guix.texi index ebeef5070..1356a357c 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -3811,6 +3811,61 @@ need to be copied into place. It copies font files to standard locations in the output directory. @end defvr +@defvr {Scheme Variable} meson-build-system +This variable is exported by @code{(guix build-system meson)}. It +implements the build procedure for packages that use +@url{http://mesonbuild.com, Meson} as their build system. + +It adds both Meson and @uref{https://ninja-build.org/, Ninja} to the set +of inputs, and they can be changed with the parameters @code{#:meson} +and @code{#:ninja} if needed. The default Meson is +@code{meson-for-build}, which is special because it doesn't clear the +@code{RUNPATH} of binaries and libraries when they are installed. + +This build system is an extension of @var{gnu-build-system}, but with the +following phases changed to some specific for Meson: + +@table @code + +@item configure +The phase runs @code{meson} with the flags specified in +@code{#:configure-flags}. The flag @code{--build-type} is always set to +@code{plain} unless something else is specified in @code{#:build-type}. + +@item build +The phase runs @code{ninja} to build the package in parallel by default, but +this can be changed with @code{#:parallel-build?}. + +@item check +The phase runs @code{ninja} with the target specified in @code{#:test-target}, +which is @code{"test"} by default. + +@item install +The phase runs @code{ninja install} and can not be changed. +@end table + +Apart from that, the build system also adds the following phases: + +@table @code + +@item fix-runpath +This phase tries to locate the local directories in the package being build, +which has libraries that some of the binaries need. If any are found, they will +be added to the programs @code{RUNPATH}. It is needed because +@code{meson-for-build} keeps the @code{RUNPATH} of binaries and libraries from +when they are build, but often that is not the @code{RUNPATH} we want. +Therefor it is also shrinked to the minimum needed by the program. + +@item glib-or-gtk-wrap +This phase is the phase provided by @code{glib-or-gtk-build-system}, and it +is not enabled by default. It can be enabled with @code{#:glib-or-gtk?}. + +@item glib-or-gtk-compile-schemas +This phase is the phase provided by @code{glib-or-gtk-build-system}, and it +is not enabled by default. It can be enabled with @code{#:glib-or-gtk?}. +@end table +@end defvr + Lastly, for packages that do not need anything as sophisticated, a ``trivial'' build system is provided. It is trivial in the sense that it provides basically no support: it does not pull any implicit inputs, diff --git a/guix/build-system/meson.scm b/guix/build-system/meson.scm new file mode 100644 index 000000000..d66ec760a --- /dev/null +++ b/guix/build-system/meson.scm @@ -0,0 +1,178 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2017 Peter Mikkelsen +;;; +;;; 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 build-system meson) + #:use-module (guix store) + #:use-module (guix utils) + #:use-module (guix derivations) + #:use-module (guix search-paths) + #:use-module (guix build-system) + #:use-module (guix build-system gnu) + #:use-module (guix build-system glib-or-gtk) + #:use-module (guix packages) + #:use-module (ice-9 match) + #:export (%meson-build-system-modules + meson-build-system)) + +;; Commentary: +;; +;; Standard build procedure for packages using Meson. This is implemented as an +;; extension of `gnu-build-system', with the option to turn on the glib/gtk +;; phases from `glib-or-gtk-build-system'. +;; +;; Code: + +(define %meson-build-system-modules + ;; Build-side modules imported by default. + `((guix build meson-build-system) + (guix build rpath) + ;; The modules from glib-or-gtk contains the modules from gnu-build-system, + ;; so there is no need to import that too. + ,@%glib-or-gtk-build-system-modules)) + +(define (default-ninja) + "Return the default ninja package." + ;; Lazily resolve the binding to avoid a circular dependency. + (let ((module (resolve-interface '(gnu packages ninja)))) + (module-ref module 'ninja))) + +(define (default-meson) + "Return the default meson package." + ;; Lazily resolve the binding to avoid a circular dependency. + (let ((module (resolve-interface '(gnu packages build-tools)))) + (module-ref module 'meson-for-build))) + +(define (default-patchelf) + "Return the default patchelf package." + ;; Lazily resolve the binding to avoid a circular dependency. + (let ((module (resolve-interface '(gnu packages elf)))) + (module-ref module 'patchelf))) + +(define* (lower name + #:key source inputs native-inputs outputs system target + (meson (default-meson)) + (ninja (default-ninja)) + (glib-or-gtk #f) + #:allow-other-keys + #:rest arguments) + "Return a bag for NAME." + (define private-keywords + `(#:source #:meson #:ninja #:inputs #:native-inputs #:outputs #:target)) + + (and (not target) ;; TODO: add support for cross-compilation. + (bag + (name name) + (system system) + (build-inputs `(("meson" ,meson) + ("ninja" ,ninja) + ;; Add patchelf for (guix build rpath) to work. + ("patchelf" ,(default-patchelf)) + ,@native-inputs)) + (host-inputs `(,@(if source + `(("source" ,source)) + '()) + ,@inputs + ;; Keep the standard inputs of 'gnu-build-system'. + ,@(standard-packages))) + (outputs outputs) + (build meson-build) + (arguments (strip-keyword-arguments private-keywords arguments))))) + +(define* (meson-build store name inputs + #:key (guile #f) + (outputs '("out")) + (configure-flags ''()) + (search-paths '()) + (build-type "plain") + (tests? #t) + (test-target "test") + (glib-or-gtk? #f) + (parallel-build? #t) + (parallel-tests? #f) + (validate-runpath? #t) + (patch-shebangs? #t) + (strip-binaries? #t) + (strip-flags ''("--strip-debug")) + (strip-directories ''("lib" "lib64" "libexec" + "bin" "sbin")) + (elf-directories ''("lib" "lib64" "libexec" + "bin" "sbin")) + (phases '(@ (guix build meson-build-system) + %standard-phases)) + (system (%current-system)) + (imported-modules %meson-build-system-modules) + (modules '((guix build meson-build-system) + (guix build utils)))) + "Build SOURCE using MESON, and with INPUTS, assuming that SOURCE +has a 'meson.build' file." + (define builder + `(let ((build-phases (if ,glib-or-gtk? + ,phases + (modify-phases ,phases + (delete 'glib-or-gtk-compile-schemas) + (delete 'glib-or-gtk-wrap))))) + (use-modules ,@modules) + (meson-build #:source ,(match (assoc-ref inputs "source") + (((? derivation? source)) + (derivation->output-path source)) + ((source) + source) + (source + source)) + #:system ,system + #:outputs %outputs + #:inputs %build-inputs + #:search-paths ',(map search-path-specification->sexp + search-paths) + #:phases build-phases + #:configure-flags ,configure-flags + #:build-type ,build-type + #:tests? ,tests? + #:test-target ,test-target + #:parallel-build? ,parallel-build? + #:parallel-tests? ,parallel-tests? + #:validate-runpath? ,validate-runpath? + #:patch-shebangs? ,patch-shebangs? + #:strip-binaries? ,strip-binaries? + #:strip-flags ,strip-flags + #:strip-directories ,strip-directories + #:elf-directories ,elf-directories))) + + (define guile-for-build + (match guile + ((? package?) + (package-derivation store guile system #:graft? #f)) + (#f ; the default + (let* ((distro (resolve-interface '(gnu packages commencement))) + (guile (module-ref distro 'guile-final))) + (package-derivation store guile system #:graft? #f))))) + + (build-expression->derivation store name builder + #:system system + #:inputs inputs + #:modules imported-modules + #:outputs outputs + #:guile-for-build guile-for-build)) + +(define meson-build-system + (build-system + (name 'meson) + (description "The standard Meson build system") + (lower lower))) + +;;; meson.scm ends here diff --git a/guix/build/meson-build-system.scm b/guix/build/meson-build-system.scm new file mode 100644 index 000000000..2b92240c5 --- /dev/null +++ b/guix/build/meson-build-system.scm @@ -0,0 +1,150 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2017 Peter Mikkelsen +;;; +;;; 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 build meson-build-system) + #:use-module ((guix build gnu-build-system) #:prefix gnu:) + #:use-module ((guix build glib-or-gtk-build-system) #:prefix glib-or-gtk:) + #:use-module (guix build utils) + #:use-module (guix build rpath) + #:use-module (guix build gremlin) + #:use-module (guix elf) + #:use-module (ice-9 match) + #:use-module (rnrs io ports) + #:use-module (srfi srfi-1) + #:export (%standard-phases + meson-build)) + +;; Commentary: +;; +;; Builder-side code of the standard meson build procedure. +;; +;; Code: + +(define* (configure #:key outputs configure-flags build-type + #:allow-other-keys) + "Configure the given package." + (let* ((out (assoc-ref outputs "out")) + (source-dir (getcwd)) + (build-dir "../build") + (prefix (assoc-ref outputs "out")) + (args `(,(string-append "--prefix=" prefix) + ,(string-append "--buildtype=" build-type) + ,@configure-flags + ,source-dir))) + (mkdir build-dir) + (chdir build-dir) + (zero? (apply system* "meson" args)))) + +(define* (build #:key parallel-build? + #:allow-other-keys) + "Build a given meson package." + (zero? (apply system* "ninja" + (if parallel-build? + `("-j" ,(number->string (parallel-job-count))) + '("-j" "1"))))) + +(define* (check #:key test-target parallel-tests? tests? + #:allow-other-keys) + (setenv "MESON_TESTTHREADS" + (if parallel-tests? + (number->string (parallel-job-count)) + "1")) + (if tests? + (zero? (system* "ninja" test-target)) + (begin + (format #t "test suite not run~%") + #t))) + +(define* (install #:rest args) + (zero? (system* "ninja" "install"))) + +(define* (fix-runpath #:key (elf-directories '("lib" "lib64" "libexec" + "bin" "sbin")) + outputs #:allow-other-keys) + "Try to make sure all ELF files in ELF-DIRECTORIES are able to find their +local dependencies in their RUNPATH, by searching for the needed libraries in +the directories of the package, and adding them to the RUNPATH if needed. +Also shrink the RUNPATH to what is needed, +since a lot of directories are left over from the build phase of meson, +for example libraries only needed for the tests." + + ;; Find the directories (if any) that contains DEP-NAME. The directories + ;; searched are the ones that ELF-FILES are in. + (define (find-deps dep-name elf-files) + (map dirname (filter (lambda (file) + (string=? dep-name (basename file))) + elf-files))) + + ;; Return a list of libraries that FILE needs. + (define (file-needed file) + (let* ((elf (call-with-input-file file + (compose parse-elf get-bytevector-all))) + (dyninfo (elf-dynamic-info elf))) + (if dyninfo + (elf-dynamic-info-needed dyninfo) + '()))) + + + ;; If FILE needs any libs that are part of ELF-FILES, the RUNPATH + ;; is modified accordingly. + (define (handle-file file elf-files) + (let* ((dep-dirs (concatenate (map (lambda (dep-name) + (find-deps dep-name elf-files)) + (file-needed file))))) + (unless (null? dep-dirs) + (augment-rpath file (string-join dep-dirs ":"))))) + + (define handle-output + (match-lambda + ((output . directory) + (let* ((elf-dirnames (map (lambda (subdir) + (string-append directory "/" subdir)) + elf-directories)) + (existing-elf-dirs (filter (lambda (dir) + (and (file-exists? dir) + (file-is-directory? dir))) + elf-dirnames)) + (elf-pred (lambda (name stat) + (elf-file? name))) + (elf-list (concatenate (map (lambda (dir) + (find-files dir elf-pred)) + existing-elf-dirs)))) + (for-each (lambda (elf-file) + (system* "patchelf" "--shrink-rpath" elf-file) + (handle-file elf-file elf-list)) + elf-list))))) + (for-each handle-output outputs) + #t) + +(define %standard-phases + ;; The standard-phases of glib-or-gtk contains a superset of the phases + ;; from the gnu-build-system. If the glib-or-gtk? key is #f (the default) + ;; then the extra phases will be removed again in (guix build-system meson). + (modify-phases glib-or-gtk:%standard-phases + (replace 'configure configure) + (replace 'build build) + (replace 'check check) + (replace 'install install) + (add-after 'strip 'fix-runpath fix-runpath))) + +(define* (meson-build #:key inputs phases + #:allow-other-keys #:rest args) + "Build the given package, applying all of PHASES in order." + (apply gnu:gnu-build #:inputs inputs #:phases phases args)) + +;;; meson-build-system.scm ends here -- cgit v1.3 From 798648515b77507c242752457b4dc17c155bad6e Mon Sep 17 00:00:00 2001 From: 宋文武 Date: Sat, 16 Sep 2017 14:10:18 -0600 Subject: download: Don't report the progress too fast. * guix/utils.scm (): New record type. (call-with-progress-reporter): New procedure. * guix/build/download.scm (dump-port*, rate-limited, progress-reporter/file): New procedures. (ftp-fetch, http-fetch): Use 'dump-port*'. (progress-proc): Remove procedure. * guix/scripts/substitute.scm (progress-report-port): Rewrite in terms of . (process-substitution): Adjust accordingly. --- guix/build/download.scm | 174 ++++++++++++++++++++++++++------------------ guix/scripts/substitute.scm | 54 +++++++------- guix/utils.scm | 32 +++++++- 3 files changed, 161 insertions(+), 99 deletions(-) (limited to 'guix/build') diff --git a/guix/build/download.scm b/guix/build/download.scm index bcf22663b..9490f4805 100644 --- a/guix/build/download.scm +++ b/guix/build/download.scm @@ -27,6 +27,7 @@ #:use-module (guix base64) #:use-module (guix ftp-client) #:use-module (guix build utils) + #:use-module (guix utils) #:use-module (rnrs io ports) #:use-module (rnrs bytevectors) #:use-module (srfi srfi-1) @@ -45,7 +46,7 @@ url-fetch byte-count->string current-terminal-columns - progress-proc + progress-reporter/file uri-abbreviation nar-uri-abbreviation store-path-abbreviation)) @@ -148,65 +149,97 @@ Otherwise return STORE-PATH." (define time-monotonic time-tai)) (else #t)) -(define* (progress-proc file size - #:optional (log-port (current-output-port)) - #:key (abbreviation basename)) - "Return a procedure to show the progress of FILE's download, which is SIZE -bytes long. The returned procedure is suitable for use as an argument to -`dump-port'. The progress report is written to LOG-PORT, with ABBREVIATION -used to shorten FILE for display." - ;; XXX: Because of this procedure is often not - ;; called as frequently as we'd like too; this is especially bad with Nginx - ;; on hydra.gnu.org, which returns whole nars as a single chunk. - (let ((start-time #f)) - (let-syntax ((with-elapsed-time - (syntax-rules () - ((_ elapsed body ...) - (let* ((now (current-time time-monotonic)) - (elapsed (and start-time - (duration->seconds - (time-difference now - start-time))))) - (unless start-time - (set! start-time now)) - body ...))))) + +;; TODO: replace '(@ (guix build utils) dump-port))'. +(define* (dump-port* in out + #:key (buffer-size 16384) + (reporter (make-progress-reporter noop noop noop))) + "Read as much data as possible from IN and write it to OUT, using chunks of +BUFFER-SIZE bytes. After each successful transfer of BUFFER-SIZE bytes or +less, report the total number of bytes transferred to the REPORTER, which +should be a object." + (define buffer + (make-bytevector buffer-size)) + + (call-with-progress-reporter reporter + (lambda (report) + (let loop ((total 0) + (bytes (get-bytevector-n! in buffer 0 buffer-size))) + (or (eof-object? bytes) + (let ((total (+ total bytes))) + (put-bytevector out buffer 0 bytes) + (report total) + (loop total (get-bytevector-n! in buffer 0 buffer-size)))))))) + +(define (rate-limited proc interval) + "Return a procedure that will forward the invocation to PROC when the time +elapsed since the previous forwarded invocation is greater or equal to +INTERVAL (a time-duration object), otherwise does nothing and returns #f." + (let ((previous-at #f)) + (lambda args + (let* ((now (current-time time-monotonic)) + (forward-invocation (lambda () + (set! previous-at now) + (apply proc args)))) + (if previous-at + (let ((elapsed (time-difference now previous-at))) + (if (time>=? elapsed interval) + (forward-invocation) + #f)) + (forward-invocation)))))) + +(define* (progress-reporter/file file size + #:optional (log-port (current-output-port)) + #:key (abbreviation basename)) + "Return a object to show the progress of FILE's download, +which is SIZE bytes long. The progress report is written to LOG-PORT, with +ABBREVIATION used to shorten FILE for display." + (let ((start-time (current-time time-monotonic)) + (transferred 0)) + (define (render) + "Write the progress report to LOG-PORT." + (define elapsed + (duration->seconds + (time-difference (current-time time-monotonic) start-time))) (if (number? size) - (lambda (transferred cont) - (with-elapsed-time elapsed - (let* ((% (* 100.0 (/ transferred size))) - (throughput (if elapsed - (/ transferred elapsed) - 0)) - (left (format #f " ~a ~a" - (abbreviation file) - (byte-count->string size))) - (right (format #f "~a/s ~a ~a~6,1f%" - (byte-count->string throughput) - (seconds->string elapsed) - (progress-bar %) %))) - (display "\r\x1b[K" log-port) - (display (string-pad-middle left right - (current-terminal-columns)) - log-port) - (flush-output-port log-port) - (cont)))) - (lambda (transferred cont) - (with-elapsed-time elapsed - (let* ((throughput (if elapsed - (/ transferred elapsed) - 0)) - (left (format #f " ~a" - (abbreviation file))) - (right (format #f "~a/s ~a | ~a transferred" - (byte-count->string throughput) - (seconds->string elapsed) - (byte-count->string transferred)))) - (display "\r\x1b[K" log-port) - (display (string-pad-middle left right - (current-terminal-columns)) - log-port) - (flush-output-port log-port) - (cont)))))))) + (let* ((% (* 100.0 (/ transferred size))) + (throughput (/ transferred elapsed)) + (left (format #f " ~a ~a" + (abbreviation file) + (byte-count->string size))) + (right (format #f "~a/s ~a ~a~6,1f%" + (byte-count->string throughput) + (seconds->string elapsed) + (progress-bar %) %))) + (display "\r\x1b[K" log-port) + (display (string-pad-middle left right + (current-terminal-columns)) + log-port) + (flush-output-port log-port)) + (let* ((throughput (/ transferred elapsed)) + (left (format #f " ~a" + (abbreviation file))) + (right (format #f "~a/s ~a | ~a transferred" + (byte-count->string throughput) + (seconds->string elapsed) + (byte-count->string transferred)))) + (display "\r\x1b[K" log-port) + (display (string-pad-middle left right + (current-terminal-columns)) + log-port) + (flush-output-port log-port)))) + + (progress-reporter + (start render) + ;; Report the progress every 300ms or longer. + (report + (let ((rate-limited-render + (rate-limited render (make-time time-monotonic 300000000 0)))) + (lambda (value) + (set! transferred value) + (rate-limited-render)))) + ;; Don't miss the last report. + (stop render)))) (define* (uri-abbreviation uri #:optional (max-length 42)) "If URI's string representation is larger than MAX-LENGTH, return an @@ -264,9 +297,10 @@ out if the connection could not be established in less than TIMEOUT seconds." (dirname (uri-path uri))))) (call-with-output-file file (lambda (out) - (dump-port in out - #:buffer-size %http-receive-buffer-size - #:progress (progress-proc (uri-abbreviation uri) size)))) + (dump-port* in out + #:buffer-size %http-receive-buffer-size + #:reporter (progress-reporter/file + (uri-abbreviation uri) size)))) (ftp-close conn)) (newline) @@ -755,10 +789,10 @@ certificates; otherwise simply ignore them." (lambda (p) (if (port? bv-or-port) (begin - (dump-port bv-or-port p - #:buffer-size %http-receive-buffer-size - #:progress (progress-proc (uri-abbreviation uri) - size)) + (dump-port* bv-or-port p + #:buffer-size %http-receive-buffer-size + #:reporter (progress-reporter/file + (uri-abbreviation uri) size)) (newline)) (put-bytevector p bv-or-port)))) file)) @@ -863,8 +897,8 @@ otherwise simply ignore them." hashes)) content-addressed-mirrors)) - ;; Make this unbuffered so 'progress-proc' works as expected. _IOLBF means - ;; '\n', not '\r', so it's not appropriate here. + ;; Make this unbuffered so 'progress-report/file' works as expected. _IOLBF + ;; means '\n', not '\r', so it's not appropriate here. (setvbuf (current-output-port) _IONBF) (setvbuf (current-error-port) _IOLBF) @@ -879,8 +913,4 @@ otherwise simply ignore them." file url) #f)))) -;;; Local Variables: -;;; eval: (put 'with-elapsed-time 'scheme-indent-function 1) -;;; End: - ;;; download.scm ends here diff --git a/guix/scripts/substitute.scm b/guix/scripts/substitute.scm index 61eff1886..3dcf42d0d 100755 --- a/guix/scripts/substitute.scm +++ b/guix/scripts/substitute.scm @@ -34,7 +34,8 @@ #:use-module ((guix build utils) #:select (mkdir-p dump-port)) #:use-module ((guix build download) #:select (current-terminal-columns - progress-proc uri-abbreviation nar-uri-abbreviation + progress-reporter/file + uri-abbreviation nar-uri-abbreviation (open-connection-for-uri . guix:open-connection-for-uri) close-connection @@ -814,23 +815,25 @@ was found." (= (string-length file) 32))))) (narinfo-cache-directories directory))) -(define (progress-report-port report-progress port) - "Return a port that calls REPORT-PROGRESS every time something is read from -PORT. REPORT-PROGRESS is a two-argument procedure such as that returned by -`progress-proc'." - (define total 0) - (define (read! bv start count) - (let ((n (match (get-bytevector-n! port bv start count) - ((? eof-object?) 0) - (x x)))) - (set! total (+ total n)) - (report-progress total (const n)) - ;; XXX: We're not in control, so we always return anyway. - n)) - - (make-custom-binary-input-port "progress-port-proc" - read! #f #f - (cut close-connection port))) +(define (progress-report-port reporter port) + "Return a port that continuously reports the bytes read from PORT using +REPORTER, which should be a object." + (match reporter + (($ start report stop) + (let* ((total 0) + (read! (lambda (bv start count) + (let ((n (match (get-bytevector-n! port bv start count) + ((? eof-object?) 0) + (x x)))) + (set! total (+ total n)) + (report total) + n)))) + (start) + (make-custom-binary-input-port "progress-port-proc" + read! #f #f + (lambda () + (close-connection port) + (stop))))))) (define-syntax with-networking (syntax-rules () @@ -947,12 +950,11 @@ DESTINATION as a nar file. Verify the substitute against ACL." (dl-size (or download-size (and (equal? comp "none") (narinfo-size narinfo)))) - (progress (progress-proc (uri->string uri) - dl-size - (current-error-port) - #:abbreviation - nar-uri-abbreviation))) - (progress-report-port progress raw))) + (reporter (progress-reporter/file + (uri->string uri) dl-size + (current-error-port) + #:abbreviation nar-uri-abbreviation))) + (progress-report-port reporter raw))) ((input pids) (decompressed-port (and=> (narinfo-compression narinfo) string->symbol) @@ -961,8 +963,8 @@ DESTINATION as a nar file. Verify the substitute against ACL." (restore-file input destination) (close-port input) - ;; Skip a line after what 'progress-proc' printed, and another one to - ;; visually separate substitutions. + ;; Skip a line after what 'progress-reporter/file' printed, and another + ;; one to visually separate substitutions. (display "\n\n" (current-error-port)) (every (compose zero? cdr waitpid) pids)))) diff --git a/guix/utils.scm b/guix/utils.scm index 8fbbdc356..de4aa6531 100644 --- a/guix/utils.scm +++ b/guix/utils.scm @@ -33,6 +33,7 @@ #:autoload (rnrs io ports) (make-custom-binary-input-port) #:use-module ((rnrs bytevectors) #:select (bytevector-u8-set!)) #:use-module (guix memoization) + #:use-module (guix records) #:use-module ((guix build utils) #:select (dump-port mkdir-p)) #:use-module ((guix build syscalls) #:select (mkdtemp! fdatasync)) #:use-module (ice-9 format) @@ -94,7 +95,13 @@ call-with-decompressed-port compressed-output-port call-with-compressed-output-port - canonical-newline-port)) + canonical-newline-port + + + progress-reporter + make-progress-reporter + progress-reporter? + call-with-progress-reporter)) ;;; @@ -747,3 +754,26 @@ a location object." `((line . ,(and=> (location-line loc) 1-)) (column . ,(location-column loc)) (filename . ,(location-file loc)))) + + +;;; +;;; Progress reporter. +;;; + +(define-record-type* + progress-reporter make-progress-reporter progress-reporter? + (start progress-reporter-start) ; thunk + (report progress-reporter-report) ; procedure + (stop progress-reporter-stop)) ; thunk + +(define (call-with-progress-reporter reporter proc) + "Start REPORTER for progress reporting, and call @code{(@var{proc} report)} +with the resulting report procedure. When @var{proc} returns, the REPORTER is +stopped." + (match reporter + (($ start report stop) + (dynamic-wind start (lambda () (proc report)) stop)))) + +;;; Local Variables: +;;; eval: (put 'call-with-progress-reporter 'scheme-indent-function 1) +;;; End: -- cgit v1.3