rfc.tls - Fix mbed_write for large data

shirok · Dec 30, 2023 · d88ce9b · d88ce9b
1 parent e8fa665
commit d88ce9b
Show file tree

Hide file tree

Showing 3 changed files with 42 additions and 10 deletions.
diff --git a/ChangeLog b/ChangeLog
@@ -1,3 +1,9 @@
+2023-12-29  Shiro Kawai  <[email protected]>
+
+	* ext/tls/tls-mbed.c (mbed_write): If the data is big, single
+	  mbedtls_ssl_write may return with partial write, so we need
+	  to retry to send the rest of the data.
+
 2023-12-28  Shiro Kawai  <[email protected]>
 
 	* 0.9.14_pre1.  Preparing another release to make TLS addition

diff --git a/ext/tls/test.scm b/ext/tls/test.scm
@@ -20,10 +20,14 @@
   (define (make-server-thread-1 bound-tls)
     (^[]
       (guard (e [else (report-error e) #f])
-        (let* ([clnt (tls-accept bound-tls)]
-               [line (read-line (tls-input-port clnt))])
-          (display #"OK:~|line|\r\n" (tls-output-port clnt))
-          (tls-close clnt)))))
+        (let loop ()
+          (let* ([clnt (tls-accept bound-tls)]
+                 [line (read-line (tls-input-port clnt))])
+            (unless (equal? line "")
+              (display #"OK:~|line|\r\n" (tls-output-port clnt))
+              (tls-close clnt)
+              (loop)))))
+      'bye))
 
   (define (datafile filename)
     (build-path 'cld "data" filename))
@@ -57,7 +61,26 @@
                            (flush (tls-output-port clnt))
                            (read-line (tls-input-port clnt)))
                        (tls-close clnt)))))
-          (thread-join! serv-thread)
+          (test* "connect (big packet)" (+ 3 65536)
+                 (parameterize ((tls-ca-bundle-path (datafile "test-cert.pem")))
+                   (let1 clnt (make <mbed-tls> :server-name "localhost")
+                     (unwind-protect
+                         (begin
+                           (tls-connect clnt "localhost" serv-port)
+                           (display (string-append (make-string 65536 #\.)
+                                                   "\r\n")
+                                    (tls-output-port clnt))
+                           (flush (tls-output-port clnt))
+                           (string-length (read-line (tls-input-port clnt))))
+                       (tls-close clnt)))))
+          (test* "server shutdown" 'bye
+                 (parameterize ((tls-ca-bundle-path (datafile "test-cert.pem")))
+                   (let1 clnt (make <mbed-tls> :server-name "localhost")
+                     (tls-connect clnt "localhost" serv-port)
+                     (display "\r\n" (tls-output-port clnt))
+                     (flush (tls-output-port clnt))
+                     (tls-close clnt)
+                     (thread-join! serv-thread))))
           )
       (tls-close serv)))
 

diff --git a/ext/tls/tls-mbed.c b/ext/tls/tls-mbed.c
@@ -313,9 +313,8 @@ static ScmObj mbed_read(ScmTLS *tls)
     mbed_context_check(t, "read");
     mbed_close_check(t, "read");
     uint8_t buf[1024] = {};
-    int r;
-    r = mbedtls_ssl_read(&t->ctx, buf, sizeof(buf));
 
+    int r = mbedtls_ssl_read(&t->ctx, buf, sizeof(buf));
     if (r == MBEDTLS_ERR_SSL_PEER_CLOSE_NOTIFY) return SCM_EOF;
     if (r < 0) mbed_error("mbedtls_ssl_read() failed: %s (%d)", r);
 
@@ -335,9 +334,13 @@ static ScmObj mbed_write(ScmTLS *tls, ScmObj msg)
     if (cmsg == NULL) {
         Scm_TypeError("TLS message", "uniform vector or string", msg);
     }
-    int r = mbedtls_ssl_write(&t->ctx, cmsg, size);
-    if (r < 0) mbed_error("mbedtls_ssl_write() failed: %s (%d)", r);
-    return SCM_MAKE_INT(r);
+    int nsent = 0;
+    do {
+        int r = mbedtls_ssl_write(&t->ctx, cmsg+nsent, size-nsent);
+        if (r < 0) mbed_error("mbedtls_ssl_write() failed: %s (%d)", r);
+        nsent += r;
+    } while (nsent < size);
+    return SCM_MAKE_INT(nsent);
 }
 
 static u_long mbed_poll(ScmTLS *tls, u_long rwflags, ScmTimeSpec *timeout)