From 17af5d51de7c40756a4a39d336f81681de2ba447 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 10 Jan 2018 17:52:23 +0100 Subject: ssh: Work around 'get-bytevector-some' bug. This works around 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'. --- guix/ssh.scm | 33 +++++++++++++++++++++++---------- 1 file changed, 23 insertions(+), 10 deletions(-) (limited to 'guix/ssh.scm') 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 . + ;; 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))))))) -- cgit v1.2.3