From de9d8f0e295928d92e0e5ea43a4e594fa78c76fb Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= <ludo@gnu.org>
Date: Sun, 4 Jun 2017 22:53:40 +0200
Subject: [PATCH] ssh: Improve error reporting when 'send-files' fails.

Fixes <http://bugs.gnu.org/26972>.

* guix/ssh.scm (store-import-channel)[import]: Add 'consume-input'
procedure.  Wrap body in 'catch' and 'guard'.  Use 'open-remote-pipe'
with OPEN_BOTH instead of 'open-remote-output-pipe'.
(send-files): After the 'channel-send-eof' call, do (read port).
Interpret the result sexp and raise an error condition if needed.
---
 guix/ssh.scm | 70 +++++++++++++++++++++++++++++++++++++++++-----------
 1 file changed, 55 insertions(+), 15 deletions(-)

diff --git a/guix/ssh.scm b/guix/ssh.scm
index 4fb145230d..32cf6e464b 100644
--- a/guix/ssh.scm
+++ b/guix/ssh.scm
@@ -150,23 +150,44 @@ can be written."
   ;; makes a round trip every time 32 KiB have been transferred.  This
   ;; procedure instead opens a separate channel to use the remote
   ;; 'import-paths' procedure, which consumes all the data in a single round
-  ;; trip.
+  ;; trip.  This optimizes the successful case at the expense of error
+  ;; conditions: errors can only be reported once all the input has been
+  ;; consumed.
   (define import
     `(begin
-       (use-modules (guix))
+       (use-modules (guix) (srfi srfi-34)
+                    (rnrs io ports) (rnrs bytevectors))
 
-       (with-store store
-         (setvbuf (current-input-port) _IONBF)
+       (define (consume-input port)
+         (let ((bv (make-bytevector 32768)))
+           (let loop ()
+             (let ((n (get-bytevector-n! port bv 0
+                                         (bytevector-length bv))))
+               (unless (eof-object? n)
+                 (loop))))))
 
-         ;; FIXME: Exceptions are silently swallowed.  We should report them
-         ;; somehow.
-         (import-paths store (current-input-port)))))
+       ;; Upon completion, write an sexp that denotes the status.
+       (write
+        (catch #t
+          (lambda ()
+            (guard (c ((nix-protocol-error? c)
+                       ;; Consume all the input since the only time we can
+                       ;; report the error is after everything has been
+                       ;; consumed.
+                       (consume-input (current-input-port))
+                       (list 'protocol-error (nix-protocol-error-message c))))
+              (with-store store
+                (setvbuf (current-input-port) _IONBF)
+                (import-paths store (current-input-port))
+                '(success))))
+          (lambda args
+            (cons 'error args))))))
 
-  (open-remote-output-pipe session
-                           (string-join
-                            `("guile" "-c"
-                              ,(object->string
-                                (object->string import))))))
+  (open-remote-pipe session
+                    (string-join
+                     `("guile" "-c"
+                       ,(object->string (object->string import))))
+                    OPEN_BOTH))
 
 (define* (store-export-channel session files
                                #:key recursive?)
@@ -224,10 +245,29 @@ Return the list of store items actually sent."
     ;; mark of 'export-paths' would be enough, but in practice it's not.)
     (channel-send-eof port)
 
-    ;; Wait for completion of the remote process.
-    (let ((result (zero? (channel-get-exit-status port))))
+    ;; Wait for completion of the remote process and read the status sexp from
+    ;; PORT.
+    (let* ((result (false-if-exception (read port)))
+           (status (zero? (channel-get-exit-status port))))
       (close-port port)
-      missing)))
+      (match result
+        (('success . _)
+         missing)
+        (('protocol-error message)
+         (raise (condition
+                 (&nix-protocol-error (message message) (status 42)))))
+        (('error key args ...)
+         (raise (condition
+                 (&nix-protocol-error
+                  (message (call-with-output-string
+                             (lambda (port)
+                               (print-exception port #f key args))))
+                  (status 43)))))
+        (_
+         (raise (condition
+                 (&nix-protocol-error
+                  (message "unknown error while sending files over SSH")
+                  (status 44)))))))))
 
 (define (remote-store-session remote)
   "Return the SSH channel beneath REMOTE, a remote store as returned by