summaryrefslogtreecommitdiff
path: root/guix/ssh.scm
diff options
context:
space:
mode:
Diffstat (limited to 'guix/ssh.scm')
-rw-r--r--guix/ssh.scm146
1 files changed, 108 insertions, 38 deletions
diff --git a/guix/ssh.scm b/guix/ssh.scm
index 7b33ef5a3b..cb560c0e9c 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)
@@ -100,30 +101,43 @@ Throw an error on failure."
;; Unix-domain sockets but libssh doesn't have an API for that, hence this
;; hack.
`(begin
- (use-modules (ice-9 match) (rnrs io ports))
+ (use-modules (ice-9 match) (rnrs io ports)
+ (rnrs bytevectors) (system foreign))
+
+ (define read!
+ ;; XXX: We would use 'get-bytevector-some' but it always returns a
+ ;; single byte in Guile <= 2.2.3---see <https://bugs.gnu.org/30066>.
+ ;; This procedure works around it.
+ (let ((proc (pointer->procedure int
+ (dynamic-func "read" (dynamic-link))
+ (list int '* size_t))))
+ (lambda (port bv)
+ (proc (fileno port) (bytevector->pointer bv)
+ (bytevector-length bv)))))
(let ((sock (socket AF_UNIX SOCK_STREAM 0))
(stdin (current-input-port))
- (stdout (current-output-port)))
+ (stdout (current-output-port))
+ (buffer (make-bytevector 65536)))
(setvbuf stdin _IONBF)
(setvbuf stdout _IONBF)
(connect sock AF_UNIX ,socket-name)
(let loop ()
- (match (select (list stdin sock) '() (list stdin stdout sock))
- ((reads writes ())
+ (match (select (list stdin sock) '() '())
+ ((reads () ())
(when (memq stdin reads)
- (match (get-bytevector-some stdin)
- ((? eof-object?)
+ (match (read! stdin buffer)
+ ((? zero?) ;EOF
(primitive-exit 0))
- (bv
- (put-bytevector sock bv))))
+ (count
+ (put-bytevector sock buffer 0 count))))
(when (memq sock reads)
- (match (get-bytevector-some sock)
- ((? eof-object?)
+ (match (read! sock buffer)
+ ((? zero?) ;EOF
(primitive-exit 0))
- (bv
- (put-bytevector stdout bv))))
+ (count
+ (put-bytevector stdout buffer 0 count))))
(loop))
(_
(primitive-exit 1)))))))
@@ -197,15 +211,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 +326,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 +346,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
+@code{$PATH} 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