Patch of openssl pasted by LemonBoy on Thu Aug 24 23:09:10 2017
diff --git a/openssl.scm b/openssl.scm index 0c8819d..2f92125 100644 --- a/openssl.scm +++ b/openssl.scm @@ -276,6 +276,17 @@ EOF (ssl-result-or-abort 'ssl-shutdown ssl ret #t) ret))) +(define (ssl-read! ssl buffer offset size) + (ssl-clear-error) + (let ((ret + ((foreign-lambda* + scheme-object ((c-pointer ssl) (scheme-pointer buf) (int offset) (int size)) + "return(C_fix(SSL_read((SSL *)ssl, (char *)buf + offset, size)));\n") + ssl buffer offset size))) + (if (fx< ret 0) + (ssl-result-or-abort 'ssl-read! ssl ret #t) + ret))) + (define (ssl-get-char ssl) (ssl-clear-error) (let ((ret @@ -294,6 +305,24 @@ EOF (ssl-result-or-abort 'ssl-get-char ssl ret #t) ret))) +(define (ssl-peek-char ssl) + (ssl-clear-error) + (let ((ret + ((foreign-lambda* + scheme-object ((c-pointer ssl)) + "unsigned char ch;\n" + "int ret;\n" + "switch (ret = SSL_peek((SSL *)ssl, &ch, 1)) {\n" + "case 0: return(SSL_get_error((SSL *)ssl, 0) == SSL_ERROR_ZERO_RETURN ?\n" + " C_SCHEME_END_OF_FILE : C_fix(0));\n" + "case 1: return(C_make_character(ch));\n" + "default: return(C_fix(ret));\n" + "}\n") + ssl))) + (if (fixnum? ret) + (ssl-result-or-abort 'ssl-peek-char ssl ret #t) + ret))) + (define (ssl-write ssl buffer offset size) (ssl-clear-error) (ssl-result-or-abort @@ -429,27 +458,19 @@ EOF ;; read (lambda () (startup) - (unless buffer - (set! buffer - (ssl-call/timeout 'ssl-get-char - (lambda () (ssl-get-char ssl)) - fd (tcp-read-timeout) - "SSL read timed out"))) - (let ((ch buffer)) - (unless (eof-object? buffer) - (set! buffer #f)) - ch)) + (ssl-call/timeout 'ssl-get-char + (lambda () (ssl-get-char ssl)) + fd (tcp-read-timeout) + "SSL read timed out")) ;; ready? (lambda () (startup) - (or buffer - (let ((ret (ssl-get-char ssl))) - (case ret - ((want-read want-write) - #f) - (else - (set! buffer ret) - #t))))) + (let ((ret (ssl-peek-char ssl))) + (case ret + ((want-read want-write) + #f) + (else + #t)))) ;; close (lambda () (when (startup #t) @@ -458,12 +479,18 @@ EOF ;; peek (lambda () (startup) - (unless buffer - (set! buffer (ssl-call/timeout 'ssl-peek-char - (lambda () (ssl-get-char ssl)) - fd (tcp-read-timeout) - "SSL read timed out"))) - buffer)))) + (ssl-call/timeout 'ssl-peek-char + (lambda () (ssl-peek-char ssl)) + fd (tcp-read-timeout) + "SSL read timed out")) + ;; read-string! + (lambda (port size buf offset) + (startup) + (ssl-call/timeout 'ssl-read! + (lambda () (ssl-read! ssl buf offset size)) + fd (tcp-read-timeout) + "SSL read timed out")) + ))) (out (let* ((outbufmax (tcp-buffer-size)) (outbuf (and outbufmax (fx> outbufmax 0) (make-string outbufmax)))
v2 pasted by LemonBoy on Fri Aug 25 14:04:45 2017
diff --git a/openssl.scm b/openssl.scm index 0c8819d..d276801 100644 --- a/openssl.scm +++ b/openssl.scm @@ -276,6 +276,22 @@ EOF (ssl-result-or-abort 'ssl-shutdown ssl ret #t) ret))) +(define (ssl-read! ssl buffer offset size) + (ssl-clear-error) + (let ((ret + ((foreign-lambda* + scheme-object ((c-pointer ssl) (scheme-pointer buf) (int offset) (int size)) + "int ret;\n" + "switch (ret = SSL_read((SSL *)ssl, (char *)buf + offset, size)) {\n" + "case 0: return(SSL_get_error((SSL *)ssl, 0) == SSL_ERROR_ZERO_RETURN ?\n" + " C_SCHEME_END_OF_FILE : C_fix(0));\n" + "default: return(C_fix(ret));\n" + "}\n") + ssl buffer offset size))) + (cond ((eof-object? ret) 0) + ((fx> ret 0) ret) + (else (ssl-result-or-abort 'ssl-read! ssl ret #t))))) + (define (ssl-get-char ssl) (ssl-clear-error) (let ((ret @@ -294,6 +310,24 @@ EOF (ssl-result-or-abort 'ssl-get-char ssl ret #t) ret))) +(define (ssl-peek-char ssl) + (ssl-clear-error) + (let ((ret + ((foreign-lambda* + scheme-object ((c-pointer ssl)) + "unsigned char ch;\n" + "int ret;\n" + "switch (ret = SSL_peek((SSL *)ssl, &ch, 1)) {\n" + "case 0: return(SSL_get_error((SSL *)ssl, 0) == SSL_ERROR_ZERO_RETURN ?\n" + " C_SCHEME_END_OF_FILE : C_fix(0));\n" + "case 1: return(C_make_character(ch));\n" + "default: return(C_fix(ret));\n" + "}\n") + ssl))) + (if (fixnum? ret) + (ssl-result-or-abort 'ssl-peek-char ssl ret #t) + ret))) + (define (ssl-write ssl buffer offset size) (ssl-clear-error) (ssl-result-or-abort @@ -429,27 +463,19 @@ EOF ;; read (lambda () (startup) - (unless buffer - (set! buffer - (ssl-call/timeout 'ssl-get-char - (lambda () (ssl-get-char ssl)) - fd (tcp-read-timeout) - "SSL read timed out"))) - (let ((ch buffer)) - (unless (eof-object? buffer) - (set! buffer #f)) - ch)) + (ssl-call/timeout 'ssl-get-char + (lambda () (ssl-get-char ssl)) + fd (tcp-read-timeout) + "SSL read timed out")) ;; ready? (lambda () (startup) - (or buffer - (let ((ret (ssl-get-char ssl))) - (case ret - ((want-read want-write) - #f) - (else - (set! buffer ret) - #t))))) + (let ((ret (ssl-peek-char ssl))) + (case ret + ((want-read want-write) + #f) + (else + #t)))) ;; close (lambda () (when (startup #t) @@ -458,12 +484,17 @@ EOF ;; peek (lambda () (startup) - (unless buffer - (set! buffer (ssl-call/timeout 'ssl-peek-char - (lambda () (ssl-get-char ssl)) - fd (tcp-read-timeout) - "SSL read timed out"))) - buffer)))) + (ssl-call/timeout 'ssl-peek-char + (lambda () (ssl-peek-char ssl)) + fd (tcp-read-timeout) + "SSL read timed out")) + ;; read-string! + (lambda (port size buf offset) + (startup) + (ssl-call/timeout 'ssl-read! + (lambda () (ssl-read! ssl buf offset size)) + fd (tcp-read-timeout) + "SSL read timed out"))))) (out (let* ((outbufmax (tcp-buffer-size)) (outbuf (and outbufmax (fx> outbufmax 0) (make-string outbufmax)))
v3 added by LemonBoy on Sun Aug 27 16:48:37 2017
diff --git a/openssl.scm b/openssl.scm index 0c8819d..56c1e74 100644 --- a/openssl.scm +++ b/openssl.scm @@ -276,6 +276,22 @@ EOF (ssl-result-or-abort 'ssl-shutdown ssl ret #t) ret))) +(define (ssl-read! ssl buffer offset size) + (ssl-clear-error) + (let ((ret + ((foreign-lambda* + scheme-object ((c-pointer ssl) (scheme-pointer buf) (int offset) (int size)) + "int ret;\n" + "switch (ret = SSL_read((SSL *)ssl, (char *)buf + offset, size)) {\n" + "case 0: return(SSL_get_error((SSL *)ssl, 0) == SSL_ERROR_ZERO_RETURN ?\n" + " C_SCHEME_END_OF_FILE : C_fix(0));\n" + "default: return(C_fix(ret));\n" + "}\n") + ssl buffer offset size))) + (cond ((eof-object? ret) 0) + ((fx> ret 0) ret) + (else (ssl-result-or-abort 'ssl-read! ssl ret #t))))) + (define (ssl-get-char ssl) (ssl-clear-error) (let ((ret @@ -294,6 +310,24 @@ EOF (ssl-result-or-abort 'ssl-get-char ssl ret #t) ret))) +(define (ssl-peek-char ssl) + (ssl-clear-error) + (let ((ret + ((foreign-lambda* + scheme-object ((c-pointer ssl)) + "unsigned char ch;\n" + "int ret;\n" + "switch (ret = SSL_peek((SSL *)ssl, &ch, 1)) {\n" + "case 0: return(SSL_get_error((SSL *)ssl, 0) == SSL_ERROR_ZERO_RETURN ?\n" + " C_SCHEME_END_OF_FILE : C_fix(0));\n" + "case 1: return(C_make_character(ch));\n" + "default: return(C_fix(ret));\n" + "}\n") + ssl))) + (if (fixnum? ret) + (ssl-result-or-abort 'ssl-peek-char ssl ret #t) + ret))) + (define (ssl-write ssl buffer offset size) (ssl-clear-error) (ssl-result-or-abort @@ -424,46 +458,42 @@ EOF (ssl-free ssl) (net-close-socket fd))))) (let ((in - (let ((buffer #f)) - (make-input-port + (make-input-port ;; read (lambda () - (startup) - (unless buffer - (set! buffer - (ssl-call/timeout 'ssl-get-char - (lambda () (ssl-get-char ssl)) - fd (tcp-read-timeout) - "SSL read timed out"))) - (let ((ch buffer)) - (unless (eof-object? buffer) - (set! buffer #f)) - ch)) + (startup) + (ssl-call/timeout 'ssl-get-char + (lambda () (ssl-get-char ssl)) + fd (tcp-read-timeout) + "SSL read timed out")) ;; ready? (lambda () - (startup) - (or buffer - (let ((ret (ssl-get-char ssl))) - (case ret - ((want-read want-write) - #f) - (else - (set! buffer ret) - #t))))) + (startup) + (let ((ret (ssl-peek-char ssl))) + (case ret + ((want-read want-write) + #f) + (else + #t)))) ;; close (lambda () - (when (startup #t) - (set! in-open? #f) - (shutdown))) + (when (startup #t) + (set! in-open? #f) + (shutdown))) ;; peek (lambda () - (startup) - (unless buffer - (set! buffer (ssl-call/timeout 'ssl-peek-char - (lambda () (ssl-get-char ssl)) - fd (tcp-read-timeout) - "SSL read timed out"))) - buffer)))) + (startup) + (ssl-call/timeout 'ssl-peek-char + (lambda () (ssl-peek-char ssl)) + fd (tcp-read-timeout) + "SSL read timed out")) + ;; read-string! + (lambda (port size buf offset) + (startup) + (ssl-call/timeout 'ssl-read! + (lambda () (ssl-read! ssl buf offset size)) + fd (tcp-read-timeout) + "SSL read timed out")))) (out (let* ((outbufmax (tcp-buffer-size)) (outbuf (and outbufmax (fx> outbufmax 0) (make-string outbufmax)))