diff --git a/basis/io/sockets/secure/openssl/openssl.factor b/basis/io/sockets/secure/openssl/openssl.factor index 0c6aba05f0..547d6d97da 100644 --- a/basis/io/sockets/secure/openssl/openssl.factor +++ b/basis/io/sockets/secure/openssl/openssl.factor @@ -1,12 +1,11 @@ ! Copyright (C) 2007, 2008, Slava Pestov, Elie CHAFTARI. ! See http://factorcode.org/license.txt for BSD license. USING: accessors alien alien.c-types alien.data alien.strings -assocs byte-arrays classes.struct combinators destructors -io.backend io.encodings.8-bit.latin1 io.encodings.utf8 -io.pathnames io.sockets.secure kernel libc locals math -math.order math.parser namespaces openssl openssl.libcrypto -openssl.libssl random sequences splitting unicode.case -io.files ; +assocs byte-arrays classes.struct combinators destructors fry +io.backend io.buffers io.encodings.8-bit.latin1 io.encodings.utf8 +io.files io.pathnames io.sockets.secure io.timeouts kernel libc +locals math math.order math.parser namespaces openssl openssl.libssl +openssl.libcrypto random sequences splitting unicode.case ; IN: io.sockets.secure.openssl GENERIC: ssl-method ( symbol -- method ) @@ -161,6 +160,12 @@ SYMBOL: default-secure-context ] initialize-alien ] unless* ; +: get-session ( addrspec -- session/f ) + current-secure-context sessions>> at ; + +: save-session ( session addrspec -- ) + current-secure-context sessions>> set-at ; + : ( fd -- ssl ) [ ssl-handle new-disposable |dispose @@ -169,6 +174,130 @@ SYMBOL: default-secure-context swap >>file ] with-destructors ; +: syscall-error ( handle r -- event ) + nip + ERR_get_error [ + { + { -1 [ errno ECONNRESET = [ premature-close ] [ (io-error) ] 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-response ( port r -- port r n ) + over handle>> handle>> over SSL_get_error ; inline + +: check-accept-response ( handle r -- event ) + over handle>> over SSL_get_error + { + { SSL_ERROR_NONE [ 2drop f ] } + { SSL_ERROR_WANT_READ [ 2drop +input+ ] } + { SSL_ERROR_WANT_ACCEPT [ 2drop +input+ ] } + { SSL_ERROR_WANT_WRITE [ 2drop +output+ ] } + { SSL_ERROR_SYSCALL [ syscall-error ] } + { SSL_ERROR_ZERO_RETURN [ (ssl-error) ] } + { SSL_ERROR_SSL [ (ssl-error) ] } + } case ; + +! Does this work on windows? +: do-ssl-accept ( ssl-handle -- ) + dup dup handle>> SSL_accept check-accept-response dup + [ + [ dup file>> ] dip + 2drop ! wait-for-fd, todo: figure out wait-for-fd for windows + do-ssl-accept + ] [ 2drop ] if ; + +: maybe-handshake ( ssl-handle -- ) + dup connected>> [ drop ] [ + t >>connected + [ do-ssl-accept ] with-timeout + ] if ; + +! Input ports +: check-read-response ( port r -- event ) + check-response + { + { SSL_ERROR_NONE [ swap buffer>> n>buffer f ] } + { SSL_ERROR_ZERO_RETURN [ 2drop f ] } + { SSL_ERROR_WANT_READ [ 2drop +input+ ] } + { SSL_ERROR_WANT_WRITE [ 2drop +output+ ] } + { SSL_ERROR_SYSCALL [ syscall-error ] } + { SSL_ERROR_SSL [ (ssl-error) ] } + } case ; + +M: ssl-handle refill + dup maybe-handshake + handle>> ! ssl + over buffer>> + [ buffer-end ] ! buf + [ buffer-capacity ] bi ! len + SSL_read + check-read-response ; + +! Output ports +: check-write-response ( port r -- event ) + check-response + { + { SSL_ERROR_NONE [ swap buffer>> buffer-consume f ] } + { SSL_ERROR_WANT_READ [ 2drop +input+ ] } + { SSL_ERROR_WANT_WRITE [ 2drop +output+ ] } + { SSL_ERROR_SYSCALL [ syscall-error ] } + { SSL_ERROR_SSL [ (ssl-error) ] } + } case ; + +M: ssl-handle drain + dup maybe-handshake + handle>> ! ssl + over buffer>> + [ buffer@ ] ! buf + [ buffer-length ] bi ! len + SSL_write + check-write-response ; + +! Connect +: check-connect-response ( ssl-handle r -- event ) + 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 [ syscall-error ] } + { SSL_ERROR_SSL [ (ssl-error) ] } + } case ; + +: do-ssl-connect ( ssl-handle -- ) + dup dup handle>> SSL_connect check-connect-response dup + [ dupd 2drop do-ssl-connect ] [ 2drop ] if ; + +: resume-session ( ssl-handle ssl-session -- ) + [ [ handle>> ] dip SSL_set_session ssl-error ] + [ drop do-ssl-connect ] + 2bi ; + +: begin-session ( ssl-handle addrspec -- ) + [ drop do-ssl-connect ] + [ [ handle>> SSL_get1_session ] dip save-session ] + 2bi ; + +: secure-connection ( client-out addrspec -- ) + [ handle>> ] dip + [ + '[ + _ dup get-session + [ resume-session ] [ begin-session ] ?if + ] with-timeout + ] [ drop t >>connected drop ] 2bi ; + +M: ssl-handle timeout + drop secure-socket-timeout get ; + +M: ssl-handle cancel-operation + file>> cancel-operation ; + M: ssl-handle dispose* [ ! Free file>> after SSL_free @@ -218,10 +347,4 @@ M: openssl check-certificate ( host ssl -- ) 2bi ] [ 2drop ] if ; -: get-session ( addrspec -- session/f ) - current-secure-context sessions>> at ; - -: save-session ( session addrspec -- ) - current-secure-context sessions>> set-at ; - openssl secure-socket-backend set-global diff --git a/basis/io/sockets/secure/unix/unix.factor b/basis/io/sockets/secure/unix/unix.factor index 7905dfd6e3..46d30fc1cb 100644 --- a/basis/io/sockets/secure/unix/unix.factor +++ b/basis/io/sockets/secure/unix/unix.factor @@ -16,91 +16,6 @@ M: openssl ssl-certificate-verification-supported? t ; M: ssl-handle handle-fd file>> handle-fd ; -: syscall-error ( handle r -- event ) - nip - ERR_get_error [ - { - { -1 [ errno ECONNRESET = [ premature-close ] [ (io-error) ] 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-accept-response ( handle r -- event ) - over handle>> over SSL_get_error - { - { SSL_ERROR_NONE [ 2drop f ] } - { SSL_ERROR_WANT_READ [ 2drop +input+ ] } - { SSL_ERROR_WANT_ACCEPT [ 2drop +input+ ] } - { SSL_ERROR_WANT_WRITE [ 2drop +output+ ] } - { SSL_ERROR_SYSCALL [ syscall-error ] } - { SSL_ERROR_ZERO_RETURN [ (ssl-error) ] } - { SSL_ERROR_SSL [ (ssl-error) ] } - } case ; - -: do-ssl-accept ( ssl-handle -- ) - dup dup handle>> SSL_accept check-accept-response dup - [ [ dup file>> ] dip wait-for-fd do-ssl-accept ] [ 2drop ] if ; - -: maybe-handshake ( ssl-handle -- ) - dup connected>> [ drop ] [ - t >>connected - [ do-ssl-accept ] with-timeout - ] if ; - -: check-response ( port r -- port r n ) - over handle>> handle>> over SSL_get_error ; inline - -! Input ports -: check-read-response ( port r -- event ) - check-response - { - { SSL_ERROR_NONE [ swap buffer>> n>buffer f ] } - { SSL_ERROR_ZERO_RETURN [ 2drop f ] } - { SSL_ERROR_WANT_READ [ 2drop +input+ ] } - { SSL_ERROR_WANT_WRITE [ 2drop +output+ ] } - { SSL_ERROR_SYSCALL [ syscall-error ] } - { SSL_ERROR_SSL [ (ssl-error) ] } - } case ; - -M: ssl-handle refill - dup maybe-handshake - handle>> ! ssl - over buffer>> - [ buffer-end ] ! buf - [ buffer-capacity ] bi ! len - SSL_read - check-read-response ; - -! Output ports -: check-write-response ( port r -- event ) - check-response - { - { SSL_ERROR_NONE [ swap buffer>> buffer-consume f ] } - { SSL_ERROR_WANT_READ [ 2drop +input+ ] } - { SSL_ERROR_WANT_WRITE [ 2drop +output+ ] } - { SSL_ERROR_SYSCALL [ syscall-error ] } - { SSL_ERROR_SSL [ (ssl-error) ] } - } case ; - -M: ssl-handle drain - dup maybe-handshake - handle>> ! ssl - over buffer>> - [ buffer@ ] ! buf - [ buffer-length ] bi ! len - SSL_write - check-write-response ; - -M: ssl-handle cancel-operation - file>> cancel-operation ; - -M: ssl-handle timeout - drop secure-socket-timeout get ; - ! Client sockets : ( fd -- ssl ) [ fd>> BIO_NOCLOSE BIO_new_socket dup ssl-error ] keep @@ -113,39 +28,6 @@ M: secure parse-sockaddr addrspec>> parse-sockaddr ; M: secure (get-local-address) addrspec>> (get-local-address) ; -: check-connect-response ( ssl-handle r -- event ) - 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 [ syscall-error ] } - { SSL_ERROR_SSL [ (ssl-error) ] } - } case ; - -: do-ssl-connect ( ssl-handle -- ) - dup dup handle>> SSL_connect check-connect-response dup - [ dupd wait-for-fd do-ssl-connect ] [ 2drop ] if ; - -: resume-session ( ssl-handle ssl-session -- ) - [ [ handle>> ] dip SSL_set_session ssl-error ] - [ drop do-ssl-connect ] - 2bi ; - -: begin-session ( ssl-handle addrspec -- ) - [ drop do-ssl-connect ] - [ [ handle>> SSL_get1_session ] dip save-session ] - 2bi ; - -: secure-connection ( client-out addrspec -- ) - [ handle>> ] dip - [ - '[ - _ dup get-session - [ resume-session ] [ begin-session ] ?if - ] with-timeout - ] [ drop t >>connected drop ] 2bi ; - M: secure establish-connection ( client-out remote -- ) addrspec>> [ establish-connection ] [ secure-connection ] 2bi ; diff --git a/basis/io/sockets/secure/windows/windows.factor b/basis/io/sockets/secure/windows/windows.factor index c252e14211..a4887bd14b 100644 --- a/basis/io/sockets/secure/windows/windows.factor +++ b/basis/io/sockets/secure/windows/windows.factor @@ -1,76 +1,19 @@ USING: accessors - alien alien.c-types alien.data - combinators - fry - io.buffers - io.files + alien io.ports io.sockets.private io.sockets.secure io.sockets.secure.openssl - io.timeouts kernel - namespaces openssl openssl.libcrypto openssl.libssl ; IN: io.sockets.secure.windows -! Most of this vocab is duplicated code from io.sockets.secure.unix so -! you could probably unify them. M: openssl ssl-supported? t ; M: openssl ssl-certificate-verification-supported? f ; -: check-response ( port r -- port r n ) - over handle>> handle>> over SSL_get_error ; inline - -: check-read-response ( port r -- event ) - check-response - { - { SSL_ERROR_NONE [ swap buffer>> n>buffer f ] } - { SSL_ERROR_ZERO_RETURN [ 2drop f ] } - { SSL_ERROR_WANT_READ [ 2drop "input" ] } - { SSL_ERROR_WANT_WRITE [ 2drop "output" ] } - { SSL_ERROR_SYSCALL [ syscall-error ] } - { SSL_ERROR_SSL [ (ssl-error) ] } - } case ; - -: maybe-handshake ( ssl-handle -- ) - dup connected>> [ drop ] [ - t >>connected - [ do-ssl-accept ] with-timeout - ] if ; - -M: ssl-handle refill - dup maybe-handshake - handle>> ! ssl - over buffer>> - [ buffer-end ] ! buf - [ buffer-capacity ] bi ! len - SSL_read - check-read-response ; - -: check-write-response ( port r -- event ) - check-response - { - { SSL_ERROR_NONE [ swap buffer>> buffer-consume f ] } - { SSL_ERROR_WANT_READ [ 2drop "input!" ] } - { SSL_ERROR_WANT_WRITE [ 2drop "output!" ] } - { SSL_ERROR_SYSCALL [ syscall-error ] } - { SSL_ERROR_SSL [ (ssl-error) ] } - } case ; - -M: ssl-handle drain - dup maybe-handshake - handle>> ! ssl - over buffer>> - [ buffer@ ] ! buf - [ buffer-length ] bi ! len - SSL_write - check-write-response ; - -M: ssl-handle timeout - drop secure-socket-timeout get ; - : ( winsock -- ssl ) - [ handle>> alien-address BIO_NOCLOSE BIO_new_socket ] keep + [ + handle>> alien-address BIO_NOCLOSE BIO_new_socket dup ssl-error + ] keep [ handle>> swap dup SSL_set_bio ] keep ; M: secure ((client)) ( addrspec -- handle ) @@ -81,49 +24,6 @@ M: secure (get-local-address) ( handle remote -- sockaddr ) M: secure parse-sockaddr addrspec>> parse-sockaddr ; -! The error codes needs to be handled properly. -: check-connect-response ( ssl-handle r -- event ) - over handle>> over SSL_get_error - { - { SSL_ERROR_NONE [ 2drop f ] } - { - SSL_ERROR_WANT_READ - [ 2drop "input route" ] - } - { - SSL_ERROR_WANT_WRITE - [ 2drop "output route" ] - } - { - SSL_ERROR_SYSCALL - [ 2drop "syscall error" ] - } - { SSL_ERROR_SSL [ (ssl-error) ] } - } case ; - -: do-ssl-connect ( ssl-handle -- ) - dup dup handle>> SSL_connect check-connect-response dup - [ dupd 2drop do-ssl-connect ] [ 2drop ] if ; - -: resume-session ( ssl-handle ssl-session -- ) - [ [ handle>> ] dip SSL_set_session ssl-error ] - [ drop do-ssl-connect ] - 2bi ; - -: begin-session ( ssl-handle addrspec -- ) - [ drop do-ssl-connect ] - [ [ handle>> SSL_get1_session ] dip save-session ] - 2bi ; - -: secure-connection ( client-out addrspec -- ) - [ handle>> ] dip - [ - '[ - _ dup get-session - [ resume-session ] [ begin-session ] ?if - ] with-timeout - ] [ drop t >>connected drop ] 2bi ; - M: secure establish-connection ( client-out remote -- ) [ [ handle>> file>> ] [ addrspec>> ] bi* establish-connection