summaryrefslogtreecommitdiff
path: root/guix
diff options
context:
space:
mode:
authorLudovic Courtès <ludo@gnu.org>2018-01-10 17:52:23 +0100
committerLudovic Courtès <ludo@gnu.org>2018-01-11 00:00:02 +0100
commit17af5d51de7c40756a4a39d336f81681de2ba447 (patch)
tree0266b933a2b68e79b780935e52e50869695ff470 /guix
parent74a235525410083bf02d3f3e495eca9adb0db2c8 (diff)
downloadgnu-guix-17af5d51de7c40756a4a39d336f81681de2ba447.tar
gnu-guix-17af5d51de7c40756a4a39d336f81681de2ba447.tar.gz
ssh: Work around 'get-bytevector-some' bug.
This works around <https://bugs.gnu.org/30066> and noticeably improves performance when using GUIX_DAEMON_SOCKET=ssh://HOST (the redirect code was transferring data to guix-daemon one byte at a time!). * guix/ssh.scm (remote-daemon-channel)[redirect]: Define 'read!' and use it instead of 'get-bytevector-some'.
Diffstat (limited to 'guix')
-rw-r--r--guix/ssh.scm33
1 files changed, 23 insertions, 10 deletions
diff --git a/guix/ssh.scm b/guix/ssh.scm
index 469f4fa6c1..96e4af9179 100644
--- a/guix/ssh.scm
+++ b/guix/ssh.scm
@@ -101,11 +101,24 @@ 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)
@@ -114,17 +127,17 @@ Throw an error on failure."
(match (select (list stdin sock) '() (list stdin stdout sock))
((reads writes ())
(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)))))))