01/05: ssh: 'send-files' displays a progress bar.

[guix-commits]

civodul pushed a commit to branch master
in repository guix.

commit b03267df6d5ec44e9617b6aab0df14a2e79f822e
Author: Ludovic Courtès <ludo@gnu.org>
AuthorDate: Mon Aug 31 11:36:26 2020 +0200

    ssh: 'send-files' displays a progress bar.
    
    * guix/store.scm (export-paths): Add #:start, #:progress, and #:finish
    parameters and honor them.
    * guix/ssh.scm (prepare-to-send, notify-transfer-progress)
    (notify-transfer-completion): New procedures.
    (send-files): Pass #:start, #:progress, and #:finish to 'export-paths'.
---
 guix/ssh.scm   | 77 +++++++++++++++++++++++++++++++++++++++++++++++-----------
 guix/store.scm | 24 +++++++++++++++---
 2 files changed, 83 insertions(+), 18 deletions(-)

diff --git a/guix/ssh.scm b/guix/ssh.scm
index 24db171..5f94528 100644
--- a/guix/ssh.scm
+++ b/guix/ssh.scm
@@ -20,7 +20,11 @@
   #:use-module (guix store)
   #:use-module (guix inferior)
   #:use-module (guix i18n)
-  #:use-module ((guix diagnostics) #:select (&fix-hint formatted-message))
+  #:use-module ((guix diagnostics)
+                #:select (info &fix-hint formatted-message))
+  #:use-module ((guix progress)
+                #:select (progress-bar
+                          erase-current-line current-terminal-columns))
   #:use-module (gcrypt pk-crypto)
   #:use-module (ssh session)
   #:use-module (ssh auth)
@@ -36,6 +40,7 @@
   #:use-module (ice-9 match)
   #:use-module (ice-9 format)
   #:use-module (ice-9 binary-ports)
+  #:use-module (ice-9 vlist)
   #:export (open-ssh-session
             authenticate-server*
 
@@ -402,6 +407,55 @@ to the system ACL file if it has not yet been authorized."
    session
    become-command))
 
+(define (prepare-to-send store host log-port items)
+  "Notify the user that we're about to send ITEMS to HOST.  Return three
+values allowing 'notify-send-progress' to track the state of this transfer."
+  (let* ((count (length items))
+         (sizes (fold (lambda (item result)
+                        (vhash-cons item
+                                    (path-info-nar-size
+                                     (query-path-info store item))
+                                    result))
+                      vlist-null
+                      items))
+         (total  (vlist-fold (lambda (pair result)
+                               (match pair
+                                 ((_ . size) (+ size result))))
+                             0
+                             sizes)))
+    (info (N_ "sending ~a store item (~h MiB) to '~a'...~%"
+              "sending ~a store items (~h MiB) to '~a'...~%" count)
+          count
+          (inexact->exact (round (/ total (expt 2. 20))))
+          host)
+
+    (values log-port sizes total 0)))
+
+(define (notify-transfer-progress item port sizes total sent)
+  "Notify the user that we've already transferred SENT bytes out of TOTAL.
+Use SIZES to determine the size of ITEM, which is about to be sent."
+  (define (display-bar %)
+    (erase-current-line port)
+    (format port "~3@a% ~a"
+            (inexact->exact (round (* 100. (/ sent total))))
+            (progress-bar % (- (max (current-terminal-columns) 5) 5)))
+    (force-output port))
+
+  (let ((% (* 100. (/ sent total))))
+    (match (vhash-assoc item sizes)
+      (#f
+       (display-bar %)
+       (values port sizes total sent))
+      ((_ . size)
+       (display-bar %)
+       (values port sizes total (+ sent size))))))
+
+(define (notify-transfer-completion port . args)
+  "Notify the user that the transfer has completed."
+  (apply notify-transfer-progress "" port args) ;display the 100% progress bar
+  (erase-current-line port)
+  (force-output port))
+
 (define* (send-files local files remote
                      #:key
                      recursive?
@@ -412,7 +466,7 @@ Return the list of store items actually sent."
   ;; Compute the subset of FILES missing on SESSION and send them.
   (let* ((files   (if recursive? (requisites local files) files))
          (session (channel-get-session (store-connection-socket remote)))
-         (missing (inferior-remote-eval
+         (missing (take files 20) #;(inferior-remote-eval
                    `(begin
                       (use-modules (guix)
                                    (srfi srfi-1) (srfi srfi-26))
@@ -421,11 +475,8 @@ Return the list of store items actually sent."
                         (remove (cut valid-path? store <>)
                                 ',files)))
                    session))
-         (count   (length missing))
-         (sizes   (map (lambda (item)
-                         (path-info-nar-size (query-path-info local item)))
-                       missing))
-         (port    (store-import-channel session)))
+         (port    (store-import-channel session))
+         (host    (session-get session 'host)))
     ;; Make sure everything alright on the remote side.
     (match (read port)
       (('importing)
@@ -433,14 +484,12 @@ Return the list of store items actually sent."
       (sexp
        (handle-import/export-channel-error sexp remote)))
 
-    (format log-port (N_ "sending ~a store item (~h MiB) to '~a'...~%"
-                         "sending ~a store items (~h MiB) to '~a'...~%" count)
-            count
-            (inexact->exact (round (/ (reduce + 0 sizes) (expt 2. 20))))
-            (session-get session 'host))
-
     ;; Send MISSING in topological order.
-    (export-paths local missing port)
+    (let ((tty? (isatty? log-port)))
+      (export-paths local missing port
+                    #:start (cut prepare-to-send local host log-port <>)
+                    #:progress (if tty? notify-transfer-progress (const #f))
+                    #:finish (if tty? notify-transfer-completion (const #f))))
 
     ;; Tell the remote process that we're done.  (In theory the end-of-archive
     ;; mark of 'export-paths' would be enough, but in practice it's not.)
diff --git a/guix/store.scm b/guix/store.scm
index 495dc16..6bb6f43 100644
--- a/guix/store.scm
+++ b/guix/store.scm
@@ -1728,10 +1728,20 @@ is raised if the set of paths read from PORT is not 
signed (as per
       (or done? (loop (process-stderr server port))))
     (= 1 (read-int s))))
 
-(define* (export-paths server paths port #:key (sign? #t) recursive?)
+(define* (export-paths server paths port #:key (sign? #t) recursive?
+                       (start (const #f))
+                       (progress (const #f))
+                       (finish (const #f)))
   "Export the store paths listed in PATHS to PORT, in topological order,
 signing them if SIGN? is true.  When RECURSIVE? is true, export the closure of
-PATHS---i.e., PATHS and all their dependencies."
+PATHS---i.e., PATHS and all their dependencies.
+
+START, PROGRESS, and FINISH are used to track progress of the data transfer.
+START is a one-argument that is passed the list of store items that will be
+transferred; it returns values that are then used as the initial state
+threaded through PROGRESS calls.  PROGRESS is passed the store item about to
+be sent, along with the values previously return by START or by PROGRESS
+itself.  FINISH is called when the last store item has been called."
   (define ordered
     (let ((sorted (topologically-sorted server paths)))
       ;; When RECURSIVE? is #f, filter out the references of PATHS.
@@ -1739,14 +1749,20 @@ PATHS---i.e., PATHS and all their dependencies."
           sorted
           (filter (cut member <> paths) sorted))))
 
-  (let loop ((paths ordered))
+  (let loop ((paths ordered)
+             (state (call-with-values (lambda () (start ordered))
+                      list)))
     (match paths
       (()
+       (apply finish state)
        (write-int 0 port))
       ((head tail ...)
        (write-int 1 port)
        (and (export-path server head port #:sign? sign?)
-            (loop tail))))))
+            (loop tail
+                  (call-with-values
+                      (lambda () (apply progress head state))
+                    list)))))))
 
 (define-operation (query-failed-paths)
   "Return the list of store items for which a build failure is cached.