! See http://factorcode.org/license.txt for BSD license.
USING: accessors alien alien.c-types alien.data alien.enums
alien.strings assocs byte-arrays classes.struct combinators
-combinators.short-circuit destructors fry io io.backend
-io.binary io.buffers io.encodings.latin1 io.encodings.string
+combinators.short-circuit destructors io io.backend io.binary
+io.buffers io.encodings.latin1 io.encodings.string
io.encodings.utf8 io.files io.pathnames io.ports io.sockets
-io.sockets.secure io.timeouts kernel libc locals math
-math.functions math.order math.parser memoize namespaces openssl
-openssl.libcrypto openssl.libssl random sequences sets splitting
-unicode ;
+io.sockets.secure io.timeouts kernel libc math math.functions
+math.order math.parser namespaces openssl openssl.libcrypto
+openssl.libssl random sequences sets splitting unicode ;
SLOT: alpn-supported-protocols
IN: io.sockets.secure.openssl
native-handle bio bio SSL_set_bio
handle ;
-! Error handling
-: syscall-error ( r -- event )
- ERR_get_error [
- {
- { -1 [
- errno ECONNRESET = [ premature-close ]
- [ throw-errno ] if
- ] }
- ! OpenSSL docs say this it is an error condition for
- ! a server to not send a close notify, but web
- ! servers in the wild don't seem to do this, for
- ! example https://www.google.com.
- { 0 [ f ] }
- } case
- ] [ nip (ssl-error) ] if-zero ;
-
-: check-ssl-error ( ssl ret extra-cases/f -- event/f )
- [ tuck SSL_get_error ] dip
+: ssl-error-syscall ( ssl-handle -- event/f )
+ f >>connected drop
+ ERR_get_error {
+ { -1 [
+ errno { [ ECONNRESET = ] [ EPIPE = ] } 1||
+ [ premature-close ] [ throw-errno ] if f
+ ] }
+ ! https://stackoverflow.com/questions/13686398/ssl-read-failing-with-ssl-error-syscall-error
+ ! 0 means EOF
+ { 0 [ f ] }
+ } case ;
+
+: check-ssl-error ( ssl-handle ret -- event/f )
+ [ drop ] [ [ handle>> ] dip SSL_get_error ] 2bi
{
{ SSL_ERROR_NONE [ drop f ] }
{ SSL_ERROR_WANT_READ [ drop +input+ ] }
{ SSL_ERROR_WANT_WRITE [ drop +output+ ] }
- { SSL_ERROR_SYSCALL [ syscall-error ] }
+ { SSL_ERROR_SYSCALL [ ssl-error-syscall ] }
{ SSL_ERROR_SSL [ drop (ssl-error) ] }
- } append [ [ execute( -- n ) ] dip ] assoc-map
- at [ call( x -- y ) ] [ no-cond ] if* ;
+ { SSL_ERROR_ZERO_RETURN [ drop f ] }
+ { SSL_ERROR_WANT_ACCEPT [ drop +input+ ] }
+ } case ;
! Accept
-: do-ssl-accept-once ( ssl -- event/f )
- dup SSL_accept {
- { SSL_ERROR_ZERO_RETURN [ (ssl-error) ] }
- { SSL_ERROR_WANT_ACCEPT [ drop +input+ ] }
- } check-ssl-error ;
+: do-ssl-accept-once ( ssl-handle -- event/f )
+ dup handle>> SSL_accept check-ssl-error ;
: do-ssl-accept ( ssl-handle -- )
- dup handle>> do-ssl-accept-once
+ dup do-ssl-accept-once
[ [ dup file>> ] dip wait-for-fd do-ssl-accept ] [ drop ] if* ;
: maybe-handshake ( ssl-handle -- )
] if ;
! Input ports
-: do-ssl-read ( buffer ssl -- event/f )
- 2dup swap [ buffer-end ] [ buffer-capacity ] bi SSL_read [
- { { SSL_ERROR_ZERO_RETURN [ drop f ] } } check-ssl-error
- ] keep swap [ 2nip ] [ swap buffer+ f ] if* ;
+: do-ssl-read ( buffer ssl-handle -- event/f )
+ 2dup handle>> swap [ buffer-end ] [ buffer-capacity ] bi SSL_read
+ [ check-ssl-error ] keep swap [ 2nip ] [ swap buffer+ f ] if* ;
M: ssl-handle refill
- dup maybe-handshake [ buffer>> ] [ handle>> ] bi* do-ssl-read ;
+ dup maybe-handshake [ buffer>> ] dip do-ssl-read ;
! Output ports
-: do-ssl-write ( buffer ssl -- event/f )
- 2dup swap [ buffer@ ] [ buffer-length ] bi SSL_write
- [ f check-ssl-error ] keep swap [ 2nip ] [ swap buffer-consume f ] if* ;
+: do-ssl-write ( buffer ssl-handle -- event/f )
+ 2dup handle>> swap [ buffer@ ] [ buffer-length ] bi SSL_write
+ [ check-ssl-error ] keep swap [ 2nip ] [ swap buffer-consume f ] if* ;
M: ssl-handle drain
- dup maybe-handshake [ buffer>> ] [ handle>> ] bi* do-ssl-write ;
+ dup maybe-handshake [ buffer>> ] dip do-ssl-write ;
! Connect
-: do-ssl-connect-once ( ssl -- event/f )
- dup SSL_connect f check-ssl-error ;
+: do-ssl-connect-once ( ssl-handle -- event/f )
+ dup handle>> SSL_connect check-ssl-error ;
: do-ssl-connect ( ssl-handle -- )
- dup handle>> do-ssl-connect-once
+ dup do-ssl-connect-once
[ dupd wait-for-fd do-ssl-connect ] [ drop ] if* ;
: resume-session ( ssl-handle ssl-session -- )
! Copyright (C) 2007, 2011, Slava Pestov, Elie CHAFTARI.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors combinators destructors io.backend.unix
-io.files io.sockets.private io.sockets.secure
-io.sockets.secure.openssl io.timeouts kernel math openssl
-openssl.libssl system ;
+USING: accessors destructors io.backend.unix io.files
+io.sockets.private io.sockets.secure io.sockets.secure.openssl
+io.timeouts kernel openssl openssl.libssl system ;
FROM: io.ports => shutdown ;
IN: io.sockets.secure.unix
addrspec>> (accept) [ |dispose f <ssl-socket> ] dip
] with-destructors ;
-: check-shutdown-response ( handle r -- event )
- ! We don't do two-step shutdown here because I couldn't
- ! figure out how to do it with non-blocking BIOs. Also, it
- ! seems that SSL_shutdown always returns 0 -- this sounds
- ! like a bug
- over handle>> over SSL_get_error
- {
- { SSL_ERROR_NONE [ 2drop f ] }
- { SSL_ERROR_WANT_READ [ 2drop +input+ ] }
- { SSL_ERROR_WANT_WRITE [ 2drop +output+ ] }
- { SSL_ERROR_SYSCALL [ [ drop f ] [ nip syscall-error ] if-zero ] }
- { SSL_ERROR_SSL [ (ssl-error) ] }
- } case ;
-
-: (shutdown) ( handle -- )
- dup dup handle>> SSL_shutdown check-shutdown-response
+: try-ssl-shutdown ( ssl-handle -- event )
+ dup handle>> SSL_shutdown check-ssl-error ;
+
+: (shutdown) ( ssl-handle -- )
+ dup try-ssl-shutdown
[ dupd wait-for-fd (shutdown) ] [ drop ] if* ;
M: ssl-handle shutdown