Hi there,
I've attached a small patch for the openssl egg that adds another error status.
This status is 'ssl-eof when the error is SSL_ERR_SYSCALL but the return code
is zero.
According to the OpenSSL docs[1] under the BUGS section:
> The SSL_ERROR_SYSCALL eith errno value of 0 indicates unexpected EOF from the
> peer.
> This will be properly reported as SSL_ERROR_SSL with reason code
> SSL_R_UNEXPECTED_EOF_WHILE_READING in the OpenSSL 3.0 release because it is
> truly a
> TLS protocol error to terminate the connection without a SSL_shutdown().
>
> The issue is kept unfixed in OpenSSL 1.1.1 releases because many applications
> which
> choose to ignore this protocol error depend on the existing way of reporting
> the error.
Basically this gives the user the option to treat it is as an !#eof instead of
a fatal error.
I've been running into this issue while building a Gemini[2] client where there
are a
plethora of servers written by hobbyists. Also, the protocol does not have a
Content-Length header,
which means I can't avoid this issue by simply not reading past the end.
- Harley
[1] https://www.openssl.org/docs/man1.1.1/man3/SSL_get_error.html
[2] https://gemini.circumlunar.space/docs/specification.html
Index: openssl.scm
===================================================================
--- openssl.scm (revision 39418)
+++ openssl.scm (working copy)
@@ -256,50 +256,50 @@
'want-accept)
((eq? x (foreign-value "SSL_ERROR_WANT_X509_LOOKUP" int))
'want-X509-lookup)
- ((eq? x (foreign-value "SSL_ERROR_SYSCALL" int))
- 'syscall)
- ((eq? x (foreign-value "SSL_ERROR_SSL" int))
+ ((eq? x (foreign-value "SSL_ERROR_SYSCALL" int))
+ (if (zero? ret) 'ssl-eof 'syscall))
+ ((eq? x (foreign-value "SSL_ERROR_SSL" int))
'ssl)
- (else
+ (else
#f)))))
(apply ssl-abort loc sym args)))))
-(define (ssl-set-tlsext-hostname! ssl hostname)
- (ssl-clear-error)
- (ssl-result-or-abort
- 'ssl-set-tlsext-hostname! ssl
- ((foreign-lambda int "SSL_set_tlsext_host_name" c-pointer c-string)
- ssl hostname) #f
- hostname)
- (void))
+ (define (ssl-set-tlsext-hostname! ssl hostname)
+ (ssl-clear-error)
+ (ssl-result-or-abort
+ 'ssl-set-tlsext-hostname! ssl
+ ((foreign-lambda int "SSL_set_tlsext_host_name" c-pointer c-string)
+ ssl hostname) #f
+ hostname)
+ (void))
-(define (ssl-set-fd! ssl fd)
- (ssl-clear-error)
- (ssl-result-or-abort
- 'ssl-set-fd! ssl
- ((foreign-lambda int "SSL_set_fd" c-pointer int) ssl fd) #f
- fd)
- (void))
+ (define (ssl-set-fd! ssl fd)
+ (ssl-clear-error)
+ (ssl-result-or-abort
+ 'ssl-set-fd! ssl
+ ((foreign-lambda int "SSL_set_fd" c-pointer int) ssl fd) #f
+ fd)
+ (void))
-(define (ssl-shutdown ssl)
- (ssl-clear-error)
- (let ((ret
- ((foreign-lambda*
- scheme-object ((c-pointer ssl))
- "int ret;\n"
- "switch (ret = SSL_shutdown((SSL *)ssl)) {\n"
- "case 0: return(C_SCHEME_FALSE);\n"
- "case 1: return(C_SCHEME_TRUE);\n"
- "default: return(C_fix(ret));\n"
- "}\n") ssl)))
- (if (fixnum? ret)
- (ssl-result-or-abort 'ssl-shutdown ssl ret #t)
- ret)))
+ (define (ssl-shutdown ssl)
+ (ssl-clear-error)
+ (let ((ret
+ ((foreign-lambda*
+ scheme-object ((c-pointer ssl))
+ "int ret;\n"
+ "switch (ret = SSL_shutdown((SSL *)ssl)) {\n"
+ "case 0: return(C_SCHEME_FALSE);\n"
+ "case 1: return(C_SCHEME_TRUE);\n"
+ "default: return(C_fix(ret));\n"
+ "}\n") ssl)))
+ (if (fixnum? ret)
+ (ssl-result-or-abort 'ssl-shutdown ssl ret #t)
+ ret)))
-(define (ssl-read! ssl buffer offset size)
- (ssl-clear-error)
- (let ((ret
- ((foreign-lambda*
+ (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"
@@ -307,178 +307,178 @@
" 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)))))
+ 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
- ((foreign-lambda*
- scheme-object ((c-pointer ssl))
- "unsigned char ch;\n"
- "int ret;\n"
- "switch (ret = SSL_read((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-get-char ssl ret #t)
- ret)))
+ (define (ssl-get-char ssl)
+ (ssl-clear-error)
+ (let ((ret
+ ((foreign-lambda*
+ scheme-object ((c-pointer ssl))
+ "unsigned char ch;\n"
+ "int ret;\n"
+ "switch (ret = SSL_read((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-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-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
- 'ssl-write ssl
- ((foreign-lambda*
- int ((c-pointer ssl) (scheme-pointer buf) (int offset) (int size))
- "return(SSL_write((SSL *)ssl, (char *)buf + offset, size));\n")
- ssl buffer offset size)
- #t))
+ (define (ssl-write ssl buffer offset size)
+ (ssl-clear-error)
+ (ssl-result-or-abort
+ 'ssl-write ssl
+ ((foreign-lambda*
+ int ((c-pointer ssl) (scheme-pointer buf) (int offset) (int size))
+ "return(SSL_write((SSL *)ssl, (char *)buf + offset, size));\n")
+ ssl buffer offset size)
+ #t))
-(define-record-type ssl-port-data
- (ssl-make-port-data startup ssl tcp-port)
- ssl-port-data?
- (startup ssl-port-data-startup)
- (ssl ssl-port-data-ssl)
- (tcp-port ssl-port-data-tcp-port))
+ (define-record-type ssl-port-data
+ (ssl-make-port-data startup ssl tcp-port)
+ ssl-port-data?
+ (startup ssl-port-data-startup)
+ (ssl ssl-port-data-ssl)
+ (tcp-port ssl-port-data-tcp-port))
-(define (ssl-port? obj)
- (and (port? obj) (eq? (##sys#slot obj 10) 'ssl-socket)))
+ (define (ssl-port? obj)
+ (and (port? obj) (eq? (##sys#slot obj 10) 'ssl-socket)))
-(define (ssl-port-startup p)
- (when (ssl-port? p)
- ((ssl-port-data-startup (##sys#slot p 11)))))
+ (define (ssl-port-startup p)
+ (when (ssl-port? p)
+ ((ssl-port-data-startup (##sys#slot p 11)))))
-(define (ssl-port->ssl p)
- (if (ssl-port? p)
- (ssl-port-data-ssl (##sys#slot p 11))
- (abort
- (make-composite-condition
- (make-property-condition
- 'exn
- 'location 'ssl-port->ssl-context
- 'message "expected an ssl port, got"
- 'arguments (list p))
- (make-property-condition
- 'type)))))
+ (define (ssl-port->ssl p)
+ (if (ssl-port? p)
+ (ssl-port-data-ssl (##sys#slot p 11))
+ (abort
+ (make-composite-condition
+ (make-property-condition
+ 'exn
+ 'location 'ssl-port->ssl-context
+ 'message "expected an ssl port, got"
+ 'arguments (list p))
+ (make-property-condition
+ 'type)))))
-(define (ssl-port->tcp-port p)
- (if (ssl-port? p)
- (ssl-port-data-tcp-port (##sys#slot p 11))
- (abort
- (make-composite-condition
- (make-property-condition
- 'exn
- 'location 'ssl-port->tcp-port
- 'message "expected an ssl port, got"
- 'arguments (list p))
- (make-property-condition
- 'type)))))
+ (define (ssl-port->tcp-port p)
+ (if (ssl-port? p)
+ (ssl-port-data-tcp-port (##sys#slot p 11))
+ (abort
+ (make-composite-condition
+ (make-property-condition
+ 'exn
+ 'location 'ssl-port->tcp-port
+ 'message "expected an ssl port, got"
+ 'arguments (list p))
+ (make-property-condition
+ 'type)))))
-(define (ssl-do-handshake ssl)
- (ssl-clear-error)
- (ssl-result-or-abort 'ssl-do-handshake ssl
- ((foreign-lambda int "SSL_do_handshake" c-pointer) ssl)
#t))
+ (define (ssl-do-handshake ssl)
+ (ssl-clear-error)
+ (ssl-result-or-abort 'ssl-do-handshake ssl
+ ((foreign-lambda int "SSL_do_handshake" c-pointer)
ssl) #t))
-(define (ssl-call/timeout loc proc fd timeout timeout-message)
- (let loop ((res (proc)))
- (case res
- ((want-read)
- (when timeout
- (##sys#thread-block-for-timeout!
- ##sys#current-thread (+ (current-milliseconds) timeout)))
- (##sys#thread-block-for-i/o! ##sys#current-thread fd #:input)
- (thread-yield!)
- (if (##sys#slot ##sys#current-thread 13)
- (##sys#signal-hook
- #:network-timeout-error loc timeout-message timeout fd)
- (loop (proc))))
- ((want-write)
- (when timeout
- (##sys#thread-block-for-timeout!
- ##sys#current-thread (+ (current-milliseconds) timeout)))
- (##sys#thread-block-for-i/o! ##sys#current-thread fd #:output)
- (thread-yield!)
- (if (##sys#slot ##sys#current-thread 13)
- (##sys#signal-hook
- #:network-timeout-error loc timeout-message timeout fd)
- (loop (proc))))
- (else res))))
+ (define (ssl-call/timeout loc proc fd timeout timeout-message)
+ (let loop ((res (proc)))
+ (case res
+ ((want-read)
+ (when timeout
+ (##sys#thread-block-for-timeout!
+ ##sys#current-thread (+ (current-milliseconds) timeout)))
+ (##sys#thread-block-for-i/o! ##sys#current-thread fd #:input)
+ (thread-yield!)
+ (if (##sys#slot ##sys#current-thread 13)
+ (##sys#signal-hook
+ #:network-timeout-error loc timeout-message timeout fd)
+ (loop (proc))))
+ ((want-write)
+ (when timeout
+ (##sys#thread-block-for-timeout!
+ ##sys#current-thread (+ (current-milliseconds) timeout)))
+ (##sys#thread-block-for-i/o! ##sys#current-thread fd #:output)
+ (thread-yield!)
+ (if (##sys#slot ##sys#current-thread 13)
+ (##sys#signal-hook
+ #:network-timeout-error loc timeout-message timeout fd)
+ (loop (proc))))
+ (else res))))
-(define (ssl-make-i/o-ports ctx fd ssl tcp-in tcp-out)
- ;; note that the ctx parameter is never used but it is passed in order
- ;; to be present in the closure data of the various port functions
- ;; so it isn't garbage collected before the ports are all gone
- (let ((in-open? #f) (out-open? #f)
- (mutex (make-mutex 'ssl-mutex)))
- (define (startup #!optional (called-from-close #f))
- (dynamic-wind+
- (lambda ()
- (mutex-lock! mutex))
- (lambda ()
+ (define (ssl-make-i/o-ports ctx fd ssl tcp-in tcp-out)
+ ;; note that the ctx parameter is never used but it is passed in order
+ ;; to be present in the closure data of the various port functions
+ ;; so it isn't garbage collected before the ports are all gone
+ (let ((in-open? #f) (out-open? #f)
+ (mutex (make-mutex 'ssl-mutex)))
+ (define (startup #!optional (called-from-close #f))
+ (dynamic-wind+
+ (lambda ()
+ (mutex-lock! mutex))
+ (lambda ()
(let ((skip-startup (not ssl)))
(if skip-startup
- (when (not called-from-close)
- (error "SSL socket already closed"))
- (unless (or in-open? out-open?)
- (let ((success? #f))
- (dynamic-wind+
- void
- (lambda ()
- (ssl-set-fd! ssl fd)
- (ssl-call/timeout 'ssl-do-handshake
- (lambda () (ssl-do-handshake ssl))
- fd (ssl-handshake-timeout)
- "SSL handshake operation timed out")
- (set! in-open? #t)
- (set! out-open? #t)
- (set! success? #t))
- (lambda ()
- (unless success?
- (ssl-free ssl)
- (set! ssl #f)
- (net-close-socket fd)))))))
+ (when (not called-from-close)
+ (error "SSL socket already closed"))
+ (unless (or in-open? out-open?)
+ (let ((success? #f))
+ (dynamic-wind+
+ void
+ (lambda ()
+ (ssl-set-fd! ssl fd)
+ (ssl-call/timeout 'ssl-do-handshake
+ (lambda () (ssl-do-handshake ssl))
+ fd (ssl-handshake-timeout)
+ "SSL handshake operation timed out")
+ (set! in-open? #t)
+ (set! out-open? #t)
+ (set! success? #t))
+ (lambda ()
+ (unless success?
+ (ssl-free ssl)
+ (set! ssl #f)
+ (net-close-socket fd)))))))
(not skip-startup)))
- (lambda ()
- (mutex-unlock! mutex))))
- (define (shutdown)
- (unless (or in-open? out-open?)
- (set! ctx #f) ;; ensure that this reference is lost
- (dynamic-wind+
- void
- (lambda ()
- (ssl-call/timeout 'ssl-shutdown
- (lambda () (ssl-shutdown ssl))
- fd (ssl-shutdown-timeout)
- "SSL shutdown operation timed out"))
- (lambda ()
- (ssl-free ssl)
- (net-close-socket fd)))))
- (let ((in
- (make-input-port
+ (lambda ()
+ (mutex-unlock! mutex))))
+ (define (shutdown)
+ (unless (or in-open? out-open?)
+ (set! ctx #f) ;; ensure that this reference is lost
+ (dynamic-wind+
+ void
+ (lambda ()
+ (ssl-call/timeout 'ssl-shutdown
+ (lambda () (ssl-shutdown ssl))
+ fd (ssl-shutdown-timeout)
+ "SSL shutdown operation timed out"))
+ (lambda ()
+ (ssl-free ssl)
+ (net-close-socket fd)))))
+ (let ((in
+ (make-input-port
;; read
(lambda ()
(startup)
@@ -494,7 +494,7 @@
((want-read want-write)
#f)
(else
- #t))))
+ #t))))
;; close
(lambda ()
(when (startup #t)
@@ -514,421 +514,421 @@
(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)))
- (outbufsize 0)
- (unbuffered-write
- (lambda (buffer #!optional (offset 0) (size (##sys#size buffer)))
- (when (> size 0) ; Undefined behaviour for 0 bytes!
- (let loop ((offset offset) (size size))
- (let ((ret (ssl-call/timeout
- 'ssl-write
- (lambda () (ssl-write ssl buffer offset size))
- fd (tcp-write-timeout) "SSL write timed out")))
- (when (fx< ret size) ; Partial write
- (loop (fx+ offset ret) (fx- size ret)))))))))
+ (out
+ (let* ((outbufmax (tcp-buffer-size))
+ (outbuf (and outbufmax (fx> outbufmax 0) (make-string
outbufmax)))
+ (outbufsize 0)
+ (unbuffered-write
+ (lambda (buffer #!optional (offset 0) (size (##sys#size
buffer)))
+ (when (> size 0) ; Undefined behaviour for 0 bytes!
+ (let loop ((offset offset) (size size))
+ (let ((ret (ssl-call/timeout
+ 'ssl-write
+ (lambda () (ssl-write ssl buffer offset
size))
+ fd (tcp-write-timeout) "SSL write timed
out")))
+ (when (fx< ret size) ; Partial write
+ (loop (fx+ offset ret) (fx- size ret)))))))))
- (define (buffered-write data #!optional (start 0))
- (let* ((size (- (##sys#size data) start))
- (to-copy (min (- outbufmax outbufsize) size))
- (left-over (- size to-copy)))
+ (define (buffered-write data #!optional (start 0))
+ (let* ((size (- (##sys#size data) start))
+ (to-copy (min (- outbufmax outbufsize) size))
+ (left-over (- size to-copy)))
- (string-copy! outbuf outbufsize data start (+ start to-copy))
- (set! outbufsize (+ outbufsize to-copy))
+ (string-copy! outbuf outbufsize data start (+ start to-copy))
+ (set! outbufsize (+ outbufsize to-copy))
- (if (= outbufsize outbufmax)
- (begin
- (unbuffered-write outbuf)
- (set! outbufsize 0)))
+ (if (= outbufsize outbufmax)
+ (begin
+ (unbuffered-write outbuf)
+ (set! outbufsize 0)))
- (if (> left-over 0)
- (buffered-write data (+ start to-copy)))))
+ (if (> left-over 0)
+ (buffered-write data (+ start to-copy)))))
- (make-output-port
- ;; write
- (lambda (buffer)
- (startup)
- (if outbuf
- (buffered-write buffer)
- (unbuffered-write buffer)))
- ;; close
- (lambda ()
- (when (startup #t)
- (dynamic-wind+
- void
- (lambda ()
- (when outbuf
- (unbuffered-write outbuf 0 outbufsize)
- (set! outbufsize 0)))
- (lambda ()
- (set! out-open? #f)
- (shutdown)))))
- ;; flush
- (lambda ()
- (when outbuf
- (startup)
- (unbuffered-write outbuf 0 outbufsize)
- (set! outbufsize 0)))))))
- (##sys#setslot in 3 "(ssl)")
- (##sys#setslot out 3 "(ssl)")
- ;; first "reserved" slot
- ;; Slot 7 should probably stay 'custom
- (##sys#setslot in 10 'ssl-socket)
- (##sys#setslot out 10 'ssl-socket)
- ;; second "reserved" slot
- (##sys#setslot in 11 (ssl-make-port-data startup ssl tcp-in))
- (##sys#setslot out 11 (ssl-make-port-data startup ssl tcp-out))
- (values in out))))
+ (make-output-port
+ ;; write
+ (lambda (buffer)
+ (startup)
+ (if outbuf
+ (buffered-write buffer)
+ (unbuffered-write buffer)))
+ ;; close
+ (lambda ()
+ (when (startup #t)
+ (dynamic-wind+
+ void
+ (lambda ()
+ (when outbuf
+ (unbuffered-write outbuf 0 outbufsize)
+ (set! outbufsize 0)))
+ (lambda ()
+ (set! out-open? #f)
+ (shutdown)))))
+ ;; flush
+ (lambda ()
+ (when outbuf
+ (startup)
+ (unbuffered-write outbuf 0 outbufsize)
+ (set! outbufsize 0)))))))
+ (##sys#setslot in 3 "(ssl)")
+ (##sys#setslot out 3 "(ssl)")
+ ;; first "reserved" slot
+ ;; Slot 7 should probably stay 'custom
+ (##sys#setslot in 10 'ssl-socket)
+ (##sys#setslot out 10 'ssl-socket)
+ ;; second "reserved" slot
+ (##sys#setslot in 11 (ssl-make-port-data startup ssl tcp-in))
+ (##sys#setslot out 11 (ssl-make-port-data startup ssl tcp-out))
+ (values in out))))
-(define (ssl-unwrap-context obj)
- (cond
- ((ssl-client-context? obj)
- (ssl-unwrap-client-context obj))
- ((ssl-listener? obj)
- (ssl-unwrap-listener-context obj))
- (else
- (abort
- (make-composite-condition
- (make-property-condition
- 'exn
- 'location 'ssl-unwrap-context
- 'message "expected an ssl-client-context or ssl-listener, got"
- 'arguments (list obj))
- (make-property-condition
- 'type))))))
+ (define (ssl-unwrap-context obj)
+ (cond
+ ((ssl-client-context? obj)
+ (ssl-unwrap-client-context obj))
+ ((ssl-listener? obj)
+ (ssl-unwrap-listener-context obj))
+ (else
+ (abort
+ (make-composite-condition
+ (make-property-condition
+ 'exn
+ 'location 'ssl-unwrap-context
+ 'message "expected an ssl-client-context or ssl-listener, got"
+ 'arguments (list obj))
+ (make-property-condition
+ 'type))))))
;;; exported routines
-;; create SSL client context
-(define-record-type ssl-client-context
- (ssl-wrap-client-context context)
- ssl-client-context?
- (context ssl-unwrap-client-context))
+ ;; create SSL client context
+ (define-record-type ssl-client-context
+ (ssl-wrap-client-context context)
+ ssl-client-context?
+ (context ssl-unwrap-client-context))
-(define (ssl-make-client-context #!optional (protocol 'tls))
- (ssl-wrap-client-context (ssl-ctx-new protocol #f)))
+ (define (ssl-make-client-context #!optional (protocol 'tls))
+ (ssl-wrap-client-context (ssl-ctx-new protocol #f)))
-(define ssl-set-connect-state! (foreign-lambda void "SSL_set_connect_state"
c-pointer))
+ (define ssl-set-connect-state! (foreign-lambda void "SSL_set_connect_state"
c-pointer))
-(define (symbolic-host? host port)
- (not (address-infos host #:port port #:type 'tcp #:server? #f #:numeric?
#t)))
+ (define (symbolic-host? host port)
+ (not (address-infos host #:port port #:type 'tcp #:server? #f #:numeric?
#t)))
-;; connect to SSL server
-(define (ssl-connect hostname #!optional port (ctx 'tls) sni-name)
- (let* ((ctx
- (if (ssl-client-context? ctx)
- (ssl-unwrap-client-context ctx)
- (ssl-ctx-new ctx #f)))
- (ssl (ssl-new ctx))
- (success? #f))
- (dynamic-wind+
- void
- (lambda ()
- (when (eq? sni-name #t)
- (set! sni-name
- (and
- (symbolic-host? hostname port)
- (let ((last (sub1 (string-length hostname))))
- (if (and (>= last 0) (eqv? (string-ref hostname last) #\.))
- (substring hostname 0 last)
- hostname)))))
- (when sni-name
- (ssl-set-tlsext-hostname! ssl sni-name))
- (ssl-set-connect-state! ssl)
- (receive (tcp-in tcp-out)
- (tcp-connect hostname port)
- (receive (ssl-in ssl-out)
- (ssl-make-i/o-ports ctx (net-unwrap-tcp-ports tcp-in tcp-out) ssl
tcp-in tcp-out)
- (set! success? #t)
- (values ssl-in ssl-out))))
- (lambda ()
- (unless success?
- (ssl-free ssl)
- (set! ssl #f))))))
+ ;; connect to SSL server
+ (define (ssl-connect hostname #!optional port (ctx 'tls) sni-name)
+ (let* ((ctx
+ (if (ssl-client-context? ctx)
+ (ssl-unwrap-client-context ctx)
+ (ssl-ctx-new ctx #f)))
+ (ssl (ssl-new ctx))
+ (success? #f))
+ (dynamic-wind+
+ void
+ (lambda ()
+ (when (eq? sni-name #t)
+ (set! sni-name
+ (and
+ (symbolic-host? hostname port)
+ (let ((last (sub1 (string-length hostname))))
+ (if (and (>= last 0) (eqv? (string-ref hostname last) #\.))
+ (substring hostname 0 last)
+ hostname)))))
+ (when sni-name
+ (ssl-set-tlsext-hostname! ssl sni-name))
+ (ssl-set-connect-state! ssl)
+ (receive (tcp-in tcp-out)
+ (tcp-connect hostname port)
+ (receive (ssl-in ssl-out)
+ (ssl-make-i/o-ports ctx (net-unwrap-tcp-ports tcp-in tcp-out)
ssl tcp-in tcp-out)
+ (set! success? #t)
+ (values ssl-in ssl-out))))
+ (lambda ()
+ (unless success?
+ (ssl-free ssl)
+ (set! ssl #f))))))
-;; create listener/SSL server context
-(define-record-type ssl-listener
- (ssl-wrap-listener context listener)
- ssl-listener?
- (context ssl-unwrap-listener-context)
- (listener ssl-unwrap-listener))
+ ;; create listener/SSL server context
+ (define-record-type ssl-listener
+ (ssl-wrap-listener context listener)
+ ssl-listener?
+ (context ssl-unwrap-listener-context)
+ (listener ssl-unwrap-listener))
-;; Import from tcp6 when available, otherwise fall back to the
-;; standard tcp library from CHICKEN core.
-(define-values (tcp-listen tcp-listener-fileno tcp-listener-port
- tcp-accept tcp-accept-ready? tcp-close
- tcp-abandon-port tcp-buffer-size tcp-connect
- tcp-read-timeout tcp-write-timeout)
- (handle-exceptions
- exn (let ()
- (import (chicken tcp))
- (values tcp-listen tcp-listener-fileno tcp-listener-port
- tcp-accept tcp-accept-ready? tcp-close
- tcp-abandon-port tcp-buffer-size tcp-connect
- tcp-read-timeout tcp-write-timeout))
- (eval '(let ()
- (import tcp6)
- (values tcp-listen tcp-listener-fileno tcp-listener-port
- tcp-accept tcp-accept-ready? tcp-close
- tcp-abandon-port tcp-buffer-size tcp-connect
- tcp-read-timeout tcp-write-timeout)))))
+ ;; Import from tcp6 when available, otherwise fall back to the
+ ;; standard tcp library from CHICKEN core.
+ (define-values (tcp-listen tcp-listener-fileno tcp-listener-port
+ tcp-accept tcp-accept-ready? tcp-close
+ tcp-abandon-port tcp-buffer-size tcp-connect
+ tcp-read-timeout tcp-write-timeout)
+ (handle-exceptions
+ exn (let ()
+ (import (chicken tcp))
+ (values tcp-listen tcp-listener-fileno tcp-listener-port
+ tcp-accept tcp-accept-ready? tcp-close
+ tcp-abandon-port tcp-buffer-size tcp-connect
+ tcp-read-timeout tcp-write-timeout))
+ (eval '(let ()
+ (import tcp6)
+ (values tcp-listen tcp-listener-fileno tcp-listener-port
+ tcp-accept tcp-accept-ready? tcp-close
+ tcp-abandon-port tcp-buffer-size tcp-connect
+ tcp-read-timeout tcp-write-timeout)))))
-(define (ssl-listen port #!optional (backlog 4) (hostname #f) (protocol 'tls))
- (ssl-wrap-listener
- (ssl-ctx-new protocol #t)
- (tcp-listen port backlog hostname)))
+ (define (ssl-listen port #!optional (backlog 4) (hostname #f) (protocol
'tls))
+ (ssl-wrap-listener
+ (ssl-ctx-new protocol #t)
+ (tcp-listen port backlog hostname)))
-;; shutdown a SSL server
-(define (ssl-close listener)
- (tcp-close (ssl-unwrap-listener listener)))
+ ;; shutdown a SSL server
+ (define (ssl-close listener)
+ (tcp-close (ssl-unwrap-listener listener)))
-;; return the port number this listener is operating on
-(define (ssl-listener-port listener)
- (tcp-listener-port (ssl-unwrap-listener listener)))
+ ;; return the port number this listener is operating on
+ (define (ssl-listener-port listener)
+ (tcp-listener-port (ssl-unwrap-listener listener)))
-;; get the underlying socket descriptor number for an SSL listener
-(define (ssl-listener-fileno listener)
- (tcp-listener-fileno (ssl-unwrap-listener listener)))
+ ;; get the underlying socket descriptor number for an SSL listener
+ (define (ssl-listener-fileno listener)
+ (tcp-listener-fileno (ssl-unwrap-listener listener)))
-;; check whether an incoming connection is pending
-(define (ssl-accept-ready? listener)
- (tcp-accept-ready? (ssl-unwrap-listener listener)))
+ ;; check whether an incoming connection is pending
+ (define (ssl-accept-ready? listener)
+ (tcp-accept-ready? (ssl-unwrap-listener listener)))
-(define ssl-set-accept-state! (foreign-lambda void "SSL_set_accept_state"
c-pointer))
+ (define ssl-set-accept-state! (foreign-lambda void "SSL_set_accept_state"
c-pointer))
-;; accept a connection from an SSL listener
-(define (ssl-accept listener)
- (receive (tcp-in tcp-out)
- (tcp-accept (ssl-unwrap-listener listener))
- (let* ((fd (net-unwrap-tcp-ports tcp-in tcp-out))
- (ctx (ssl-unwrap-listener-context listener))
- (ssl (ssl-new ctx)))
- (ssl-set-accept-state! ssl)
- (ssl-make-i/o-ports ctx fd ssl tcp-in tcp-out))))
+ ;; accept a connection from an SSL listener
+ (define (ssl-accept listener)
+ (receive (tcp-in tcp-out)
+ (tcp-accept (ssl-unwrap-listener listener))
+ (let* ((fd (net-unwrap-tcp-ports tcp-in tcp-out))
+ (ctx (ssl-unwrap-listener-context listener))
+ (ssl (ssl-new ctx)))
+ (ssl-set-accept-state! ssl)
+ (ssl-make-i/o-ports ctx fd ssl tcp-in tcp-out))))
-;; set the list of allowed ciphers
-(define (ssl-set-cipher-list! obj v)
- (ssl-clear-error)
- (unless (eq?
- ((foreign-lambda
- int "SSL_CTX_set_cipher_list" c-pointer c-string)
- (ssl-unwrap-context obj)
- (if (pair? v)
- (string-join (map ->string v) ":")
- (->string v)))
- 1)
- (ssl-abort 'ssl-set-cipher-list! #f v)))
+ ;; set the list of allowed ciphers
+ (define (ssl-set-cipher-list! obj v)
+ (ssl-clear-error)
+ (unless (eq?
+ ((foreign-lambda
+ int "SSL_CTX_set_cipher_list" c-pointer c-string)
+ (ssl-unwrap-context obj)
+ (if (pair? v)
+ (string-join (map ->string v) ":")
+ (->string v)))
+ 1)
+ (ssl-abort 'ssl-set-cipher-list! #f v)))
-;; load identifying certificate or certificate chain into SSL context
-(define (ssl-load-certificate-chain! obj pathname/blob #!optional (asn1? #f))
- (ssl-clear-error)
- (unless
- (eq?
- (if (blob? pathname/blob)
- ((foreign-lambda
- int "SSL_CTX_use_certificate_ASN1" c-pointer int scheme-pointer)
- (ssl-unwrap-context obj) (blob-size pathname/blob) pathname/blob)
- (begin
- (##sys#check-string pathname/blob)
- (if asn1?
- ((foreign-lambda*
- int ((c-pointer ctx) (c-string path))
- "return(SSL_CTX_use_certificate_file((SSL_CTX *)ctx, path,
SSL_FILETYPE_ASN1));")
- (ssl-unwrap-context obj) pathname/blob)
- ((foreign-lambda
- int "SSL_CTX_use_certificate_chain_file" c-pointer c-string)
- (ssl-unwrap-context obj) pathname/blob))))
- 1)
- (ssl-abort 'ssl-load-certificate-chain! #f pathname/blob asn1?)))
+ ;; load identifying certificate or certificate chain into SSL context
+ (define (ssl-load-certificate-chain! obj pathname/blob #!optional (asn1? #f))
+ (ssl-clear-error)
+ (unless
+ (eq?
+ (if (blob? pathname/blob)
+ ((foreign-lambda
+ int "SSL_CTX_use_certificate_ASN1" c-pointer int scheme-pointer)
+ (ssl-unwrap-context obj) (blob-size pathname/blob) pathname/blob)
+ (begin
+ (##sys#check-string pathname/blob)
+ (if asn1?
+ ((foreign-lambda*
+ int ((c-pointer ctx) (c-string path))
+ "return(SSL_CTX_use_certificate_file((SSL_CTX *)ctx, path,
SSL_FILETYPE_ASN1));")
+ (ssl-unwrap-context obj) pathname/blob)
+ ((foreign-lambda
+ int "SSL_CTX_use_certificate_chain_file" c-pointer
c-string)
+ (ssl-unwrap-context obj) pathname/blob))))
+ 1)
+ (ssl-abort 'ssl-load-certificate-chain! #f pathname/blob asn1?)))
-;; load the private key for the identifying certificate chain
-(define (ssl-load-private-key! obj pathname/blob #!optional (rsa? #t) (asn1?
#f))
- (ssl-clear-error)
- (unless
- (eq?
- (if (blob? pathname/blob)
- ((foreign-lambda
- int "SSL_CTX_use_PrivateKey_ASN1" int c-pointer scheme-pointer long)
- (case rsa?
- ((rsa #t)
- (foreign-value "EVP_PKEY_RSA" int))
- ((dsa #f)
- (foreign-value "EVP_PKEY_DSA" int))
- ((dh)
- (foreign-value "EVP_PKEY_DH" int))
- ((ec)
- (foreign-value "EVP_PKEY_EC" int))
- (else
- (abort
- (make-composite-condition
- (make-property-condition
- 'exn
- 'message "invalid key type"
- 'location 'ssl-load-private-key!
- 'arguments (list obj pathname/blob rsa? asn1?))
- (make-property-condition
- 'type)))))
- (ssl-unwrap-context obj) pathname/blob (blob-size pathname/blob))
- (begin
- (##sys#check-string pathname/blob)
- (if (memq rsa? '(rsa #t))
- ((foreign-lambda*
- int ((c-pointer ctx) (c-string path) (bool asn1))
- "return(SSL_CTX_use_RSAPrivateKey_file((SSL_CTX *)ctx, path,
(asn1 ? SSL_FILETYPE_ASN1 : SSL_FILETYPE_PEM)));")
- (ssl-unwrap-context obj) pathname/blob asn1?)
- ((foreign-lambda*
- int ((c-pointer ctx) (c-string path) (bool asn1))
- "return(SSL_CTX_use_PrivateKey_file((SSL_CTX *)ctx, path, (asn1
? SSL_FILETYPE_ASN1 : SSL_FILETYPE_PEM)));")
- (ssl-unwrap-context obj) pathname/blob asn1?))))
- 1)
- (ssl-abort 'ssl-load-private-key! #f pathname/blob rsa? asn1?)))
+ ;; load the private key for the identifying certificate chain
+ (define (ssl-load-private-key! obj pathname/blob #!optional (rsa? #t) (asn1?
#f))
+ (ssl-clear-error)
+ (unless
+ (eq?
+ (if (blob? pathname/blob)
+ ((foreign-lambda
+ int "SSL_CTX_use_PrivateKey_ASN1" int c-pointer scheme-pointer
long)
+ (case rsa?
+ ((rsa #t)
+ (foreign-value "EVP_PKEY_RSA" int))
+ ((dsa #f)
+ (foreign-value "EVP_PKEY_DSA" int))
+ ((dh)
+ (foreign-value "EVP_PKEY_DH" int))
+ ((ec)
+ (foreign-value "EVP_PKEY_EC" int))
+ (else
+ (abort
+ (make-composite-condition
+ (make-property-condition
+ 'exn
+ 'message "invalid key type"
+ 'location 'ssl-load-private-key!
+ 'arguments (list obj pathname/blob rsa? asn1?))
+ (make-property-condition
+ 'type)))))
+ (ssl-unwrap-context obj) pathname/blob (blob-size pathname/blob))
+ (begin
+ (##sys#check-string pathname/blob)
+ (if (memq rsa? '(rsa #t))
+ ((foreign-lambda*
+ int ((c-pointer ctx) (c-string path) (bool asn1))
+ "return(SSL_CTX_use_RSAPrivateKey_file((SSL_CTX *)ctx,
path, (asn1 ? SSL_FILETYPE_ASN1 : SSL_FILETYPE_PEM)));")
+ (ssl-unwrap-context obj) pathname/blob asn1?)
+ ((foreign-lambda*
+ int ((c-pointer ctx) (c-string path) (bool asn1))
+ "return(SSL_CTX_use_PrivateKey_file((SSL_CTX *)ctx, path,
(asn1 ? SSL_FILETYPE_ASN1 : SSL_FILETYPE_PEM)));")
+ (ssl-unwrap-context obj) pathname/blob asn1?))))
+ 1)
+ (ssl-abort 'ssl-load-private-key! #f pathname/blob rsa? asn1?)))
-;; switch verification of peer on or off
-(define (ssl-set-verify! obj v)
- ((foreign-lambda*
- void
- ((c-pointer ctx) (bool verify))
- "SSL_CTX_set_verify((SSL_CTX *)ctx,"
- " (verify ? SSL_VERIFY_PEER|SSL_VERIFY_FAIL_IF_NO_PEER_CERT"
- " : SSL_VERIFY_NONE), NULL);\n")
- (ssl-unwrap-context obj) v))
+ ;; switch verification of peer on or off
+ (define (ssl-set-verify! obj v)
+ ((foreign-lambda*
+ void
+ ((c-pointer ctx) (bool verify))
+ "SSL_CTX_set_verify((SSL_CTX *)ctx,"
+ " (verify ? SSL_VERIFY_PEER|SSL_VERIFY_FAIL_IF_NO_PEER_CERT"
+ " : SSL_VERIFY_NONE), NULL);\n")
+ (ssl-unwrap-context obj) v))
-;; load trusted root certificates into SSL context
-(define (ssl-load-verify-root-certificates! obj pathname #!optional (dirname
#f))
- (unless (boolean? pathname) (##sys#check-string pathname))
- (unless (boolean? dirname) (##sys#check-string dirname))
- (ssl-clear-error)
- (if (and (eq? pathname #t) (eq? dirname #t))
- (unless (eq?
- ((foreign-lambda
- int "SSL_CTX_set_default_verify_paths" c-pointer)
- (ssl-unwrap-context obj))
- 1)
- (ssl-abort 'ssl-load-verify-root-certificates! #f pathname dirname))
- (unless (eq?
- ((foreign-lambda
- int "SSL_CTX_load_verify_locations" c-pointer c-string c-string)
- (ssl-unwrap-context obj) pathname dirname)
- 1)
- (ssl-abort 'ssl-load-verify-root-certificates! #f pathname dirname))))
+ ;; load trusted root certificates into SSL context
+ (define (ssl-load-verify-root-certificates! obj pathname #!optional (dirname
#f))
+ (unless (boolean? pathname) (##sys#check-string pathname))
+ (unless (boolean? dirname) (##sys#check-string dirname))
+ (ssl-clear-error)
+ (if (and (eq? pathname #t) (eq? dirname #t))
+ (unless (eq?
+ ((foreign-lambda
+ int "SSL_CTX_set_default_verify_paths" c-pointer)
+ (ssl-unwrap-context obj))
+ 1)
+ (ssl-abort 'ssl-load-verify-root-certificates! #f pathname dirname))
+ (unless (eq?
+ ((foreign-lambda
+ int "SSL_CTX_load_verify_locations" c-pointer c-string
c-string)
+ (ssl-unwrap-context obj) pathname dirname)
+ 1)
+ (ssl-abort 'ssl-load-verify-root-certificates! #f pathname dirname))))
-;; load suggested root certificates into SSL context
-(define (ssl-load-suggested-certificate-authorities! obj pathname)
- (##sys#check-string pathname)
- (ssl-clear-error)
- (cond
- (((foreign-lambda c-pointer "SSL_load_client_CA_file" c-string) pathname)
- => (cut
- (foreign-lambda
- void "SSL_CTX_set_client_CA_list" c-pointer c-pointer)
- (ssl-unwrap-context obj) <>))
- (else
- (ssl-abort 'ssl-load-suggested-certificate-authorities! #f pathname))))
+ ;; load suggested root certificates into SSL context
+ (define (ssl-load-suggested-certificate-authorities! obj pathname)
+ (##sys#check-string pathname)
+ (ssl-clear-error)
+ (cond
+ (((foreign-lambda c-pointer "SSL_load_client_CA_file" c-string) pathname)
+ => (cut
+ (foreign-lambda
+ void "SSL_CTX_set_client_CA_list" c-pointer c-pointer)
+ (ssl-unwrap-context obj) <>))
+ (else
+ (ssl-abort 'ssl-load-suggested-certificate-authorities! #f pathname))))
-;; check whether the connection peer has presented a valid certificate
-(define (ssl-peer-verified? p)
- (ssl-port-startup p)
- (let ((ssl (ssl-port->ssl p)))
- (and ((foreign-lambda*
- bool ((c-pointer ssl))
- "C_return(SSL_get_verify_result(ssl) == X509_V_OK);")
- ssl)
- ((foreign-lambda*
- bool ((c-pointer ssl))
- "X509 *crt = SSL_get_peer_certificate(ssl);\n"
- "X509_free(crt);\n"
- "C_return(crt != NULL);\n")
- ssl))))
+ ;; check whether the connection peer has presented a valid certificate
+ (define (ssl-peer-verified? p)
+ (ssl-port-startup p)
+ (let ((ssl (ssl-port->ssl p)))
+ (and ((foreign-lambda*
+ bool ((c-pointer ssl))
+ "C_return(SSL_get_verify_result(ssl) == X509_V_OK);")
+ ssl)
+ ((foreign-lambda*
+ bool ((c-pointer ssl))
+ "X509 *crt = SSL_get_peer_certificate(ssl);\n"
+ "X509_free(crt);\n"
+ "C_return(crt != NULL);\n")
+ ssl))))
-;; obtain the subject name of the connection peer's certificate, if any
-(define (ssl-peer-subject-name p)
- (ssl-port-startup p)
- ((foreign-lambda*
- c-string* ((c-pointer ssl))
- "X509 *crt = SSL_get_peer_certificate(ssl);\n"
- "if (!crt) C_return(NULL);\n"
- "char *name = X509_NAME_oneline(X509_get_subject_name(crt), NULL, -1);\n"
- "X509_free(crt);\n"
- "C_return(name);")
- (ssl-port->ssl p)))
+ ;; obtain the subject name of the connection peer's certificate, if any
+ (define (ssl-peer-subject-name p)
+ (ssl-port-startup p)
+ ((foreign-lambda*
+ c-string* ((c-pointer ssl))
+ "X509 *crt = SSL_get_peer_certificate(ssl);\n"
+ "if (!crt) C_return(NULL);\n"
+ "char *name = X509_NAME_oneline(X509_get_subject_name(crt), NULL, -1);\n"
+ "X509_free(crt);\n"
+ "C_return(name);")
+ (ssl-port->ssl p)))
-;; obtain the issuer name of the connection peer's certificate, if any
-(define (ssl-peer-issuer-name p)
- (ssl-port-startup p)
- ((foreign-lambda*
- c-string* ((c-pointer ssl))
- "X509 *crt = SSL_get_peer_certificate(ssl);\n"
- "if (!crt) C_return(NULL);\n"
- "char *name = X509_NAME_oneline(X509_get_issuer_name(crt), NULL, -1);\n"
- "X509_free(crt);\n"
- "C_return(name);")
- (ssl-port->ssl p)))
+ ;; obtain the issuer name of the connection peer's certificate, if any
+ (define (ssl-peer-issuer-name p)
+ (ssl-port-startup p)
+ ((foreign-lambda*
+ c-string* ((c-pointer ssl))
+ "X509 *crt = SSL_get_peer_certificate(ssl);\n"
+ "if (!crt) C_return(NULL);\n"
+ "char *name = X509_NAME_oneline(X509_get_issuer_name(crt), NULL, -1);\n"
+ "X509_free(crt);\n"
+ "C_return(name);")
+ (ssl-port->ssl p)))
;;; wrappers with secure defaults
-(define ssl-default-certificate-authorities
- (make-parameter #t))
+ (define ssl-default-certificate-authorities
+ (make-parameter #t))
-(define ssl-default-certificate-authority-directory
- (make-parameter #t))
+ (define ssl-default-certificate-authority-directory
+ (make-parameter #t))
-(define (ssl-make-client-context* #!key (protocol 'tlsv12) (cipher-list
"DEFAULT") certificate private-key (private-key-type 'rsa) private-key-asn1?
certificate-authorities certificate-authority-directory (verify? #t))
- (unless certificate-authorities
- (set! certificate-authorities (ssl-default-certificate-authorities)))
- (unless certificate-authority-directory
- (set! certificate-authority-directory
(ssl-default-certificate-authority-directory)))
- (let ((ctx (ssl-make-client-context protocol)))
- (ssl-set-cipher-list! ctx cipher-list)
- (when certificate
- (ssl-load-certificate-chain! ctx certificate)
- (ssl-load-private-key! ctx private-key private-key-type
private-key-asn1?))
- (ssl-load-verify-root-certificates! ctx certificate-authorities
certificate-authority-directory)
- (ssl-set-verify! ctx verify?)
- ctx))
+ (define (ssl-make-client-context* #!key (protocol 'tlsv12) (cipher-list
"DEFAULT") certificate private-key (private-key-type 'rsa) private-key-asn1?
certificate-authorities certificate-authority-directory (verify? #t))
+ (unless certificate-authorities
+ (set! certificate-authorities (ssl-default-certificate-authorities)))
+ (unless certificate-authority-directory
+ (set! certificate-authority-directory
(ssl-default-certificate-authority-directory)))
+ (let ((ctx (ssl-make-client-context protocol)))
+ (ssl-set-cipher-list! ctx cipher-list)
+ (when certificate
+ (ssl-load-certificate-chain! ctx certificate)
+ (ssl-load-private-key! ctx private-key private-key-type
private-key-asn1?))
+ (ssl-load-verify-root-certificates! ctx certificate-authorities
certificate-authority-directory)
+ (ssl-set-verify! ctx verify?)
+ ctx))
-(define (ssl-connect* #!rest args #!key hostname port (sni-name #t))
- (ssl-connect hostname port (apply ssl-make-client-context* args) sni-name))
+ (define (ssl-connect* #!rest args #!key hostname port (sni-name #t))
+ (ssl-connect hostname port (apply ssl-make-client-context* args) sni-name))
-(define (ssl-listen* #!key hostname (port 0) (backlog 4) (protocol 'tlsv12)
(cipher-list "DEFAULT") certificate private-key (private-key-type 'rsa)
private-key-asn1? certificate-authorities certificate-authority-directory
(verify? #f))
- (unless certificate-authorities
- (set! certificate-authorities (ssl-default-certificate-authorities)))
- (unless certificate-authority-directory
- (set! certificate-authority-directory
(ssl-default-certificate-authority-directory)))
- (let ((ear (ssl-listen port backlog hostname protocol)))
- (ssl-set-cipher-list! ear cipher-list)
- (ssl-load-certificate-chain! ear certificate)
- (ssl-load-private-key! ear private-key private-key-type private-key-asn1?)
- (when (string? certificate-authorities)
- (ssl-load-suggested-certificate-authorities! ear
certificate-authorities))
- (ssl-load-verify-root-certificates! ear certificate-authorities
certificate-authority-directory)
- (ssl-set-verify! ear verify?)
- ear))
+ (define (ssl-listen* #!key hostname (port 0) (backlog 4) (protocol 'tlsv12)
(cipher-list "DEFAULT") certificate private-key (private-key-type 'rsa)
private-key-asn1? certificate-authorities certificate-authority-directory
(verify? #f))
+ (unless certificate-authorities
+ (set! certificate-authorities (ssl-default-certificate-authorities)))
+ (unless certificate-authority-directory
+ (set! certificate-authority-directory
(ssl-default-certificate-authority-directory)))
+ (let ((ear (ssl-listen port backlog hostname protocol)))
+ (ssl-set-cipher-list! ear cipher-list)
+ (ssl-load-certificate-chain! ear certificate)
+ (ssl-load-private-key! ear private-key private-key-type
private-key-asn1?)
+ (when (string? certificate-authorities)
+ (ssl-load-suggested-certificate-authorities! ear
certificate-authorities))
+ (ssl-load-verify-root-certificates! ear certificate-authorities
certificate-authority-directory)
+ (ssl-set-verify! ear verify?)
+ ear))
-(define (ssl-start* server? tcp-in tcp-out #!key (protocol 'tlsv12)
(cipher-list "DEFAULT") certificate private-key (private-key-type 'rsa)
private-key-asn1? certificate-authorities certificate-authority-directory
(verify? (not server?)) sni-name)
- (unless certificate-authorities
- (set! certificate-authorities (ssl-default-certificate-authorities)))
- (unless certificate-authority-directory
- (set! certificate-authority-directory
(ssl-default-certificate-authority-directory)))
- ;; ssl-wrap-client-context only serves a technical purpose here,
- ;; as the plain context pointer needs to be wrapped somehow.
- (let ((ctx (ssl-wrap-client-context (ssl-ctx-new protocol server?))))
- (ssl-set-cipher-list! ctx cipher-list)
- (when certificate
- (ssl-load-certificate-chain! ctx certificate)
- (ssl-load-private-key! ctx private-key private-key-type
private-key-asn1?))
- (when (string? certificate-authorities)
- (ssl-load-suggested-certificate-authorities! ctx
certificate-authorities))
- (ssl-load-verify-root-certificates! ctx certificate-authorities
certificate-authority-directory)
- (ssl-set-verify! ctx verify?)
- (let* ((fd (net-unwrap-tcp-ports tcp-in tcp-out))
- (ssl (ssl-new (ssl-unwrap-client-context ctx))))
- (if server?
- (ssl-set-accept-state! ssl)
- (begin
- (when sni-name
- (ssl-set-tlsext-hostname! ssl sni-name))
- (ssl-set-connect-state! ssl)))
- (ssl-make-i/o-ports ctx fd ssl tcp-in tcp-out))))
+ (define (ssl-start* server? tcp-in tcp-out #!key (protocol 'tlsv12)
(cipher-list "DEFAULT") certificate private-key (private-key-type 'rsa)
private-key-asn1? certificate-authorities certificate-authority-directory
(verify? (not server?)) sni-name)
+ (unless certificate-authorities
+ (set! certificate-authorities (ssl-default-certificate-authorities)))
+ (unless certificate-authority-directory
+ (set! certificate-authority-directory
(ssl-default-certificate-authority-directory)))
+ ;; ssl-wrap-client-context only serves a technical purpose here,
+ ;; as the plain context pointer needs to be wrapped somehow.
+ (let ((ctx (ssl-wrap-client-context (ssl-ctx-new protocol server?))))
+ (ssl-set-cipher-list! ctx cipher-list)
+ (when certificate
+ (ssl-load-certificate-chain! ctx certificate)
+ (ssl-load-private-key! ctx private-key private-key-type
private-key-asn1?))
+ (when (string? certificate-authorities)
+ (ssl-load-suggested-certificate-authorities! ctx
certificate-authorities))
+ (ssl-load-verify-root-certificates! ctx certificate-authorities
certificate-authority-directory)
+ (ssl-set-verify! ctx verify?)
+ (let* ((fd (net-unwrap-tcp-ports tcp-in tcp-out))
+ (ssl (ssl-new (ssl-unwrap-client-context ctx))))
+ (if server?
+ (ssl-set-accept-state! ssl)
+ (begin
+ (when sni-name
+ (ssl-set-tlsext-hostname! ssl sni-name))
+ (ssl-set-connect-state! ssl)))
+ (ssl-make-i/o-ports ctx fd ssl tcp-in tcp-out))))
-)
+ )
