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.
This commit is contained in:
parent
fb976ada5b
commit
de9d8f0e29
64
guix/ssh.scm
64
guix/ssh.scm
|
@ -150,23 +150,44 @@ can be written."
|
||||||
;; makes a round trip every time 32 KiB have been transferred. This
|
;; makes a round trip every time 32 KiB have been transferred. This
|
||||||
;; procedure instead opens a separate channel to use the remote
|
;; procedure instead opens a separate channel to use the remote
|
||||||
;; 'import-paths' procedure, which consumes all the data in a single round
|
;; '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
|
(define import
|
||||||
`(begin
|
`(begin
|
||||||
(use-modules (guix))
|
(use-modules (guix) (srfi srfi-34)
|
||||||
|
(rnrs io ports) (rnrs bytevectors))
|
||||||
|
|
||||||
|
(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))))))
|
||||||
|
|
||||||
|
;; 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
|
(with-store store
|
||||||
(setvbuf (current-input-port) _IONBF)
|
(setvbuf (current-input-port) _IONBF)
|
||||||
|
(import-paths store (current-input-port))
|
||||||
|
'(success))))
|
||||||
|
(lambda args
|
||||||
|
(cons 'error args))))))
|
||||||
|
|
||||||
;; FIXME: Exceptions are silently swallowed. We should report them
|
(open-remote-pipe session
|
||||||
;; somehow.
|
|
||||||
(import-paths store (current-input-port)))))
|
|
||||||
|
|
||||||
(open-remote-output-pipe session
|
|
||||||
(string-join
|
(string-join
|
||||||
`("guile" "-c"
|
`("guile" "-c"
|
||||||
,(object->string
|
,(object->string (object->string import))))
|
||||||
(object->string import))))))
|
OPEN_BOTH))
|
||||||
|
|
||||||
(define* (store-export-channel session files
|
(define* (store-export-channel session files
|
||||||
#:key recursive?)
|
#: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.)
|
;; mark of 'export-paths' would be enough, but in practice it's not.)
|
||||||
(channel-send-eof port)
|
(channel-send-eof port)
|
||||||
|
|
||||||
;; Wait for completion of the remote process.
|
;; Wait for completion of the remote process and read the status sexp from
|
||||||
(let ((result (zero? (channel-get-exit-status port))))
|
;; PORT.
|
||||||
|
(let* ((result (false-if-exception (read port)))
|
||||||
|
(status (zero? (channel-get-exit-status port))))
|
||||||
(close-port 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)
|
(define (remote-store-session remote)
|
||||||
"Return the SSH channel beneath REMOTE, a remote store as returned by
|
"Return the SSH channel beneath REMOTE, a remote store as returned by
|
||||||
|
|
Loading…
Reference in New Issue