[WIP][PATCH] download: Don't report the progress too fast

[WIP][PATCH] download: Don't report the progress too fast

[宋文武]

[-- Attachment #1: Type: text/plain, Size: 1379 bytes --]

Hello, our progress report of 'guix download' can refresh too fast.  For
example, it blinks much with this script:

--8<---------------cut here---------------start------------->8---
(use-modules (guix build download))


(let* ((size (expt 2 20))
       (progress (progress-proc "" size)))
  (let loop ((p 0))
    (unless (> p size)
      (progress p (const #t))
      (loop (+ p (random 100)))))
  (newline))
--8<---------------cut here---------------end--------------->8---

I'd like limiting its rate to render every 300ms.  So I write a
higher-order function that does nothing when the previous invocation not
happened some time (the interval) ago.  For lacking a proper name in my
mind, I just call it 'rate-limited'.  Then using it to modify the
'progress-proc', let it render every 300ms.

It seems working as I want, but will lost the last report, the progress
will never finish to 100%...  There is no way to know a report is the
last or not in the 'progress-proc' with only the 'transferred' parameter
when the 'size' of file is unknown.

So, the left step is adding a parameter to the produce that
'progress-proc' returns, and change the produce 'dump-port' in
build/utils.scm to call it trickly like '(progress total #:eof? #t)'
when the file ends.  So I can always render the last one.

This doesn't look good, so help wanted, thanks!

The patch, without the finish:

[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #2: 0001-download-Don-t-report-the-progress-too-fast.patch --]
[-- Type: text/x-patch, Size: 4806 bytes --]

From 70f4d739a9b67f5c169d95b2c26415489932761b Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?=E5=AE=8B=E6=96=87=E6=AD=A6?= <iyzsong@member.fsf.org>
Date: Sat, 26 Aug 2017 17:48:48 +0800
Subject: [PATCH] download: Don't report the progress too fast.

* guix/build/download.scm (rate-limited): New procedure.
(progress-proc): Report the progress only when 300ms has been elapsed since
the previous reporting.
---
 guix/build/download.scm | 54 +++++++++++++++++++++++++++++++++++++------------
 1 file changed, 41 insertions(+), 13 deletions(-)

diff --git a/guix/build/download.scm b/guix/build/download.scm
index 6ef623334..b7b7e7d65 100644
--- a/guix/build/download.scm
+++ b/guix/build/download.scm
@@ -147,6 +147,24 @@ Otherwise return STORE-PATH."
    (define time-monotonic time-tai))
   (else #t))
 
+(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 ((lasted-at #f))
+    (lambda args
+      (let ((forward-invocation
+	     (lambda ()
+	       (set! lasted-at (current-time time-monotonic))
+               (apply proc args))))
+	(if lasted-at
+	    (let ((elapsed
+		   (time-difference (current-time time-monotonic) lasted-at)))
+	      (if (time>=? elapsed interval)
+		  (forward-invocation)
+                  #f))
+	    (forward-invocation))))))
+
 (define* (progress-proc file size
                         #:optional (log-port (current-output-port))
                         #:key (abbreviation basename))
@@ -157,7 +175,11 @@ used to shorten FILE for display."
   ;; XXX: Because of <http://bugs.gnu.org/19939> 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 ((start-time #f)
+        ;; Procedure that only runs a thunk when 300ms has been elapsed.
+        (noop-if-too-fast (rate-limited
+                           (lambda (x) (x))
+                           (make-time time-monotonic 300000000 0))))
     (let-syntax ((with-elapsed-time
                      (syntax-rules ()
                        ((_ elapsed body ...)
@@ -182,12 +204,15 @@ used to shorten FILE for display."
                      (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)
+                                         (progress-bar %) %))
+                     (render     (lambda ()
+                                   (display "\r\x1b[K" log-port)
+                                   (display (string-pad-middle
+                                             left right
+                                             (current-terminal-columns))
+                                            log-port)
+                                   (flush-output-port log-port))))
+                (noop-if-too-fast render)
                 (cont))))
           (lambda (transferred cont)
             (with-elapsed-time elapsed
@@ -199,12 +224,15 @@ used to shorten FILE for display."
                      (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)
+                                         (byte-count->string transferred)))
+                     (render     (lambda ()
+                                   (display "\r\x1b[K" log-port)
+                                   (display (string-pad-middle
+                                             left right
+                                             (current-terminal-columns))
+                                            log-port)
+                                   (flush-output-port log-port))))
+                (noop-if-too-fast render)
                 (cont))))))))
 
 (define* (uri-abbreviation uri #:optional (max-length 42))
-- 
2.13.3

Re: [WIP][PATCH] download: Don't report the progress too fast

[Ludovic Courtès]

Hello 宋文武,

iyzsong@member.fsf.org (宋文武) skribis:

> Hello, our progress report of 'guix download' can refresh too fast.  For
> example, it blinks much with this script:

Indeed, that’s always annoyed me.  I’m glad you’re looking at it!

> I'd like limiting its rate to render every 300ms.  So I write a
> higher-order function that does nothing when the previous invocation not
> happened some time (the interval) ago.  For lacking a proper name in my
> mind, I just call it 'rate-limited'.  Then using it to modify the
> 'progress-proc', let it render every 300ms.
>
> It seems working as I want, but will lost the last report, the progress
> will never finish to 100%...  There is no way to know a report is the
> last or not in the 'progress-proc' with only the 'transferred' parameter
> when the 'size' of file is unknown.

What about sacrificing elegance, and instead put that logic directly in
‘progress-proc’ itself, where we know whether we’re at 100% or not?  I’m
very much in favor of pragmatic choices in such circumstances.

(Also, longer-term, we’d want to do that other way around, which is to
update the report every N milliseconds, as opposed to just printing
something when a chunk has been transferred.)

WDYT?

Ludo’.

Re: [WIP][PATCH] download: Don't report the progress too fast

[宋文武]

[-- Attachment #1: Type: text/plain, Size: 658 bytes --]

Hi, sorry for my late response.

ludo@gnu.org (Ludovic Courtès) writes:

> Hello 宋文武,
>
> iyzsong@member.fsf.org (宋文武) skribis:
>
>> Hello, our progress report of 'guix download' can refresh too fast.  For
>> example, it blinks much with this script:
>
> Indeed, that’s always annoyed me.  I’m glad you’re looking at it!
>
>> [...]
>
> [...]
> (Also, longer-term, we’d want to do that other way around, which is to
> update the report every N milliseconds, as opposed to just printing
> something when a chunk has been transferred.)
>

Yes, so the elapsed time won't be freezed, and here is my try using
thread:


[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #2: 0001-download-Report-the-progress-asynchronously-in-anoth.patch --]
[-- Type: text/x-patch, Size: 17239 bytes --]

From 4036ce5de7bf3b98327010bbfbf75029f3d0b572 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?=E5=AE=8B=E6=96=87=E6=AD=A6?= <iyzsong@member.fsf.org>
Date: Fri, 8 Sep 2017 22:49:03 +0800
Subject: [PATCH] download: Report the progress asynchronously in another
 thread.

* guix/utils.scm (<progress-reporter>): New record type.
(call-with-progress-reporter): New procedure.
* guix/build/download.scm (dump-port*, progress-reporter/file): New
procedures.
(ftp-fetch, http-fetch): Use them.
(progress-proc): Remove procedure.
* guix/scripts/substitute.scm (progress-report-port): Rewrite in terms of
<progress-reporter>.
(process-substitution): Adjust accordingly.
---
 guix/build/download.scm     | 169 ++++++++++++++++++++++++++------------------
 guix/scripts/substitute.scm |  54 +++++++-------
 guix/utils.scm              |  32 ++++++++-
 3 files changed, 159 insertions(+), 96 deletions(-)

diff --git a/guix/build/download.scm b/guix/build/download.scm
index bcf22663b..7c712ca94 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)
@@ -36,6 +37,8 @@
   #:autoload   (ice-9 ftw) (scandir)
   #:use-module (ice-9 match)
   #:use-module (ice-9 format)
+  #:use-module (ice-9 atomic)
+  #:use-module (ice-9 threads)
   #:export (open-socket-for-uri
             open-connection-for-uri
             %x509-certificate-directory
@@ -45,7 +48,7 @@
             url-fetch
             byte-count->string
             current-terminal-columns
-            progress-proc
+            progress-reporter/file
             uri-abbreviation
             nar-uri-abbreviation
             store-path-abbreviation))
@@ -148,65 +151,92 @@ 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 <http://bugs.gnu.org/19939> 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 ...)))))
-      (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))))))))
+
+;; 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* (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 ((thread      #f)
+        (%transferred (make-atomic-box 0)))
+    (define (report-progress)
+      "Continuously write the progress report to LOG-PORT."
+      (define start-time (current-time time-monotonic))
+      (define (render)
+        (define transferred (atomic-box-ref %transferred))
+        (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))))
+
+      (dynamic-wind
+        noop
+        (lambda ()
+          (let loop ()
+            ;; Report the progress every 300ms.
+            (render)
+            (usleep 300000)
+            (loop)))
+        ;; And don't miss the last report.
+        render))
+
+    (progress-reporter
+     (start (lambda ()
+              (set! thread (make-thread report-progress))))
+     (report (lambda (value)
+               (atomic-box-set! %transferred value)))
+     (stop (lambda ()
+             (cancel-thread thread)
+             (join-thread thread))))))
 
 (define* (uri-abbreviation uri #:optional (max-length 42))
   "If URI's string representation is larger than MAX-LENGTH, return an
@@ -264,9 +294,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 +786,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 +894,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)
diff --git a/guix/scripts/substitute.scm b/guix/scripts/substitute.scm
index 0d36997bc..f7d523fd6 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
@@ -772,23 +773,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 <progress-reporter> object."
+  (match reporter
+    (($ <progress-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 ()
@@ -903,12 +906,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)
@@ -916,8 +918,8 @@ DESTINATION as a nar file.  Verify the substitute against ACL."
       ;; Unpack the Nar at INPUT into DESTINATION.
       (restore-file input destination)
 
-      ;; 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 ab43ed400..e986ccd4f 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>
+            progress-reporter
+            make-progress-reporter
+            progress-reporter?
+            call-with-progress-reporter))
 
 \f
 ;;;
@@ -747,3 +754,26 @@ a location object."
   `((line     . ,(and=> (location-line loc) 1-))
     (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.13.3

Re: [WIP][PATCH] download: Don't report the progress too fast

[Ludovic Courtès]

Hi!

iyzsong@member.fsf.org (宋文武) skribis:

> Hi, sorry for my late response.

No problem, it was worth waiting.  ;-)

> ludo@gnu.org (Ludovic Courtès) writes:

[...]

>> (Also, longer-term, we’d want to do that other way around, which is to
>> update the report every N milliseconds, as opposed to just printing
>> something when a chunk has been transferred.)
>>
>
> Yes, so the elapsed time won't be freezed, and here is my try using
> thread:

[...]

> From 4036ce5de7bf3b98327010bbfbf75029f3d0b572 Mon Sep 17 00:00:00 2001
> From: =?UTF-8?q?=E5=AE=8B=E6=96=87=E6=AD=A6?= <iyzsong@member.fsf.org>
> Date: Fri, 8 Sep 2017 22:49:03 +0800
> Subject: [PATCH] download: Report the progress asynchronously in another
>  thread.
>
> * guix/utils.scm (<progress-reporter>): New record type.
> (call-with-progress-reporter): New procedure.
> * guix/build/download.scm (dump-port*, progress-reporter/file): New
> procedures.
> (ftp-fetch, http-fetch): Use them.
> (progress-proc): Remove procedure.
> * guix/scripts/substitute.scm (progress-report-port): Rewrite in terms of
> <progress-reporter>.
> (process-substitution): Adjust accordingly.

Impressive!

I have a couple of concerns though:

  1. Using a thread “just” for progress reporting seems quite
     heavyweight, though maybe that’s OK.

  2. As per POSIX, we cannot mix ‘fork’ and threads, so programs that
     use ‘primitive-fork’ should not also use threads.  One such program
     is (guix scripts substitute), via ‘decompressed-port’.  Guile
     rightfully emits a warning when a multithreaded program calls
     ‘primitive-fork’:

       https://git.savannah.gnu.org/cgit/guile.git/tree/libguile/posix.c#n1224

   3. “Atomic boxes” are a Guile 2.2 feature, but we still support 2.0.

To address these, I would use ‘abort-to-prompt’ & co., possibly with
“suspendable ports”, but this is a 2.2 feature.  (It may be that we
should use Fibers directly.)

Tricky!  Not sure what to do here.

Thoughts?

Ludo’.

Re: [WIP][PATCH] download: Don't report the progress too fast

[宋文武]

ludo@gnu.org (Ludovic Courtès) writes:

> [...]
>> Date: Fri, 8 Sep 2017 22:49:03 +0800
>> Subject: [PATCH] download: Report the progress asynchronously in another
>>  thread.
>>
>> * guix/utils.scm (<progress-reporter>): New record type.
>> (call-with-progress-reporter): New procedure.
>> * guix/build/download.scm (dump-port*, progress-reporter/file): New
>> procedures.
>> (ftp-fetch, http-fetch): Use them.
>> (progress-proc): Remove procedure.
>> * guix/scripts/substitute.scm (progress-report-port): Rewrite in terms of
>> <progress-reporter>.
>> (process-substitution): Adjust accordingly.
>
> Impressive!
>
> I have a couple of concerns though:
>
>   1. Using a thread “just” for progress reporting seems quite
>      heavyweight, though maybe that’s OK.

Yes..
>
>   2. As per POSIX, we cannot mix ‘fork’ and threads, so programs that
>      use ‘primitive-fork’ should not also use threads.  One such program
>      is (guix scripts substitute), via ‘decompressed-port’.  Guile
>      rightfully emits a warning when a multithreaded program calls
>      ‘primitive-fork’:
>
>        https://git.savannah.gnu.org/cgit/guile.git/tree/libguile/posix.c#n1224

Oh, thanks for pointing it out!
>
>    3. “Atomic boxes” are a Guile 2.2 feature, but we still support 2.0.
>
> To address these, I would use ‘abort-to-prompt’ & co., possibly with
> “suspendable ports”, but this is a 2.2 feature.  (It may be that we
> should use Fibers directly.)

Sure, I’d like to try fibers.  When we can drop the support of Guile
2.0?  (I guess one sign is that 2.2 is in the debian stable.)

>
> Tricky!  Not sure what to do here.
>
> Thoughts?

How about replace the use of thread from ‘progress-reporter/file’ by a
‘rate-limited’ render procedure, and then change the elapsed time to
ETA, which is okay without updating in seconds?

Re: [WIP][PATCH] download: Don't report the progress too fast

[宋文武]

[-- Attachment #1: Type: text/plain, Size: 350 bytes --]

iyzsong@member.fsf.org (宋文武) writes:

> ludo@gnu.org (Ludovic Courtès) writes:
>
>> [...]
>> Thoughts?
>
> How about replace the use of thread from ‘progress-reporter/file’ by a
> ‘rate-limited’ render procedure, and then change the elapsed time to
> ETA, which is okay without updating in seconds?

So I end up it with:


[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #2: 0001-download-Don-t-report-the-progress-too-fast.patch --]
[-- Type: text/x-patch, Size: 17450 bytes --]

From d0c49ac1341c21d0efb069afb1521f61541e3eb4 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?=E5=AE=8B=E6=96=87=E6=AD=A6?= <iyzsong@member.fsf.org>
Date: Sat, 16 Sep 2017 14:10:18 -0600
Subject: [PATCH] download: Don't report the progress too fast.

* guix/utils.scm (<progress-reporter>): 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
<progress-reporter>.
(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(-)

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 <http://bugs.gnu.org/19939> 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 <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)
-          (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 dd49cf15f..19212d749 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 <progress-reporter> object."
+  (match reporter
+    (($ <progress-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)
@@ -960,8 +962,8 @@ DESTINATION as a nar file.  Verify the substitute against ACL."
       ;; Unpack the Nar at INPUT into DESTINATION.
       (restore-file input destination)
 
-      ;; 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 ab43ed400..e986ccd4f 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>
+            progress-reporter
+            make-progress-reporter
+            progress-reporter?
+            call-with-progress-reporter))
 
 \f
 ;;;
@@ -747,3 +754,26 @@ a location object."
   `((line     . ,(and=> (location-line loc) 1-))
     (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.13.3

Re: [WIP][PATCH] download: Don't report the progress too fast

[Ludovic Courtès]

iyzsong@member.fsf.org (宋文武) skribis:

> From d0c49ac1341c21d0efb069afb1521f61541e3eb4 Mon Sep 17 00:00:00 2001
> From: =?UTF-8?q?=E5=AE=8B=E6=96=87=E6=AD=A6?= <iyzsong@member.fsf.org>
> Date: Sat, 16 Sep 2017 14:10:18 -0600
> Subject: [PATCH] download: Don't report the progress too fast.
>
> * guix/utils.scm (<progress-reporter>): 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
> <progress-reporter>.
> (process-substitution): Adjust accordingly.

LGTM.  If you’ve confirmed that it works as intended, please push.

Thank you!

Ludo’.

Re: [WIP][PATCH] download: Don't report the progress too fast

[宋文武]

ludo@gnu.org (Ludovic Courtès) writes:

> iyzsong@member.fsf.org (宋文武) skribis:
>
>> From d0c49ac1341c21d0efb069afb1521f61541e3eb4 Mon Sep 17 00:00:00 2001
>> From: =?UTF-8?q?=E5=AE=8B=E6=96=87=E6=AD=A6?= <iyzsong@member.fsf.org>
>> Date: Sat, 16 Sep 2017 14:10:18 -0600
>> Subject: [PATCH] download: Don't report the progress too fast.
>>
>> * guix/utils.scm (<progress-reporter>): 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
>> <progress-reporter>.
>> (process-substitution): Adjust accordingly.
>
> LGTM.  If you’ve confirmed that it works as intended, please push.
>

Done, thanks for the review!

Re: [WIP][PATCH] download: Don't report the progress too fast

[Ludovic Courtès]

Hello!

iyzsong@member.fsf.org (宋文武) skribis:

> ludo@gnu.org (Ludovic Courtès) writes:

[...]

>> To address these, I would use ‘abort-to-prompt’ & co., possibly with
>> “suspendable ports”, but this is a 2.2 feature.  (It may be that we
>> should use Fibers directly.)
>
> Sure, I’d like to try fibers.  When we can drop the support of Guile
> 2.0?  (I guess one sign is that 2.2 is in the debian stable.)

“Sometime.”  :-)

IMO we should keep supporting 2.0 until 2.2’s compiler has reasonable
resource consumption.

>> Tricky!  Not sure what to do here.
>>
>> Thoughts?
>
> How about replace the use of thread from ‘progress-reporter/file’ by a
> ‘rate-limited’ render procedure, and then change the elapsed time to
> ETA, which is okay without updating in seconds?

Roughly what you did initially, right?  That sounds good to me.

Thanks,
Ludo’.