02/07: ssh: Improve error reporting when retrieving files.

[Ludovic Courtès]

civodul pushed a commit to branch master
in repository guix.

commit 896fec476f728183b331cbb6e2afb891207b4205
Author: Ludovic Courtès <address@hidden>
Date:   Sun Jan 7 22:13:45 2018 +0100

    ssh: Improve error reporting when retrieving files.
    
    'guix copy --from' now reports messages much more useful than "failed to
    retrieve files".
    
    * guix/ssh.scm (store-export-channel)[export]: Wrap 'use-modules' in
    'catch' and 'with-store' in 'guard'.  Check for invalid items.  Write a
    status sexp on stdout.
    (raise-error): New macro.
    (retrieve-files): Read the initial status sexp and report errors
    accordingly.
---
 guix/ssh.scm | 109 +++++++++++++++++++++++++++++++++++++++++++++--------------
 1 file changed, 83 insertions(+), 26 deletions(-)

diff --git a/guix/ssh.scm b/guix/ssh.scm
index 7b33ef5..469f4fa 100644
--- a/guix/ssh.scm
+++ b/guix/ssh.scm
@@ -19,6 +19,7 @@
 (define-module (guix ssh)
   #:use-module (guix store)
   #:use-module (guix i18n)
+  #:use-module ((guix utils) #:select (&fix-hint))
   #:use-module (ssh session)
   #:use-module (ssh auth)
   #:use-module (ssh key)
@@ -197,15 +198,36 @@ be read.  When RECURSIVE? is true, the closure of FILES 
is exported."
   ;; remote store.
   (define export
     `(begin
-       (use-modules (guix))
-
-       (with-store store
-         (setvbuf (current-output-port) _IONBF)
-
-         ;; FIXME: Exceptions are silently swallowed.  We should report them
-         ;; somehow.
-         (export-paths store ',files (current-output-port)
-                       #:recursive? ,recursive?))))
+       (eval-when (load expand eval)
+         (unless (resolve-module '(guix) #:ensure #f)
+           (write `(module-error))
+           (exit 7)))
+
+       (use-modules (guix) (srfi srfi-1)
+                    (srfi srfi-26) (srfi srfi-34))
+
+       (guard (c ((nix-connection-error? c)
+                  (write `(connection-error ,(nix-connection-error-file c)
+                                            ,(nix-connection-error-code c))))
+                 ((nix-protocol-error? c)
+                  (write `(protocol-error ,(nix-protocol-error-status c)
+                                          ,(nix-protocol-error-message c))))
+                 (else
+                  (write `(exception))))
+         (with-store store
+           (let* ((files ',files)
+                  (invalid (remove (cut valid-path? store <>)
+                                   files)))
+             (unless (null? invalid)
+               (write `(invalid-items ,invalid))
+               (exit 1))
+
+             (write '(exporting))                 ;we're ready
+             (force-output)
+
+             (setvbuf (current-output-port) _IONBF)
+             (export-paths store files (current-output-port)
+                           #:recursive? ,recursive?))))))
 
   (open-remote-input-pipe session
                           (string-join
@@ -291,6 +313,19 @@ to the length of FILES.)"
                                 #:recursive? recursive?)
           (length files)))            ;XXX: inaccurate when RECURSIVE? is true
 
+(define-syntax raise-error
+  (syntax-rules (=>)
+    ((_ fmt args ... (=> hint-fmt hint-args ...))
+     (raise (condition
+             (&message
+              (message (format #f fmt args ...)))
+             (&fix-hint
+              (hint (format #f hint-fmt hint-args ...))))))
+    ((_ fmt args ...)
+     (raise (condition
+             (&message
+              (message (format #f fmt args ...))))))))
+
 (define* (retrieve-files local files remote
                          #:key recursive? (log-port (current-error-port)))
   "Retrieve FILES from REMOTE and import them using the 'import-paths' RPC on
@@ -298,22 +333,44 @@ LOCAL.  When RECURSIVE? is true, retrieve the closure of 
FILES."
   (let-values (((port count)
                 (file-retrieval-port files remote
                                      #:recursive? recursive?)))
-    (format #t (N_ "retrieving ~a store item from '~a'...~%"
-                   "retrieving ~a store items from '~a'...~%" count)
-            count (remote-store-host remote))
-    (when (eof-object? (lookahead-u8 port))
-      ;; The failure could be because one of the requested store items is not
-      ;; valid on REMOTE, or because Guile or Guix is improperly installed.
-      ;; TODO: Improve error reporting.
-      (raise (condition
-              (&message
-               (message
-                (format #f
-                        (G_ "failed to retrieve store items from '~a'")
-                        (remote-store-host remote)))))))
-
-    (let ((result (import-paths local port)))
-      (close-port port)
-      result)))
+    (match (read port)                            ;read the initial status
+      (('exporting)
+       (format #t (N_ "retrieving ~a store item from '~a'...~%"
+                      "retrieving ~a store items from '~a'...~%" count)
+               count (remote-store-host remote))
+
+       (let ((result (import-paths local port)))
+         (close-port port)
+         result))
+      ((? eof-object?)
+       (raise-error (G_ "failed to start Guile on remote host '~A': exit code 
~A")
+                    (remote-store-host remote)
+                    (channel-get-exit-status port)
+                    (=> (G_ "Make sure @command{guile} can be found in
address@hidden on the remote host.  Run @command{ssh ~A guile --version} to
+check.")
+                        (remote-store-host remote))))
+      (('module-error . _)
+       ;; TRANSLATORS: Leave "Guile" untranslated.
+       (raise-error (G_ "Guile modules not found on remote host '~A'")
+                    (remote-store-host remote)
+                    (=> (G_ "Make sure @code{GUILE_LOAD_PATH} includes Guix'
+own module directory.  Run @command{ssh ~A env | grep GUILE_LOAD_PATH} to
+check.")
+                        (remote-store-host remote))))
+      (('connection-error file code . _)
+       (raise-error (G_ "failed to connect to '~A' on remote host '~A': ~a")
+                    file (remote-store-host remote) (strerror code)))
+      (('invalid-items items . _)
+       (raise-error (N_ "no such item on remote host '~A':~{ ~a~}"
+                        "no such items on remote host '~A':~{ ~a~}"
+                        (length items))
+                    (remote-store-host remote) items))
+      (('protocol-error status message . _)
+       (raise-error (G_ "protocol error on remote host '~A': ~a")
+                    (remote-store-host remote) message))
+      (_
+       (raise-error (G_ "failed to retrieve store items from '~a'")
+                    (remote-store-host remote))))))
 
 ;;; ssh.scm ends here