* bug#28709: [PATCH 1/4] download: Remove old-Guile leftovers.
2017-10-17 8:48 ` bug#28709: [PATCH 0/4] Content-addressed mirrors for VCS checkouts Ludovic Courtès
@ 2017-10-17 8:48 ` Ludovic Courtès
2017-10-17 8:48 ` bug#28709: [PATCH 2/4] download: Make 'http-fetch' public Ludovic Courtès
` (3 subsequent siblings)
4 siblings, 0 replies; 8+ messages in thread
From: Ludovic Courtès @ 2017-10-17 8:48 UTC (permalink / raw)
To: 28709
This is a followup to 36626c556ed75219bce196ac93d148f6b9af984c.
* guix/build/download.scm (http-fetch): Rename 'port-or-bv' to 'port'.
Assume (port? port) is always true, and remove other branch.
---
guix/build/download.scm | 15 ++++++---------
1 file changed, 6 insertions(+), 9 deletions(-)
diff --git a/guix/build/download.scm b/guix/build/download.scm
index 9490f4805..e227ae598 100644
--- a/guix/build/download.scm
+++ b/guix/build/download.scm
@@ -774,7 +774,7 @@ certificates; otherwise simply ignore them."
#:timeout timeout
#:verify-certificate?
verify-certificate?))
- ((resp bv-or-port)
+ ((resp port)
(http-get uri #:port connection #:decode-body? #f
#:streaming? #t
#:headers headers))
@@ -787,14 +787,11 @@ certificates; otherwise simply ignore them."
(begin
(call-with-output-file file
(lambda (p)
- (if (port? bv-or-port)
- (begin
- (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))))
+ (dump-port* port p
+ #:buffer-size %http-receive-buffer-size
+ #:reporter (progress-reporter/file
+ (uri-abbreviation uri) size))
+ (newline)))
file))
((301 ; moved permanently
302 ; found (redirection)
--
2.14.2
^ permalink raw reply related [flat|nested] 8+ messages in thread* bug#28709: [PATCH 2/4] download: Make 'http-fetch' public.
2017-10-17 8:48 ` bug#28709: [PATCH 0/4] Content-addressed mirrors for VCS checkouts Ludovic Courtès
2017-10-17 8:48 ` bug#28709: [PATCH 1/4] download: Remove old-Guile leftovers Ludovic Courtès
@ 2017-10-17 8:48 ` Ludovic Courtès
2017-10-17 8:48 ` bug#28709: [PATCH 3/4] Add (guix progress) Ludovic Courtès
` (2 subsequent siblings)
4 siblings, 0 replies; 8+ messages in thread
From: Ludovic Courtès @ 2017-10-17 8:48 UTC (permalink / raw)
To: 28709
* guix/build/download.scm (http-fetch): Remove 'file' parameter. Change
to return an input port and the content-length. Make public.
(url-fetch): Adjust accordingly.
---
guix/build/download.scm | 44 ++++++++++++++++++++++----------------------
1 file changed, 22 insertions(+), 22 deletions(-)
diff --git a/guix/build/download.scm b/guix/build/download.scm
index e227ae598..3b89f9412 100644
--- a/guix/build/download.scm
+++ b/guix/build/download.scm
@@ -39,6 +39,7 @@
#:use-module (ice-9 format)
#:export (open-socket-for-uri
open-connection-for-uri
+ http-fetch
%x509-certificate-directory
close-connection
resolve-uri-reference
@@ -745,11 +746,11 @@ Return the resulting target URI."
#:query (uri-query ref)
#:fragment (uri-fragment ref)))))
-(define* (http-fetch uri file #:key timeout (verify-certificate? #t))
- "Fetch data from URI and write it to FILE; when TIMEOUT is true, bail out if
-the connection could not be established in less than TIMEOUT seconds. Return
-FILE on success. When VERIFY-CERTIFICATE? is true, verify HTTPS
-certificates; otherwise simply ignore them."
+(define* (http-fetch uri #:key timeout (verify-certificate? #t))
+ "Return an input port containing the data at URI, and the expected number of
+bytes available or #f. When TIMEOUT is true, bail out if the connection could
+not be established in less than TIMEOUT seconds. When VERIFY-CERTIFICATE? is
+true, verify HTTPS certificates; otherwise simply ignore them."
(define headers
`(;; Some web sites, such as http://dist.schmorp.de, would block you if
@@ -779,20 +780,10 @@ certificates; otherwise simply ignore them."
#:streaming? #t
#:headers headers))
((code)
- (response-code resp))
- ((size)
- (response-content-length resp)))
+ (response-code resp)))
(case code
((200) ; OK
- (begin
- (call-with-output-file file
- (lambda (p)
- (dump-port* port p
- #:buffer-size %http-receive-buffer-size
- #:reporter (progress-reporter/file
- (uri-abbreviation uri) size))
- (newline)))
- file))
+ (values port (response-content-length resp)))
((301 ; moved permanently
302 ; found (redirection)
303 ; see other
@@ -802,7 +793,7 @@ certificates; otherwise simply ignore them."
(format #t "following redirection to `~a'...~%"
(uri->string uri))
(close connection)
- (http-fetch uri file
+ (http-fetch uri
#:timeout timeout
#:verify-certificate? verify-certificate?)))
(else
@@ -873,10 +864,19 @@ otherwise simply ignore them."
file (uri->string uri))
(case (uri-scheme uri)
((http https)
- (false-if-exception* (http-fetch uri file
- #:verify-certificate?
- verify-certificate?
- #:timeout timeout)))
+ (false-if-exception*
+ (let-values (((port size)
+ (http-fetch uri
+ #:verify-certificate? verify-certificate?
+ #:timeout timeout)))
+ (call-with-output-file file
+ (lambda (output)
+ (dump-port* port output
+ #:buffer-size %http-receive-buffer-size
+ #:reporter (progress-reporter/file
+ (uri-abbreviation uri) size))
+ (newline)))
+ #t)))
((ftp)
(false-if-exception* (ftp-fetch uri file
#:timeout timeout)))
--
2.14.2
^ permalink raw reply related [flat|nested] 8+ messages in thread* bug#28709: [PATCH 3/4] Add (guix progress).
2017-10-17 8:48 ` bug#28709: [PATCH 0/4] Content-addressed mirrors for VCS checkouts Ludovic Courtès
2017-10-17 8:48 ` bug#28709: [PATCH 1/4] download: Remove old-Guile leftovers Ludovic Courtès
2017-10-17 8:48 ` bug#28709: [PATCH 2/4] download: Make 'http-fetch' public Ludovic Courtès
@ 2017-10-17 8:48 ` Ludovic Courtès
2017-10-17 8:48 ` bug#28709: [PATCH 4/4] download: Download a nar when a VCS checkout fails Ludovic Courtès
2017-10-18 17:58 ` bug#28709: [PATCH 0/4] Content-addressed mirrors for VCS checkouts Christopher Baines
4 siblings, 0 replies; 8+ messages in thread
From: Ludovic Courtès @ 2017-10-17 8:48 UTC (permalink / raw)
To: 28709
Among other things, this removes (guix utils), (guix ui), (guix config),
etc. from the closure of (guix build download), as was the case since
798648515b77507c242752457b4dc17c155bad6e.
* guix/utils.scm (<progress-reporter>, call-with-progress-reporter):
Move to...
* guix/progress.scm: ... here. New file.
* Makefile.am (MODULES): Add it.
* guix/build/download.scm (current-terminal-columns)
(nearest-exact-integer, duration->seconds, seconds->string)
(byte-count->string, progress-bar, string-pad-middle)
(rate-limited, progress-reporter/file, dump-port*)
(time-monotonic): Move to progress.scm.
* guix/scripts/download.scm: Adjust accordingly.
* guix/scripts/substitute.scm: Likewise.
---
Makefile.am | 1 +
guix/build/download.scm | 167 +-------------------------------
guix/progress.scm | 228 ++++++++++++++++++++++++++++++++++++++++++++
guix/scripts/download.scm | 4 +-
guix/scripts/substitute.scm | 5 +-
guix/utils.scm | 28 +-----
6 files changed, 236 insertions(+), 197 deletions(-)
create mode 100644 guix/progress.scm
diff --git a/Makefile.am b/Makefile.am
index efbd07a35..071553b99 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -47,6 +47,7 @@ MODULES = \
guix/hash.scm \
guix/pk-crypto.scm \
guix/pki.scm \
+ guix/progress.scm \
guix/combinators.scm \
guix/memoization.scm \
guix/utils.scm \
diff --git a/guix/build/download.scm b/guix/build/download.scm
index 3b89f9412..61c9c6d3f 100644
--- a/guix/build/download.scm
+++ b/guix/build/download.scm
@@ -1,7 +1,6 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2015 Mark H Weaver <mhw@netris.org>
-;;; Copyright © 2015 Steve Sprang <scs@stevesprang.com>
;;; Copyright © 2017 Tobias Geerinckx-Rice <me@tobias.gr>
;;;
;;; This file is part of GNU Guix.
@@ -27,7 +26,7 @@
#:use-module (guix base64)
#:use-module (guix ftp-client)
#:use-module (guix build utils)
- #:use-module (guix utils)
+ #:use-module (guix progress)
#:use-module (rnrs io ports)
#:use-module (rnrs bytevectors)
#:use-module (srfi srfi-1)
@@ -46,8 +45,6 @@
maybe-expand-mirrors
url-fetch
byte-count->string
- current-terminal-columns
- progress-reporter/file
uri-abbreviation
nar-uri-abbreviation
store-path-abbreviation))
@@ -62,69 +59,6 @@
;; Size of the HTTP receive buffer.
65536)
-(define current-terminal-columns
- ;; Number of columns of the terminal.
- (make-parameter 80))
-
-(define (nearest-exact-integer x)
- "Given a real number X, return the nearest exact integer, with ties going to
-the nearest exact even integer."
- (inexact->exact (round x)))
-
-(define (duration->seconds duration)
- "Return the number of seconds represented by DURATION, a 'time-duration'
-object, as an inexact number."
- (+ (time-second duration)
- (/ (time-nanosecond duration) 1e9)))
-
-(define (seconds->string duration)
- "Given DURATION in seconds, return a string representing it in 'mm:ss' or
-'hh:mm:ss' format, as needed."
- (if (not (number? duration))
- "00:00"
- (let* ((total-seconds (nearest-exact-integer duration))
- (extra-seconds (modulo total-seconds 3600))
- (num-hours (quotient total-seconds 3600))
- (hours (and (positive? num-hours) num-hours))
- (mins (quotient extra-seconds 60))
- (secs (modulo extra-seconds 60)))
- (format #f "~@[~2,'0d:~]~2,'0d:~2,'0d" hours mins secs))))
-
-(define (byte-count->string size)
- "Given SIZE in bytes, return a string representing it in a human-readable
-way."
- (let ((KiB 1024.)
- (MiB (expt 1024. 2))
- (GiB (expt 1024. 3))
- (TiB (expt 1024. 4)))
- (cond
- ((< size KiB) (format #f "~dB" (nearest-exact-integer size)))
- ((< size MiB) (format #f "~dKiB" (nearest-exact-integer (/ size KiB))))
- ((< size GiB) (format #f "~,1fMiB" (/ size MiB)))
- ((< size TiB) (format #f "~,2fGiB" (/ size GiB)))
- (else (format #f "~,3fTiB" (/ size TiB))))))
-
-(define* (progress-bar % #:optional (bar-width 20))
- "Return % as a string representing an ASCII-art progress bar. The total
-width of the bar is BAR-WIDTH."
- (let* ((fraction (/ % 100))
- (filled (inexact->exact (floor (* fraction bar-width))))
- (empty (- bar-width filled)))
- (format #f "[~a~a]"
- (make-string filled #\#)
- (make-string empty #\space))))
-
-(define (string-pad-middle left right len)
- "Combine LEFT and RIGHT with enough padding in the middle so that the
-resulting string has length at least LEN (it may overflow). If the string
-does not overflow, the last char in RIGHT will be flush with the LEN
-column."
- (let* ((total-used (+ (string-length left)
- (string-length right)))
- (num-spaces (max 1 (- len total-used)))
- (padding (make-string num-spaces #\space)))
- (string-append left padding right)))
-
(define* (ellipsis #:optional (port (current-output-port)))
"Make a rough guess at whether Unicode's HORIZONTAL ELLIPSIS can be written
in PORT's encoding, and return either that or ASCII dots."
@@ -143,105 +77,6 @@ Otherwise return STORE-PATH."
(string-drop base 32)))
store-path))
-(cond-expand
- (guile-2.2
- ;; Guile 2.2.2 has a bug whereby 'time-monotonic' objects have seconds and
- ;; nanoseconds swapped (fixed in Guile commit 886ac3e). Work around it.
- (define time-monotonic time-tai))
- (else #t))
-
-
-;; 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 <progress-reporter> 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 <progress-reporter> 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)
- (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
abbreviation of URI showing the scheme, host, and basename of the file."
diff --git a/guix/progress.scm b/guix/progress.scm
new file mode 100644
index 000000000..beca2c22a
--- /dev/null
+++ b/guix/progress.scm
@@ -0,0 +1,228 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2017 Sou Bunnbu <iyzsong@gmail.com>
+;;; Copyright © 2015 Steve Sprang <scs@stevesprang.com>
+;;;
+;;; 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 <http://www.gnu.org/licenses/>.
+
+(define-module (guix progress)
+ #:use-module (guix records)
+ #:use-module (srfi srfi-19)
+ #:use-module (rnrs io ports)
+ #:use-module (rnrs bytevectors)
+ #:use-module (ice-9 format)
+ #:use-module (ice-9 match)
+ #:export (<progress-reporter>
+ progress-reporter
+ make-progress-reporter
+ progress-reporter?
+ call-with-progress-reporter
+
+ progress-reporter/silent
+ progress-reporter/file
+
+ byte-count->string
+ current-terminal-columns
+
+ dump-port*))
+
+;;; Commentary:
+;;;
+;;; Helper to write progress report code for downloads, etc.
+;;;
+;;; Code:
+
+(define-record-type* <progress-reporter>
+ 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
+ (($ <progress-reporter> start report stop)
+ (dynamic-wind start (lambda () (proc report)) stop))))
+
+(define progress-reporter/silent
+ (make-progress-reporter noop noop noop))
+
+\f
+;;;
+;;; File download progress report.
+;;;
+
+(cond-expand
+ (guile-2.2
+ ;; Guile 2.2.2 has a bug whereby 'time-monotonic' objects have seconds and
+ ;; nanoseconds swapped (fixed in Guile commit 886ac3e). Work around it.
+ (define time-monotonic time-tai))
+ (else #t))
+
+(define (nearest-exact-integer x)
+ "Given a real number X, return the nearest exact integer, with ties going to
+the nearest exact even integer."
+ (inexact->exact (round x)))
+
+(define (duration->seconds duration)
+ "Return the number of seconds represented by DURATION, a 'time-duration'
+object, as an inexact number."
+ (+ (time-second duration)
+ (/ (time-nanosecond duration) 1e9)))
+
+(define (seconds->string duration)
+ "Given DURATION in seconds, return a string representing it in 'mm:ss' or
+'hh:mm:ss' format, as needed."
+ (if (not (number? duration))
+ "00:00"
+ (let* ((total-seconds (nearest-exact-integer duration))
+ (extra-seconds (modulo total-seconds 3600))
+ (num-hours (quotient total-seconds 3600))
+ (hours (and (positive? num-hours) num-hours))
+ (mins (quotient extra-seconds 60))
+ (secs (modulo extra-seconds 60)))
+ (format #f "~@[~2,'0d:~]~2,'0d:~2,'0d" hours mins secs))))
+
+(define (byte-count->string size)
+ "Given SIZE in bytes, return a string representing it in a human-readable
+way."
+ (let ((KiB 1024.)
+ (MiB (expt 1024. 2))
+ (GiB (expt 1024. 3))
+ (TiB (expt 1024. 4)))
+ (cond
+ ((< size KiB) (format #f "~dB" (nearest-exact-integer size)))
+ ((< size MiB) (format #f "~dKiB" (nearest-exact-integer (/ size KiB))))
+ ((< size GiB) (format #f "~,1fMiB" (/ size MiB)))
+ ((< size TiB) (format #f "~,2fGiB" (/ size GiB)))
+ (else (format #f "~,3fTiB" (/ size TiB))))))
+
+(define (string-pad-middle left right len)
+ "Combine LEFT and RIGHT with enough padding in the middle so that the
+resulting string has length at least LEN (it may overflow). If the string
+does not overflow, the last char in RIGHT will be flush with the LEN
+column."
+ (let* ((total-used (+ (string-length left)
+ (string-length right)))
+ (num-spaces (max 1 (- len total-used)))
+ (padding (make-string num-spaces #\space)))
+ (string-append left padding right)))
+
+(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 current-terminal-columns
+ ;; Number of columns of the terminal.
+ (make-parameter 80))
+
+(define* (progress-bar % #:optional (bar-width 20))
+ "Return % as a string representing an ASCII-art progress bar. The total
+width of the bar is BAR-WIDTH."
+ (let* ((fraction (/ % 100))
+ (filled (inexact->exact (floor (* fraction bar-width))))
+ (empty (- bar-width filled)))
+ (format #f "[~a~a]"
+ (make-string filled #\#)
+ (make-string empty #\space))))
+
+(define* (progress-reporter/file file size
+ #:optional (log-port (current-output-port))
+ #:key (abbreviation basename))
+ "Return a <progress-reporter> 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)
+ (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)
+ (force-output 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)
+ (force-output 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))))
+
+;; TODO: replace '(@ (guix build utils) dump-port))'.
+(define* (dump-port* in out
+ #:key (buffer-size 16384)
+ (reporter progress-reporter/silent))
+ "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 <progress-reporter> 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))))))))
diff --git a/guix/scripts/download.scm b/guix/scripts/download.scm
index 8225f82bb..1b99bc62c 100644
--- a/guix/scripts/download.scm
+++ b/guix/scripts/download.scm
@@ -25,7 +25,9 @@
#:use-module (guix base32)
#:use-module ((guix download) #:hide (url-fetch))
#:use-module ((guix build download)
- #:select (url-fetch current-terminal-columns))
+ #:select (url-fetch))
+ #:use-module ((guix progress)
+ #:select (current-terminal-columns))
#:use-module ((guix build syscalls)
#:select (terminal-columns))
#:use-module (web uri)
diff --git a/guix/scripts/substitute.scm b/guix/scripts/substitute.scm
index 921a7c679..b9d86e3ff 100755
--- a/guix/scripts/substitute.scm
+++ b/guix/scripts/substitute.scm
@@ -33,13 +33,12 @@
#:use-module (guix pki)
#:use-module ((guix build utils) #:select (mkdir-p dump-port))
#:use-module ((guix build download)
- #:select (current-terminal-columns
- progress-reporter/file
- uri-abbreviation nar-uri-abbreviation
+ #:select (uri-abbreviation nar-uri-abbreviation
(open-connection-for-uri
. guix:open-connection-for-uri)
close-connection
store-path-abbreviation byte-count->string))
+ #:use-module (guix progress)
#:use-module ((guix build syscalls)
#:select (set-thread-name))
#:use-module (ice-9 rdelim)
diff --git a/guix/utils.scm b/guix/utils.scm
index de4aa6531..e1615fcf4 100644
--- a/guix/utils.scm
+++ b/guix/utils.scm
@@ -33,7 +33,6 @@
#: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)
@@ -95,13 +94,7 @@
call-with-decompressed-port
compressed-output-port
call-with-compressed-output-port
- canonical-newline-port
-
- <progress-reporter>
- progress-reporter
- make-progress-reporter
- progress-reporter?
- call-with-progress-reporter))
+ canonical-newline-port))
\f
;;;
@@ -755,25 +748,6 @@ a location object."
(column . ,(location-column loc))
(filename . ,(location-file loc))))
-\f
-;;;
-;;; Progress reporter.
-;;;
-
-(define-record-type* <progress-reporter>
- 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
- (($ <progress-reporter> start report stop)
- (dynamic-wind start (lambda () (proc report)) stop))))
-
;;; Local Variables:
;;; eval: (put 'call-with-progress-reporter 'scheme-indent-function 1)
;;; End:
--
2.14.2
^ permalink raw reply related [flat|nested] 8+ messages in thread* bug#28709: [PATCH 4/4] download: Download a nar when a VCS checkout fails.
2017-10-17 8:48 ` bug#28709: [PATCH 0/4] Content-addressed mirrors for VCS checkouts Ludovic Courtès
` (2 preceding siblings ...)
2017-10-17 8:48 ` bug#28709: [PATCH 3/4] Add (guix progress) Ludovic Courtès
@ 2017-10-17 8:48 ` Ludovic Courtès
2017-10-18 17:58 ` bug#28709: [PATCH 0/4] Content-addressed mirrors for VCS checkouts Christopher Baines
4 siblings, 0 replies; 8+ messages in thread
From: Ludovic Courtès @ 2017-10-17 8:48 UTC (permalink / raw)
To: 28709; +Cc: Ludovic Courtès
From: Ludovic Courtès <ludovic.courtes@inria.fr>
Fixes <https://bugs.gnu.org/28709>.
* guix/build/download-nar.scm: New file.
* Makefile.am (MODULES): Add it.
* guix/cvs-download.scm (cvs-fetch)[zlib, config.scm, modules]: New
variables.
[build]: Use MODULES. Add call to 'download-nar'.
* guix/git-download.scm (git-fetch): Likewise.
* guix/hg-download.scm (hg-fetch): Likewise.
---
Makefile.am | 1 +
guix/build/download-nar.scm | 125 ++++++++++++++++++++++++++++++++++++++++++++
guix/cvs-download.scm | 38 ++++++++++----
guix/git-download.scm | 37 ++++++++++---
guix/hg-download.scm | 36 +++++++++----
5 files changed, 211 insertions(+), 26 deletions(-)
create mode 100644 guix/build/download-nar.scm
diff --git a/Makefile.am b/Makefile.am
index 071553b99..2855b4efd 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -106,6 +106,7 @@ MODULES = \
guix/ui.scm \
guix/build/ant-build-system.scm \
guix/build/download.scm \
+ guix/build/download-nar.scm \
guix/build/cargo-build-system.scm \
guix/build/cmake-build-system.scm \
guix/build/dub-build-system.scm \
diff --git a/guix/build/download-nar.scm b/guix/build/download-nar.scm
new file mode 100644
index 000000000..13f01fb1e
--- /dev/null
+++ b/guix/build/download-nar.scm
@@ -0,0 +1,125 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2017 Ludovic Courtès <ludo@gnu.org>
+;;;
+;;; 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 <http://www.gnu.org/licenses/>.
+
+(define-module (guix build download-nar)
+ #:use-module (guix build download)
+ #:use-module (guix build utils)
+ #:use-module (guix serialization)
+ #:use-module (guix zlib)
+ #:use-module (guix progress)
+ #:use-module (web uri)
+ #:use-module (srfi srfi-11)
+ #:use-module (srfi srfi-26)
+ #:use-module (ice-9 format)
+ #:use-module (ice-9 match)
+ #:export (download-nar))
+
+;;; Commentary:
+;;;
+;;; Download a normalized archive or "nar", similar to what 'guix substitute'
+;;; does. The intent here is to use substitute servers as content-addressed
+;;; mirrors of VCS checkouts. This is mostly useful for users who have
+;;; disabled substitutes.
+;;;
+;;; Code:
+
+(define (urls-for-item item)
+ "Return the fallback nar URL for ITEM--e.g.,
+\"/gnu/store/cabbag3…-foo-1.2-checkout\"."
+ ;; Here we hard-code nar URLs without checking narinfos. That's probably OK
+ ;; though.
+ ;; TODO: Use HTTPS? The downside is the extra dependency.
+ (let ((bases '("http://mirror.hydra.gnu.org/guix"
+ "http://berlin.guixsd.org"))
+ (item (basename item)))
+ (append (map (cut string-append <> "/nar/gzip/" item) bases)
+ (map (cut string-append <> "/nar/" item) bases))))
+
+(define (restore-gzipped-nar port item size)
+ "Restore the gzipped nar read from PORT, of SIZE bytes (compressed), to
+ITEM."
+ ;; Since PORT is typically a non-file port (for instance because 'http-get'
+ ;; returns a delimited port), create a child process so we're back to a file
+ ;; port that can be passed to 'call-with-gzip-input-port'.
+ (match (pipe)
+ ((input . output)
+ (match (primitive-fork)
+ (0
+ (dynamic-wind
+ (const #t)
+ (lambda ()
+ (close-port output)
+ (close-port port)
+ (catch #t
+ (lambda ()
+ (call-with-gzip-input-port input
+ (cut restore-file <> item)))
+ (lambda (key . args)
+ (print-exception (current-error-port)
+ (stack-ref (make-stack #t) 1)
+ key args)
+ (primitive-exit 1))))
+ (lambda ()
+ (primitive-exit 0))))
+ (child
+ (close-port input)
+ (dump-port* port output
+ #:reporter (progress-reporter/file item size
+ #:abbreviation
+ store-path-abbreviation))
+ (close-port output)
+ (newline)
+ (match (waitpid child)
+ ((_ . status)
+ (unless (zero? status)
+ (error "nar decompression failed" status)))))))))
+
+(define (download-nar item)
+ "Download and extract the normalized archive for ITEM. Return #t on
+success, #f otherwise."
+ ;; Let progress reports go through.
+ (setvbuf (current-error-port) _IONBF)
+ (setvbuf (current-output-port) _IONBF)
+
+ (let loop ((urls (urls-for-item item)))
+ (match urls
+ ((url rest ...)
+ (format #t "Trying content-addressed mirror at ~a...~%"
+ (uri-host (string->uri url)))
+ (let-values (((port size)
+ (catch #t
+ (lambda ()
+ (http-fetch (string->uri url)))
+ (lambda args
+ (values #f #f)))))
+ (if (not port)
+ (loop rest)
+ (begin
+ (if size
+ (format #t "Downloading from ~a (~,2h MiB)...~%" url
+ (/ size (expt 2 20.)))
+ (format #t "Downloading from ~a...~%" url))
+ (if (string-contains url "/gzip")
+ (restore-gzipped-nar port item size)
+ (begin
+ ;; FIXME: Add progress report.
+ (restore-file port item)
+ (close-port port)))
+ #t))))
+ (()
+ #f))))
diff --git a/guix/cvs-download.scm b/guix/cvs-download.scm
index 85744c5b5..8b46f8ef8 100644
--- a/guix/cvs-download.scm
+++ b/guix/cvs-download.scm
@@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2014, 2015, 2016 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2014, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2014 Sree Harsha Totakura <sreeharsha@totakura.in>
;;; Copyright © 2015 Mark H Weaver <mhw@netris.org>
;;;
@@ -23,6 +23,7 @@
#:use-module (guix gexp)
#:use-module (guix store)
#:use-module (guix monads)
+ #:use-module (guix modules)
#:use-module (guix packages)
#:use-module (ice-9 match)
#:export (cvs-reference
@@ -59,16 +60,35 @@
"Return a fixed-output derivation that fetches REF, a <cvs-reference>
object. The output is expected to have recursive hash HASH of type
HASH-ALGO (a symbol). Use NAME as the file name, or a generic name if #f."
+ (define zlib
+ (module-ref (resolve-interface '(gnu packages compression)) 'zlib))
+
+ (define config.scm
+ (scheme-file "config.scm"
+ #~(begin
+ (define-module (guix config)
+ #:export (%libz))
+
+ (define %libz
+ #+(file-append zlib "/lib/libz")))))
+
+ (define modules
+ (cons `((guix config) => ,config.scm)
+ (delete '(guix config)
+ (source-module-closure '((guix build cvs)
+ (guix build download-nar))))))
(define build
- (with-imported-modules '((guix build cvs)
- (guix build utils))
+ (with-imported-modules modules
#~(begin
- (use-modules (guix build cvs))
- (cvs-fetch '#$(cvs-reference-root-directory ref)
- '#$(cvs-reference-module ref)
- '#$(cvs-reference-revision ref)
- #$output
- #:cvs-command (string-append #+cvs "/bin/cvs")))))
+ (use-modules (guix build cvs)
+ (guix build download-nar))
+
+ (or (cvs-fetch '#$(cvs-reference-root-directory ref)
+ '#$(cvs-reference-module ref)
+ '#$(cvs-reference-revision ref)
+ #$output
+ #:cvs-command (string-append #+cvs "/bin/cvs"))
+ (download-nar #$output)))))
(mlet %store-monad ((guile (package->derivation guile system)))
(gexp->derivation (or name "cvs-checkout") build
diff --git a/guix/git-download.scm b/guix/git-download.scm
index 7397cbe7f..731e549b3 100644
--- a/guix/git-download.scm
+++ b/guix/git-download.scm
@@ -25,6 +25,7 @@
#:use-module (guix monads)
#:use-module (guix records)
#:use-module (guix packages)
+ #:use-module (guix modules)
#:autoload (guix build-system gnu) (standard-packages)
#:use-module (ice-9 match)
#:use-module (ice-9 popen)
@@ -77,12 +78,31 @@ HASH-ALGO (a symbol). Use NAME as the file name, or a generic name if #f."
(standard-packages)
'()))
+ (define zlib
+ (module-ref (resolve-interface '(gnu packages compression)) 'zlib))
+
+ (define config.scm
+ (scheme-file "config.scm"
+ #~(begin
+ (define-module (guix config)
+ #:export (%libz))
+
+ (define %libz
+ #+(file-append zlib "/lib/libz")))))
+
+ (define modules
+ (cons `((guix config) => ,config.scm)
+ (delete '(guix config)
+ (source-module-closure '((guix build git)
+ (guix build utils)
+ (guix build download-nar))))))
+
(define build
- (with-imported-modules '((guix build git)
- (guix build utils))
+ (with-imported-modules modules
#~(begin
(use-modules (guix build git)
(guix build utils)
+ (guix build download-nar)
(ice-9 match))
;; The 'git submodule' commands expects Coreutils, sed,
@@ -92,12 +112,13 @@ HASH-ALGO (a symbol). Use NAME as the file name, or a generic name if #f."
(((names dirs) ...)
dirs)))
- (git-fetch (getenv "git url") (getenv "git commit")
- #$output
- #:recursive? (call-with-input-string
- (getenv "git recursive?")
- read)
- #:git-command (string-append #+git "/bin/git")))))
+ (or (git-fetch (getenv "git url") (getenv "git commit")
+ #$output
+ #:recursive? (call-with-input-string
+ (getenv "git recursive?")
+ read)
+ #:git-command (string-append #+git "/bin/git"))
+ (download-nar #$output)))))
(mlet %store-monad ((guile (package->derivation guile system)))
(gexp->derivation (or name "git-checkout") build
diff --git a/guix/hg-download.scm b/guix/hg-download.scm
index 842098090..6b25b87b6 100644
--- a/guix/hg-download.scm
+++ b/guix/hg-download.scm
@@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2014, 2015, 2016 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2014, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2016 Ricardo Wurmus <rekado@elephly.net>
;;;
;;; This file is part of GNU Guix.
@@ -22,6 +22,7 @@
#:use-module (guix store)
#:use-module (guix monads)
#:use-module (guix records)
+ #:use-module (guix modules)
#:use-module (guix packages)
#:autoload (guix build-system gnu) (standard-packages)
#:use-module (ice-9 match)
@@ -59,18 +60,35 @@
"Return a fixed-output derivation that fetches REF, a <hg-reference>
object. The output is expected to have recursive hash HASH of type
HASH-ALGO (a symbol). Use NAME as the file name, or a generic name if #f."
+ (define zlib
+ (module-ref (resolve-interface '(gnu packages compression)) 'zlib))
+
+ (define config.scm
+ (scheme-file "config.scm"
+ #~(begin
+ (define-module (guix config)
+ #:export (%libz))
+
+ (define %libz
+ #+(file-append zlib "/lib/libz")))))
+
+ (define modules
+ (cons `((guix config) => ,config.scm)
+ (delete '(guix config)
+ (source-module-closure '((guix build hg)
+ (guix build download-nar))))))
+
(define build
- (with-imported-modules '((guix build hg)
- (guix build utils))
+ (with-imported-modules modules
#~(begin
(use-modules (guix build hg)
- (guix build utils)
- (ice-9 match))
+ (guix build download-nar))
- (hg-fetch '#$(hg-reference-url ref)
- '#$(hg-reference-changeset ref)
- #$output
- #:hg-command (string-append #+hg "/bin/hg")))))
+ (or (hg-fetch '#$(hg-reference-url ref)
+ '#$(hg-reference-changeset ref)
+ #$output
+ #:hg-command (string-append #+hg "/bin/hg"))
+ (download-nar #$output)))))
(mlet %store-monad ((guile (package->derivation guile system)))
(gexp->derivation (or name "hg-checkout") build
--
2.14.2
^ permalink raw reply related [flat|nested] 8+ messages in thread* bug#28709: [PATCH 0/4] Content-addressed mirrors for VCS checkouts
2017-10-17 8:48 ` bug#28709: [PATCH 0/4] Content-addressed mirrors for VCS checkouts Ludovic Courtès
` (3 preceding siblings ...)
2017-10-17 8:48 ` bug#28709: [PATCH 4/4] download: Download a nar when a VCS checkout fails Ludovic Courtès
@ 2017-10-18 17:58 ` Christopher Baines
2017-10-19 21:26 ` Ludovic Courtès
4 siblings, 1 reply; 8+ messages in thread
From: Christopher Baines @ 2017-10-18 17:58 UTC (permalink / raw)
To: Ludovic Courtès; +Cc: 28709
[-- Attachment #1: Type: text/plain, Size: 1511 bytes --]
On Tue, 17 Oct 2017 10:48:03 +0200
Ludovic Courtès <ludo@gnu.org> wrote:
> Hello,
>
> Here’s a ready-to-merge patch series. Once applied, nars
> (aka. “substitutes”) are downloaded and extracted when a VCS checkout
> fails. This will address cases such as the recent Guile-Git repository
> renaming for people who have disabled substitutes.
>
> I’m Cc’ing 宋文武 because this also moves the progress-report code to
> a new (guix progress) module.
>
> Feedback welcome!
>
> Ludo’.
>
> Ludovic Courtès (4):
> download: Remove old-Guile leftovers.
> download: Make 'http-fetch' public.
> Add (guix progress).
> download: Download a nar when a VCS checkout fails.
>
> Makefile.am | 2 +
> guix/build/download-nar.scm | 125 ++++++++++++++++++++++++
> guix/build/download.scm | 216 +++++------------------------------------
> guix/cvs-download.scm | 38 ++++++--
> guix/git-download.scm | 37 +++++--
> guix/hg-download.scm | 36 +++++--
> guix/progress.scm | 228 ++++++++++++++++++++++++++++++++++++++++++++
> guix/scripts/download.scm | 4 +-
> guix/scripts/substitute.scm | 5 +-
> guix/utils.scm | 28 +-----
> 10 files changed, 470 insertions(+), 249 deletions(-)
> create mode 100644 guix/build/download-nar.scm
> create mode 100644 guix/progress.scm
>
This all sounds good to me Ludo, and I didn't spot anything of note
when looking through the patches.
[-- Attachment #2: OpenPGP digital signature --]
[-- Type: application/pgp-signature, Size: 963 bytes --]
^ permalink raw reply [flat|nested] 8+ messages in thread* bug#28709: [PATCH 0/4] Content-addressed mirrors for VCS checkouts
2017-10-18 17:58 ` bug#28709: [PATCH 0/4] Content-addressed mirrors for VCS checkouts Christopher Baines
@ 2017-10-19 21:26 ` Ludovic Courtès
0 siblings, 0 replies; 8+ messages in thread
From: Ludovic Courtès @ 2017-10-19 21:26 UTC (permalink / raw)
To: Christopher Baines; +Cc: 28709-done
Howdy!
Christopher Baines <mail@cbaines.net> skribis:
> On Tue, 17 Oct 2017 10:48:03 +0200
> Ludovic Courtès <ludo@gnu.org> wrote:
[...]
>> Ludovic Courtès (4):
>> download: Remove old-Guile leftovers.
>> download: Make 'http-fetch' public.
>> Add (guix progress).
>> download: Download a nar when a VCS checkout fails.
>>
>> Makefile.am | 2 +
>> guix/build/download-nar.scm | 125 ++++++++++++++++++++++++
>> guix/build/download.scm | 216 +++++------------------------------------
>> guix/cvs-download.scm | 38 ++++++--
>> guix/git-download.scm | 37 +++++--
>> guix/hg-download.scm | 36 +++++--
>> guix/progress.scm | 228 ++++++++++++++++++++++++++++++++++++++++++++
>> guix/scripts/download.scm | 4 +-
>> guix/scripts/substitute.scm | 5 +-
>> guix/utils.scm | 28 +-----
>> 10 files changed, 470 insertions(+), 249 deletions(-)
>> create mode 100644 guix/build/download-nar.scm
>> create mode 100644 guix/progress.scm
>>
>
> This all sounds good to me Ludo, and I didn't spot anything of note
> when looking through the patches.
Thank you, pushed!
Ludo’.
^ permalink raw reply [flat|nested] 8+ messages in thread