02/02: perform-download: Optionally report a "download-progress" trace.

[Ludovic Courtès]

civodul pushed a commit to branch wip-ui
in repository guix.

commit 00d4d3118fba873bfaeefe10ac08b79e41c952c1
Author: Ludovic Courtès <address@hidden>
Date:   Wed Sep 12 15:08:38 2018 +0200

    perform-download: Optionally report a "download-progress" trace.
    
    * guix/scripts/perform-download.scm (perform-download): Add
      #:print-build-trace? and pass it to 'url-fetch'.
    (guix-perform-download): Define 'print-build-trace?' and pass it to
    'perform-download'.
    * guix/build/download.scm (ftp-fetch): Add #:print-build-trace? and
    honor it.
    (url-fetch): Likewise.
---
 guix/build/download.scm           | 24 +++++++++++++++++-------
 guix/scripts/perform-download.scm | 18 +++++++++++++-----
 2 files changed, 30 insertions(+), 12 deletions(-)

diff --git a/guix/build/download.scm b/guix/build/download.scm
index 315a355..5adff1e 100644
--- a/guix/build/download.scm
+++ b/guix/build/download.scm
@@ -115,7 +115,7 @@ and 'guix publish', something like
         (string-drop path 33)
         path)))
 
-(define* (ftp-fetch uri file #:key timeout)
+(define* (ftp-fetch uri file #:key timeout print-build-trace?)
   "Fetch data from URI and write it to FILE.  Return FILE on success.  Bail
 out if the connection could not be established in less than TIMEOUT seconds."
   (let* ((conn (match (and=> (uri-userinfo uri)
@@ -136,8 +136,12 @@ out if the connection could not be established in less 
than TIMEOUT seconds."
       (lambda (out)
         (dump-port* in out
                     #:buffer-size %http-receive-buffer-size
-                    #:reporter (progress-reporter/file
-                                (uri-abbreviation uri) size))))
+                    #:reporter
+                    (if print-build-trace?
+                        (progress-reporter/trace
+                         file (uri->string uri) size)
+                        (progress-reporter/file
+                         (uri-abbreviation uri) size)))))
 
     (ftp-close conn))
     (newline)
@@ -723,7 +727,8 @@ Return a list of URIs."
                     #:key
                     (timeout 10) (verify-certificate? #t)
                     (mirrors '()) (content-addressed-mirrors '())
-                    (hashes '()))
+                    (hashes '())
+                    print-build-trace?)
   "Fetch FILE from URL; URL may be either a single string, or a list of
 string denoting alternate URLs for FILE.  Return #f on failure, and FILE
 on success.
@@ -759,13 +764,18 @@ otherwise simply ignore them."
             (lambda (output)
               (dump-port* port output
                           #:buffer-size %http-receive-buffer-size
-                          #:reporter (progress-reporter/file
-                                      (uri-abbreviation uri) size))
+                          #:reporter (if print-build-trace?
+                                         (progress-reporter/trace
+                                          file (uri->string uri) size)
+                                         (progress-reporter/file
+                                          (uri-abbreviation uri) size)))
               (newline)))
           file)))
       ((ftp)
        (false-if-exception* (ftp-fetch uri file
-                                       #:timeout timeout)))
+                                       #:timeout timeout
+                                       #:print-build-trace?
+                                       print-build-trace?)))
       (else
        (format #t "skipping URI with unsupported scheme: ~s~%"
                uri)
diff --git a/guix/scripts/perform-download.scm 
b/guix/scripts/perform-download.scm
index 9f6ecc0..ce5919a 100644
--- a/guix/scripts/perform-download.scm
+++ b/guix/scripts/perform-download.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2016, 2017 Ludovic Courtès <address@hidden>
+;;; Copyright © 2016, 2017, 2018 Ludovic Courtès <address@hidden>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -41,14 +41,14 @@
     (module-use! module (resolve-interface '(guix base32)))
     module))
 
-(define* (perform-download drv #:optional output)
+(define* (perform-download drv #:optional output
+                           #:key print-build-trace?)
   "Perform the download described by DRV, a fixed-output derivation, to
 OUTPUT.
 
 Note: Unless OUTPUT is #f, we don't read the value of 'out' in DRV since the
 actual output is different from that when we're doing a 'bmCheck' or
 'bmRepair' build."
-  ;; TODO: Use 'trace-progress-proc' when possible.
   (derivation-let drv ((url "url")
                        (output* "out")
                        (executable "executable")
@@ -68,6 +68,7 @@ actual output is different from that when we're doing a 
'bmCheck' or
 
       ;; We're invoked by the daemon, which gives us write access to OUTPUT.
       (when (url-fetch url output
+                       #:print-build-trace? print-build-trace?
                        #:mirrors (if mirrors
                                      (call-with-input-file mirrors read)
                                      '())
@@ -99,6 +100,11 @@ allows us to sidestep bootstrapping problems, such 
downloading the source code
 of GnuTLS over HTTPS, before we have built GnuTLS.  See
 <http://bugs.gnu.org/22774>."
 
+  (define print-build-trace?
+    (match (getenv "_NIX_OPTIONS")
+      (#f #f)
+      (str (string-contains str "print-build-trace=1"))))
+
   ;; This program must be invoked by guix-daemon under an unprivileged UID to
   ;; prevent things downloading from 'file:///etc/shadow' or arbitrary code
   ;; execution via the content-addressed mirror procedures.  (That means we
@@ -108,10 +114,12 @@ of GnuTLS over HTTPS, before we have built GnuTLS.  See
       (((? derivation-path? drv) (? store-path? output))
        (assert-low-privileges)
        (perform-download (read-derivation-from-file drv)
-                         output))
+                         output
+                         #:print-build-trace? print-build-trace?))
       (((? derivation-path? drv))                 ;backward compatibility
        (assert-low-privileges)
-       (perform-download (read-derivation-from-file drv)))
+       (perform-download (read-derivation-from-file drv)
+                         #:print-build-trace? print-build-trace?))
       (("--version")
        (show-version-and-exit))
       (x