guix: substitutes: Make progress reporting configurable.

Rather than always outputting to (current-error-port) in
lookup-narinfos (which is called from within lookup-narinfos/diverse), take a
procedure which should return a progress reporter, and defer any output to
that.

As this is now general purpose code, make the default behaviour to output
nothing. Maintain the current behaviour of the substitute script by moving the
progress reporter implementation there, and passing it in when calling
lookup-narinfos/diverse.

These changes should be generally useful, but I'm particularly looking at
getting guix weather to do progress reporting differently, with this new
flexibility.

* guix/substitutes.scm (fetch-narinfos): Take a procedure to make a
progress-reporter, and use that rather than the hardcoded behaviour.
(lookup-narinfos): Add #:make-progress-reporter keyword argument, and pass
this through to fetch-narinfos.
(lookup-narinfos/diverse): Add a #:make-progress-reporter keyword argument,
and pass this through to lookup-narinfos.
* guix/scripts/substitute.scm (process-query): Pass a progress-reporter to
lookup-narinfos/diverse.

guix/scripts/substitute.scm

@@ -288,12 +288,30 @@ (define valid?
         (lambda (obj)
           (valid-narinfo? obj acl))))
 
+  (define* (make-progress-reporter total #:key url)
+    (define done 0)
+
+    (define (report-progress)
+      (erase-current-line (current-error-port)) ;erase current line
+      (force-output (current-error-port))
+      (format (current-error-port)
+              (G_ "updating substitutes from '~a'... ~5,1f%")
+              url (* 100. (/ done total)))
+      (set! done (+ 1 done)))
+
+    (progress-reporter
+     (start report-progress)
+     (report report-progress)
+     (stop (lambda ()
+             (newline (current-error-port))))))
+
   (match (string-tokenize command)
     (("have" paths ..1)
      ;; Return the subset of PATHS available in CACHE-URLS.
      (let ((substitutable (lookup-narinfos/diverse
                            cache-urls paths valid?
-                           #:open-connection open-connection-for-uri/cached)))
+                           #:open-connection open-connection-for-uri/cached
+                           #:make-progress-reporter make-progress-reporter)))
        (for-each (lambda (narinfo)
                    (format #t "~a~%" (narinfo-path narinfo)))
                  substitutable)
@@ -302,7 +320,8 @@ (define valid?
      ;; Reply info about PATHS if it's in CACHE-URLS.
      (let ((substitutable (lookup-narinfos/diverse
                            cache-urls paths valid?
-                           #:open-connection open-connection-for-uri/cached)))
+                           #:open-connection open-connection-for-uri/cached
+                           #:make-progress-reporter make-progress-reporter)))
        (for-each display-narinfo-data substitutable)
        (newline)))
     (wtf

guix/substitutes.scm

@@ -173,18 +173,14 @@ (define (narinfo-from-file file url)
           (apply throw args)))))
 
 (define* (fetch-narinfos url paths
-                         #:key (open-connection guix:open-connection-for-uri))
+                         #:key
+                         (open-connection guix:open-connection-for-uri)
+                         (make-progress-reporter
+                          (const progress-reporter/silent)))
   "Retrieve all the narinfos for PATHS from the cache at URL and return them."
-  (define update-progress!
+  (define progress-reporter
-    (let ((done 0)
+    (make-progress-reporter (length paths)
-          (total (length paths)))
+                            #:url url))
-      (lambda ()
-        (display "\r\x1b[K" (current-error-port)) ;erase current line
-        (force-output (current-error-port))
-        (format (current-error-port)
-                (G_ "updating substitutes from '~a'... ~5,1f%")
-                url (* 100. (/ done total)))
-        (set! done (+ 1 done)))))
 
   (define hash-part->path
     (let ((mapping (fold (lambda (path result)
@@ -206,7 +202,7 @@ (define (handle-narinfo-response request response port result)
            (len    (response-content-length response))
            (cache  (response-cache-control response))
            (ttl    (and cache (assoc-ref cache 'max-age))))
-      (update-progress!)
+      (progress-reporter-report! progress-reporter)
 
       ;; Make sure to read no more than LEN bytes since subsequent bytes may
       ;; belong to the next response.
@@ -238,7 +234,7 @@ (define (do-fetch uri)
        ;; narinfos, which provides a much stronger guarantee.
        (let* ((requests (map (cut narinfo-request url <>) paths))
               (result   (begin
-                          (update-progress!)
+                          (start-progress-reporter! progress-reporter)
                           (call-with-connection-error-handling
                            uri
                            (lambda ()
@@ -247,7 +243,7 @@ (define (do-fetch uri)
                                                 requests
                                                 #:open-connection open-connection
                                                 #:verify-certificate? #f))))))
-         (newline (current-error-port))
+         (stop-progress-reporter! progress-reporter)
          result))
       ((file #f)
        (let* ((base  (string-append (uri-path uri) "/"))
@@ -297,7 +293,9 @@ (define cache-file
       (values #f #f))))
 
 (define* (lookup-narinfos cache paths
-                          #:key (open-connection guix:open-connection-for-uri))
+                          #:key (open-connection guix:open-connection-for-uri)
+                          (make-progress-reporter
+                           (const progress-reporter/silent)))
   "Return the narinfos for PATHS, invoking the server at CACHE when no
 information is available locally."
   (let-values (((cached missing)
@@ -315,12 +313,16 @@ (define* (lookup-narinfos cache paths
     (if (null? missing)
         cached
         (let ((missing (fetch-narinfos cache missing
-                                       #:open-connection open-connection)))
+                                       #:open-connection open-connection
+                                       #:make-progress-reporter
+                                       make-progress-reporter)))
           (append cached (or missing '()))))))
 
 (define* (lookup-narinfos/diverse caches paths authorized?
                                   #:key (open-connection
-                                         guix:open-connection-for-uri))
+                                         guix:open-connection-for-uri)
+                                  (make-progress-reporter
+                                   (const progress-reporter/silent)))
   "Look up narinfos for PATHS on all of CACHES, a list of URLS, in that order.
 That is, when a cache lacks an AUTHORIZED? narinfo, look it up in the next
 cache, and so on.
@@ -353,7 +355,9 @@ (define (select-hit result)
        (match caches
          ((cache rest ...)
           (let* ((narinfos (lookup-narinfos cache paths
-                                            #:open-connection open-connection))
+                                            #:open-connection open-connection
+                                            #:make-progress-reporter
+                                            make-progress-reporter))
                  (definite (map narinfo-path (filter authorized? narinfos)))
                  (missing  (lset-difference string=? paths definite))) ;XXX: perf
             (loop rest missing