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
70
guix/ssh.scm
70
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
|
||||
|
|
Loading…
Reference in New Issue